1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNARL is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This is a NT (native) version of this package 33 34-- This package contains all the GNULL primitives that interface directly with 35-- the underlying OS. 36 37pragma Polling (Off); 38-- Turn off polling, we do not want ATC polling to take place during tasking 39-- operations. It causes infinite loops and other problems. 40 41with Interfaces.C; 42with Interfaces.C.Strings; 43 44with System.Float_Control; 45with System.Interrupt_Management; 46with System.Multiprocessors; 47with System.OS_Primitives; 48with System.Task_Info; 49with System.Tasking.Debug; 50with System.Win32.Ext; 51 52with System.Soft_Links; 53-- We use System.Soft_Links instead of System.Tasking.Initialization because 54-- the later is a higher level package that we shouldn't depend on. For 55-- example when using the restricted run time, it is replaced by 56-- System.Tasking.Restricted.Stages. 57 58package body System.Task_Primitives.Operations is 59 60 package SSL renames System.Soft_Links; 61 62 use Interfaces.C; 63 use Interfaces.C.Strings; 64 use System.OS_Interface; 65 use System.OS_Primitives; 66 use System.Parameters; 67 use System.Task_Info; 68 use System.Tasking; 69 use System.Tasking.Debug; 70 use System.Win32; 71 use System.Win32.Ext; 72 73 pragma Link_With ("-Xlinker --stack=0x200000,0x1000"); 74 -- Change the default stack size (2 MB) for tasking programs on Windows. 75 -- This allows about 1000 tasks running at the same time. Note that 76 -- we set the stack size for non tasking programs on System unit. 77 -- Also note that under Windows XP, we use a Windows XP extension to 78 -- specify the stack size on a per task basis, as done under other OSes. 79 80 --------------------- 81 -- Local Functions -- 82 --------------------- 83 84 procedure InitializeCriticalSection (pCriticalSection : access RTS_Lock); 85 procedure InitializeCriticalSection 86 (pCriticalSection : access CRITICAL_SECTION); 87 pragma Import 88 (Stdcall, InitializeCriticalSection, "InitializeCriticalSection"); 89 90 procedure EnterCriticalSection (pCriticalSection : access RTS_Lock); 91 procedure EnterCriticalSection 92 (pCriticalSection : access CRITICAL_SECTION); 93 pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection"); 94 95 procedure LeaveCriticalSection (pCriticalSection : access RTS_Lock); 96 procedure LeaveCriticalSection (pCriticalSection : access CRITICAL_SECTION); 97 pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection"); 98 99 procedure DeleteCriticalSection (pCriticalSection : access RTS_Lock); 100 procedure DeleteCriticalSection 101 (pCriticalSection : access CRITICAL_SECTION); 102 pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection"); 103 104 ---------------- 105 -- Local Data -- 106 ---------------- 107 108 Environment_Task_Id : Task_Id; 109 -- A variable to hold Task_Id for the environment task 110 111 Single_RTS_Lock : aliased RTS_Lock; 112 -- This is a lock to allow only one thread of control in the RTS at 113 -- a time; it is used to execute in mutual exclusion from all other tasks. 114 -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List 115 116 Time_Slice_Val : Integer; 117 pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); 118 119 Dispatching_Policy : Character; 120 pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); 121 122 function Get_Policy (Prio : System.Any_Priority) return Character; 123 pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); 124 -- Get priority specific dispatching policy 125 126 Foreign_Task_Elaborated : aliased Boolean := True; 127 -- Used to identified fake tasks (i.e., non-Ada Threads) 128 129 Null_Thread_Id : constant Thread_Id := 0; 130 -- Constant to indicate that the thread identifier has not yet been 131 -- initialized. 132 133 ------------------------------------ 134 -- The thread local storage index -- 135 ------------------------------------ 136 137 TlsIndex : DWORD; 138 pragma Export (Ada, TlsIndex); 139 -- To ensure that this variable won't be local to this package, since 140 -- in some cases, inlining forces this variable to be global anyway. 141 142 -------------------- 143 -- Local Packages -- 144 -------------------- 145 146 package Specific is 147 148 function Is_Valid_Task return Boolean; 149 pragma Inline (Is_Valid_Task); 150 -- Does executing thread have a TCB? 151 152 procedure Set (Self_Id : Task_Id); 153 pragma Inline (Set); 154 -- Set the self id for the current task 155 156 end Specific; 157 158 package body Specific is 159 160 function Is_Valid_Task return Boolean is 161 begin 162 return TlsGetValue (TlsIndex) /= System.Null_Address; 163 end Is_Valid_Task; 164 165 procedure Set (Self_Id : Task_Id) is 166 Succeeded : BOOL; 167 begin 168 Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id)); 169 pragma Assert (Succeeded = Win32.TRUE); 170 end Set; 171 172 end Specific; 173 174 ---------------------------------- 175 -- ATCB allocation/deallocation -- 176 ---------------------------------- 177 178 package body ATCB_Allocation is separate; 179 -- The body of this package is shared across several targets 180 181 --------------------------------- 182 -- Support for foreign threads -- 183 --------------------------------- 184 185 function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; 186 -- Allocate and Initialize a new ATCB for the current Thread 187 188 function Register_Foreign_Thread 189 (Thread : Thread_Id) return Task_Id is separate; 190 191 ---------------------------------- 192 -- Condition Variable Functions -- 193 ---------------------------------- 194 195 procedure Initialize_Cond (Cond : not null access Condition_Variable); 196 -- Initialize given condition variable Cond 197 198 procedure Finalize_Cond (Cond : not null access Condition_Variable); 199 -- Finalize given condition variable Cond 200 201 procedure Cond_Signal (Cond : not null access Condition_Variable); 202 -- Signal condition variable Cond 203 204 procedure Cond_Wait 205 (Cond : not null access Condition_Variable; 206 L : not null access RTS_Lock); 207 -- Wait on conditional variable Cond, using lock L 208 209 procedure Cond_Timed_Wait 210 (Cond : not null access Condition_Variable; 211 L : not null access RTS_Lock; 212 Rel_Time : Duration; 213 Timed_Out : out Boolean; 214 Status : out Integer); 215 -- Do timed wait on condition variable Cond using lock L. The duration 216 -- of the timed wait is given by Rel_Time. When the condition is 217 -- signalled, Timed_Out shows whether or not a time out occurred. 218 -- Status is only valid if Timed_Out is False, in which case it 219 -- shows whether Cond_Timed_Wait completed successfully. 220 221 --------------------- 222 -- Initialize_Cond -- 223 --------------------- 224 225 procedure Initialize_Cond (Cond : not null access Condition_Variable) is 226 hEvent : HANDLE; 227 begin 228 hEvent := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr); 229 pragma Assert (hEvent /= 0); 230 Cond.all := Condition_Variable (hEvent); 231 end Initialize_Cond; 232 233 ------------------- 234 -- Finalize_Cond -- 235 ------------------- 236 237 -- No such problem here, DosCloseEventSem has been derived. 238 -- What does such refer to in above comment??? 239 240 procedure Finalize_Cond (Cond : not null access Condition_Variable) is 241 Result : BOOL; 242 begin 243 Result := CloseHandle (HANDLE (Cond.all)); 244 pragma Assert (Result = Win32.TRUE); 245 end Finalize_Cond; 246 247 ----------------- 248 -- Cond_Signal -- 249 ----------------- 250 251 procedure Cond_Signal (Cond : not null access Condition_Variable) is 252 Result : BOOL; 253 begin 254 Result := SetEvent (HANDLE (Cond.all)); 255 pragma Assert (Result = Win32.TRUE); 256 end Cond_Signal; 257 258 --------------- 259 -- Cond_Wait -- 260 --------------- 261 262 -- Pre-condition: Cond is posted 263 -- L is locked. 264 265 -- Post-condition: Cond is posted 266 -- L is locked. 267 268 procedure Cond_Wait 269 (Cond : not null access Condition_Variable; 270 L : not null access RTS_Lock) 271 is 272 Result : DWORD; 273 Result_Bool : BOOL; 274 275 begin 276 -- Must reset Cond BEFORE L is unlocked 277 278 Result_Bool := ResetEvent (HANDLE (Cond.all)); 279 pragma Assert (Result_Bool = Win32.TRUE); 280 Unlock (L, Global_Lock => True); 281 282 -- No problem if we are interrupted here: if the condition is signaled, 283 -- WaitForSingleObject will simply not block 284 285 Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite); 286 pragma Assert (Result = 0); 287 288 Write_Lock (L, Global_Lock => True); 289 end Cond_Wait; 290 291 --------------------- 292 -- Cond_Timed_Wait -- 293 --------------------- 294 295 -- Pre-condition: Cond is posted 296 -- L is locked. 297 298 -- Post-condition: Cond is posted 299 -- L is locked. 300 301 procedure Cond_Timed_Wait 302 (Cond : not null access Condition_Variable; 303 L : not null access RTS_Lock; 304 Rel_Time : Duration; 305 Timed_Out : out Boolean; 306 Status : out Integer) 307 is 308 Time_Out_Max : constant DWORD := 16#FFFF0000#; 309 -- NT 4 can't handle excessive timeout values (e.g. DWORD'Last - 1) 310 311 Time_Out : DWORD; 312 Result : BOOL; 313 Wait_Result : DWORD; 314 315 begin 316 -- Must reset Cond BEFORE L is unlocked 317 318 Result := ResetEvent (HANDLE (Cond.all)); 319 pragma Assert (Result = Win32.TRUE); 320 Unlock (L, Global_Lock => True); 321 322 -- No problem if we are interrupted here: if the condition is signaled, 323 -- WaitForSingleObject will simply not block. 324 325 if Rel_Time <= 0.0 then 326 Timed_Out := True; 327 Wait_Result := 0; 328 329 else 330 Time_Out := 331 (if Rel_Time >= Duration (Time_Out_Max) / 1000 332 then Time_Out_Max 333 else DWORD (Rel_Time * 1000)); 334 335 Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out); 336 337 if Wait_Result = WAIT_TIMEOUT then 338 Timed_Out := True; 339 Wait_Result := 0; 340 else 341 Timed_Out := False; 342 end if; 343 end if; 344 345 Write_Lock (L, Global_Lock => True); 346 347 -- Ensure post-condition 348 349 if Timed_Out then 350 Result := SetEvent (HANDLE (Cond.all)); 351 pragma Assert (Result = Win32.TRUE); 352 end if; 353 354 Status := Integer (Wait_Result); 355 end Cond_Timed_Wait; 356 357 ------------------ 358 -- Stack_Guard -- 359 ------------------ 360 361 -- The underlying thread system sets a guard page at the bottom of a thread 362 -- stack, so nothing is needed. 363 -- ??? Check the comment above 364 365 procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is 366 pragma Unreferenced (T, On); 367 begin 368 null; 369 end Stack_Guard; 370 371 -------------------- 372 -- Get_Thread_Id -- 373 -------------------- 374 375 function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is 376 begin 377 return T.Common.LL.Thread; 378 end Get_Thread_Id; 379 380 ---------- 381 -- Self -- 382 ---------- 383 384 function Self return Task_Id is 385 Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex)); 386 begin 387 if Self_Id = null then 388 return Register_Foreign_Thread (GetCurrentThread); 389 else 390 return Self_Id; 391 end if; 392 end Self; 393 394 --------------------- 395 -- Initialize_Lock -- 396 --------------------- 397 398 -- Note: mutexes and cond_variables needed per-task basis are initialized 399 -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such 400 -- as RTS_Lock, Memory_Lock...) used in the RTS is initialized before any 401 -- status change of RTS. Therefore raising Storage_Error in the following 402 -- routines should be able to be handled safely. 403 404 procedure Initialize_Lock 405 (Prio : System.Any_Priority; 406 L : not null access Lock) 407 is 408 begin 409 InitializeCriticalSection (L.Mutex'Access); 410 L.Owner_Priority := 0; 411 L.Priority := Prio; 412 end Initialize_Lock; 413 414 procedure Initialize_Lock 415 (L : not null access RTS_Lock; Level : Lock_Level) 416 is 417 pragma Unreferenced (Level); 418 begin 419 InitializeCriticalSection (L); 420 end Initialize_Lock; 421 422 ------------------- 423 -- Finalize_Lock -- 424 ------------------- 425 426 procedure Finalize_Lock (L : not null access Lock) is 427 begin 428 DeleteCriticalSection (L.Mutex'Access); 429 end Finalize_Lock; 430 431 procedure Finalize_Lock (L : not null access RTS_Lock) is 432 begin 433 DeleteCriticalSection (L); 434 end Finalize_Lock; 435 436 ---------------- 437 -- Write_Lock -- 438 ---------------- 439 440 procedure Write_Lock 441 (L : not null access Lock; Ceiling_Violation : out Boolean) is 442 begin 443 L.Owner_Priority := Get_Priority (Self); 444 445 if L.Priority < L.Owner_Priority then 446 Ceiling_Violation := True; 447 return; 448 end if; 449 450 EnterCriticalSection (L.Mutex'Access); 451 452 Ceiling_Violation := False; 453 end Write_Lock; 454 455 procedure Write_Lock 456 (L : not null access RTS_Lock; 457 Global_Lock : Boolean := False) 458 is 459 begin 460 if not Single_Lock or else Global_Lock then 461 EnterCriticalSection (L); 462 end if; 463 end Write_Lock; 464 465 procedure Write_Lock (T : Task_Id) is 466 begin 467 if not Single_Lock then 468 EnterCriticalSection (T.Common.LL.L'Access); 469 end if; 470 end Write_Lock; 471 472 --------------- 473 -- Read_Lock -- 474 --------------- 475 476 procedure Read_Lock 477 (L : not null access Lock; Ceiling_Violation : out Boolean) is 478 begin 479 Write_Lock (L, Ceiling_Violation); 480 end Read_Lock; 481 482 ------------ 483 -- Unlock -- 484 ------------ 485 486 procedure Unlock (L : not null access Lock) is 487 begin 488 LeaveCriticalSection (L.Mutex'Access); 489 end Unlock; 490 491 procedure Unlock 492 (L : not null access RTS_Lock; Global_Lock : Boolean := False) is 493 begin 494 if not Single_Lock or else Global_Lock then 495 LeaveCriticalSection (L); 496 end if; 497 end Unlock; 498 499 procedure Unlock (T : Task_Id) is 500 begin 501 if not Single_Lock then 502 LeaveCriticalSection (T.Common.LL.L'Access); 503 end if; 504 end Unlock; 505 506 ----------------- 507 -- Set_Ceiling -- 508 ----------------- 509 510 -- Dynamic priority ceilings are not supported by the underlying system 511 512 procedure Set_Ceiling 513 (L : not null access Lock; 514 Prio : System.Any_Priority) 515 is 516 pragma Unreferenced (L, Prio); 517 begin 518 null; 519 end Set_Ceiling; 520 521 ----------- 522 -- Sleep -- 523 ----------- 524 525 procedure Sleep 526 (Self_ID : Task_Id; 527 Reason : System.Tasking.Task_States) 528 is 529 pragma Unreferenced (Reason); 530 531 begin 532 pragma Assert (Self_ID = Self); 533 534 if Single_Lock then 535 Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); 536 else 537 Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); 538 end if; 539 540 if Self_ID.Deferral_Level = 0 541 and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 542 then 543 Unlock (Self_ID); 544 raise Standard'Abort_Signal; 545 end if; 546 end Sleep; 547 548 ----------------- 549 -- Timed_Sleep -- 550 ----------------- 551 552 -- This is for use within the run-time system, so abort is assumed to be 553 -- already deferred, and the caller should be holding its own ATCB lock. 554 555 procedure Timed_Sleep 556 (Self_ID : Task_Id; 557 Time : Duration; 558 Mode : ST.Delay_Modes; 559 Reason : System.Tasking.Task_States; 560 Timedout : out Boolean; 561 Yielded : out Boolean) 562 is 563 pragma Unreferenced (Reason); 564 Check_Time : Duration := Monotonic_Clock; 565 Rel_Time : Duration; 566 Abs_Time : Duration; 567 568 Result : Integer; 569 pragma Unreferenced (Result); 570 571 Local_Timedout : Boolean; 572 573 begin 574 Timedout := True; 575 Yielded := False; 576 577 if Mode = Relative then 578 Rel_Time := Time; 579 Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; 580 else 581 Rel_Time := Time - Check_Time; 582 Abs_Time := Time; 583 end if; 584 585 if Rel_Time > 0.0 then 586 loop 587 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 588 589 if Single_Lock then 590 Cond_Timed_Wait 591 (Self_ID.Common.LL.CV'Access, 592 Single_RTS_Lock'Access, 593 Rel_Time, Local_Timedout, Result); 594 else 595 Cond_Timed_Wait 596 (Self_ID.Common.LL.CV'Access, 597 Self_ID.Common.LL.L'Access, 598 Rel_Time, Local_Timedout, Result); 599 end if; 600 601 Check_Time := Monotonic_Clock; 602 exit when Abs_Time <= Check_Time; 603 604 if not Local_Timedout then 605 606 -- Somebody may have called Wakeup for us 607 608 Timedout := False; 609 exit; 610 end if; 611 612 Rel_Time := Abs_Time - Check_Time; 613 end loop; 614 end if; 615 end Timed_Sleep; 616 617 ----------------- 618 -- Timed_Delay -- 619 ----------------- 620 621 procedure Timed_Delay 622 (Self_ID : Task_Id; 623 Time : Duration; 624 Mode : ST.Delay_Modes) 625 is 626 Check_Time : Duration := Monotonic_Clock; 627 Rel_Time : Duration; 628 Abs_Time : Duration; 629 630 Timedout : Boolean; 631 Result : Integer; 632 pragma Unreferenced (Timedout, Result); 633 634 begin 635 if Single_Lock then 636 Lock_RTS; 637 end if; 638 639 Write_Lock (Self_ID); 640 641 if Mode = Relative then 642 Rel_Time := Time; 643 Abs_Time := Time + Check_Time; 644 else 645 Rel_Time := Time - Check_Time; 646 Abs_Time := Time; 647 end if; 648 649 if Rel_Time > 0.0 then 650 Self_ID.Common.State := Delay_Sleep; 651 652 loop 653 exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; 654 655 if Single_Lock then 656 Cond_Timed_Wait 657 (Self_ID.Common.LL.CV'Access, 658 Single_RTS_Lock'Access, 659 Rel_Time, Timedout, Result); 660 else 661 Cond_Timed_Wait 662 (Self_ID.Common.LL.CV'Access, 663 Self_ID.Common.LL.L'Access, 664 Rel_Time, Timedout, Result); 665 end if; 666 667 Check_Time := Monotonic_Clock; 668 exit when Abs_Time <= Check_Time; 669 670 Rel_Time := Abs_Time - Check_Time; 671 end loop; 672 673 Self_ID.Common.State := Runnable; 674 end if; 675 676 Unlock (Self_ID); 677 678 if Single_Lock then 679 Unlock_RTS; 680 end if; 681 682 Yield; 683 end Timed_Delay; 684 685 ------------ 686 -- Wakeup -- 687 ------------ 688 689 procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is 690 pragma Unreferenced (Reason); 691 begin 692 Cond_Signal (T.Common.LL.CV'Access); 693 end Wakeup; 694 695 ----------- 696 -- Yield -- 697 ----------- 698 699 procedure Yield (Do_Yield : Boolean := True) is 700 begin 701 -- Note: in a previous implementation if Do_Yield was False, then we 702 -- introduced a delay of 1 millisecond in an attempt to get closer to 703 -- annex D semantics, and in particular to make ACATS CXD8002 pass. But 704 -- this change introduced a huge performance regression evaluating the 705 -- Count attribute. So we decided to remove this processing. 706 707 -- Moreover, CXD8002 appears to pass on Windows (although we do not 708 -- guarantee full Annex D compliance on Windows in any case). 709 710 if Do_Yield then 711 SwitchToThread; 712 end if; 713 end Yield; 714 715 ------------------ 716 -- Set_Priority -- 717 ------------------ 718 719 procedure Set_Priority 720 (T : Task_Id; 721 Prio : System.Any_Priority; 722 Loss_Of_Inheritance : Boolean := False) 723 is 724 Res : BOOL; 725 pragma Unreferenced (Loss_Of_Inheritance); 726 727 begin 728 Res := 729 SetThreadPriority 730 (T.Common.LL.Thread, 731 Interfaces.C.int (Underlying_Priorities (Prio))); 732 pragma Assert (Res = Win32.TRUE); 733 734 -- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the 735 -- head of its priority queue when decreasing its priority as a result 736 -- of a loss of inherited priority. This is not the case, but we 737 -- consider it an acceptable variation (RM 1.1.3(6)), given this is 738 -- the built-in behavior offered by the Windows operating system. 739 740 -- In older versions we attempted to better approximate the Annex D 741 -- required behavior, but this simulation was not entirely accurate, 742 -- and it seems better to live with the standard Windows semantics. 743 744 T.Common.Current_Priority := Prio; 745 end Set_Priority; 746 747 ------------------ 748 -- Get_Priority -- 749 ------------------ 750 751 function Get_Priority (T : Task_Id) return System.Any_Priority is 752 begin 753 return T.Common.Current_Priority; 754 end Get_Priority; 755 756 ---------------- 757 -- Enter_Task -- 758 ---------------- 759 760 -- There were two paths were we needed to call Enter_Task : 761 -- 1) from System.Task_Primitives.Operations.Initialize 762 -- 2) from System.Tasking.Stages.Task_Wrapper 763 764 -- The thread initialisation has to be done only for the first case 765 766 -- This is because the GetCurrentThread NT call does not return the real 767 -- thread handler but only a "pseudo" one. It is not possible to release 768 -- the thread handle and free the system resources from this "pseudo" 769 -- handle. So we really want to keep the real thread handle set in 770 -- System.Task_Primitives.Operations.Create_Task during thread creation. 771 772 procedure Enter_Task (Self_ID : Task_Id) is 773 procedure Get_Stack_Bounds (Base : Address; Limit : Address); 774 pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds"); 775 -- Get stack boundaries 776 begin 777 Specific.Set (Self_ID); 778 779 -- Properly initializes the FPU for x86 systems 780 781 System.Float_Control.Reset; 782 783 if Self_ID.Common.Task_Info /= null 784 and then 785 Self_ID.Common.Task_Info.CPU >= CPU_Number (Number_Of_Processors) 786 then 787 raise Invalid_CPU_Number; 788 end if; 789 790 Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; 791 792 Get_Stack_Bounds 793 (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address, 794 Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address); 795 end Enter_Task; 796 797 ------------------- 798 -- Is_Valid_Task -- 799 ------------------- 800 801 function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; 802 803 ----------------------------- 804 -- Register_Foreign_Thread -- 805 ----------------------------- 806 807 function Register_Foreign_Thread return Task_Id is 808 begin 809 if Is_Valid_Task then 810 return Self; 811 else 812 return Register_Foreign_Thread (GetCurrentThread); 813 end if; 814 end Register_Foreign_Thread; 815 816 -------------------- 817 -- Initialize_TCB -- 818 -------------------- 819 820 procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is 821 begin 822 -- Initialize thread ID to 0, this is needed to detect threads that 823 -- are not yet activated. 824 825 Self_ID.Common.LL.Thread := Null_Thread_Id; 826 827 Initialize_Cond (Self_ID.Common.LL.CV'Access); 828 829 if not Single_Lock then 830 Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); 831 end if; 832 833 Succeeded := True; 834 end Initialize_TCB; 835 836 ----------------- 837 -- Create_Task -- 838 ----------------- 839 840 procedure Create_Task 841 (T : Task_Id; 842 Wrapper : System.Address; 843 Stack_Size : System.Parameters.Size_Type; 844 Priority : System.Any_Priority; 845 Succeeded : out Boolean) 846 is 847 Initial_Stack_Size : constant := 1024; 848 -- We set the initial stack size to 1024. On Windows version prior to XP 849 -- there is no way to fix a task stack size. Only the initial stack size 850 -- can be set, the operating system will raise the task stack size if 851 -- needed. 852 853 function Is_Windows_XP return Integer; 854 pragma Import (C, Is_Windows_XP, "__gnat_is_windows_xp"); 855 -- Returns 1 if running on Windows XP 856 857 hTask : HANDLE; 858 TaskId : aliased DWORD; 859 pTaskParameter : Win32.PVOID; 860 Result : DWORD; 861 Entry_Point : PTHREAD_START_ROUTINE; 862 863 use type System.Multiprocessors.CPU_Range; 864 865 begin 866 -- Check whether both Dispatching_Domain and CPU are specified for the 867 -- task, and the CPU value is not contained within the range of 868 -- processors for the domain. 869 870 if T.Common.Domain /= null 871 and then T.Common.Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU 872 and then 873 (T.Common.Base_CPU not in T.Common.Domain'Range 874 or else not T.Common.Domain (T.Common.Base_CPU)) 875 then 876 Succeeded := False; 877 return; 878 end if; 879 880 pTaskParameter := To_Address (T); 881 882 Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper); 883 884 if Is_Windows_XP = 1 then 885 hTask := CreateThread 886 (null, 887 DWORD (Stack_Size), 888 Entry_Point, 889 pTaskParameter, 890 DWORD (Create_Suspended) or 891 DWORD (Stack_Size_Param_Is_A_Reservation), 892 TaskId'Unchecked_Access); 893 else 894 hTask := CreateThread 895 (null, 896 Initial_Stack_Size, 897 Entry_Point, 898 pTaskParameter, 899 DWORD (Create_Suspended), 900 TaskId'Unchecked_Access); 901 end if; 902 903 -- Step 1: Create the thread in blocked mode 904 905 if hTask = 0 then 906 Succeeded := False; 907 return; 908 end if; 909 910 -- Step 2: set its TCB 911 912 T.Common.LL.Thread := hTask; 913 914 -- Note: it would be useful to initialize Thread_Id right away to avoid 915 -- a race condition in gdb where Thread_ID may not have the right value 916 -- yet, but GetThreadId is a Vista specific API, not available under XP: 917 -- T.Common.LL.Thread_Id := GetThreadId (hTask); so instead we set the 918 -- field to 0 to avoid having a random value. Thread_Id is initialized 919 -- in Enter_Task anyway. 920 921 T.Common.LL.Thread_Id := 0; 922 923 -- Step 3: set its priority (child has inherited priority from parent) 924 925 Set_Priority (T, Priority); 926 927 if Time_Slice_Val = 0 928 or else Dispatching_Policy = 'F' 929 or else Get_Policy (Priority) = 'F' 930 then 931 -- Here we need Annex D semantics so we disable the NT priority 932 -- boost. A priority boost is temporarily given by the system to 933 -- a thread when it is taken out of a wait state. 934 935 SetThreadPriorityBoost (hTask, DisablePriorityBoost => Win32.TRUE); 936 end if; 937 938 -- Step 4: Handle pragma CPU and Task_Info 939 940 Set_Task_Affinity (T); 941 942 -- Step 5: Now, start it for good 943 944 Result := ResumeThread (hTask); 945 pragma Assert (Result = 1); 946 947 Succeeded := Result = 1; 948 end Create_Task; 949 950 ------------------ 951 -- Finalize_TCB -- 952 ------------------ 953 954 procedure Finalize_TCB (T : Task_Id) is 955 Succeeded : BOOL; 956 957 begin 958 if not Single_Lock then 959 Finalize_Lock (T.Common.LL.L'Access); 960 end if; 961 962 Finalize_Cond (T.Common.LL.CV'Access); 963 964 if T.Known_Tasks_Index /= -1 then 965 Known_Tasks (T.Known_Tasks_Index) := null; 966 end if; 967 968 if T.Common.LL.Thread /= 0 then 969 970 -- This task has been activated. Close the thread handle. This 971 -- is needed to release system resources. 972 973 Succeeded := CloseHandle (T.Common.LL.Thread); 974 pragma Assert (Succeeded = Win32.TRUE); 975 end if; 976 977 ATCB_Allocation.Free_ATCB (T); 978 end Finalize_TCB; 979 980 --------------- 981 -- Exit_Task -- 982 --------------- 983 984 procedure Exit_Task is 985 begin 986 Specific.Set (null); 987 end Exit_Task; 988 989 ---------------- 990 -- Abort_Task -- 991 ---------------- 992 993 procedure Abort_Task (T : Task_Id) is 994 pragma Unreferenced (T); 995 begin 996 null; 997 end Abort_Task; 998 999 ---------------------- 1000 -- Environment_Task -- 1001 ---------------------- 1002 1003 function Environment_Task return Task_Id is 1004 begin 1005 return Environment_Task_Id; 1006 end Environment_Task; 1007 1008 -------------- 1009 -- Lock_RTS -- 1010 -------------- 1011 1012 procedure Lock_RTS is 1013 begin 1014 Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); 1015 end Lock_RTS; 1016 1017 ---------------- 1018 -- Unlock_RTS -- 1019 ---------------- 1020 1021 procedure Unlock_RTS is 1022 begin 1023 Unlock (Single_RTS_Lock'Access, Global_Lock => True); 1024 end Unlock_RTS; 1025 1026 ---------------- 1027 -- Initialize -- 1028 ---------------- 1029 1030 procedure Initialize (Environment_Task : Task_Id) is 1031 Discard : BOOL; 1032 1033 begin 1034 Environment_Task_Id := Environment_Task; 1035 OS_Primitives.Initialize; 1036 Interrupt_Management.Initialize; 1037 1038 if Time_Slice_Val = 0 or else Dispatching_Policy = 'F' then 1039 -- Here we need Annex D semantics, switch the current process to the 1040 -- Realtime_Priority_Class. 1041 1042 Discard := OS_Interface.SetPriorityClass 1043 (GetCurrentProcess, Realtime_Priority_Class); 1044 end if; 1045 1046 TlsIndex := TlsAlloc; 1047 1048 -- Initialize the lock used to synchronize chain of all ATCBs 1049 1050 Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); 1051 1052 Environment_Task.Common.LL.Thread := GetCurrentThread; 1053 1054 -- Make environment task known here because it doesn't go through 1055 -- Activate_Tasks, which does it for all other tasks. 1056 1057 Known_Tasks (Known_Tasks'First) := Environment_Task; 1058 Environment_Task.Known_Tasks_Index := Known_Tasks'First; 1059 1060 Enter_Task (Environment_Task); 1061 1062 -- pragma CPU and dispatching domains for the environment task 1063 1064 Set_Task_Affinity (Environment_Task); 1065 end Initialize; 1066 1067 --------------------- 1068 -- Monotonic_Clock -- 1069 --------------------- 1070 1071 function Monotonic_Clock return Duration is 1072 function Internal_Clock return Duration; 1073 pragma Import (Ada, Internal_Clock, "__gnat_monotonic_clock"); 1074 begin 1075 return Internal_Clock; 1076 end Monotonic_Clock; 1077 1078 ------------------- 1079 -- RT_Resolution -- 1080 ------------------- 1081 1082 function RT_Resolution return Duration is 1083 Ticks_Per_Second : aliased LARGE_INTEGER; 1084 begin 1085 QueryPerformanceFrequency (Ticks_Per_Second'Access); 1086 return Duration (1.0 / Ticks_Per_Second); 1087 end RT_Resolution; 1088 1089 ---------------- 1090 -- Initialize -- 1091 ---------------- 1092 1093 procedure Initialize (S : in out Suspension_Object) is 1094 begin 1095 -- Initialize internal state. It is always initialized to False (ARM 1096 -- D.10 par. 6). 1097 1098 S.State := False; 1099 S.Waiting := False; 1100 1101 -- Initialize internal mutex 1102 1103 InitializeCriticalSection (S.L'Access); 1104 1105 -- Initialize internal condition variable 1106 1107 S.CV := CreateEvent (null, Win32.TRUE, Win32.FALSE, Null_Ptr); 1108 pragma Assert (S.CV /= 0); 1109 end Initialize; 1110 1111 -------------- 1112 -- Finalize -- 1113 -------------- 1114 1115 procedure Finalize (S : in out Suspension_Object) is 1116 Result : BOOL; 1117 1118 begin 1119 -- Destroy internal mutex 1120 1121 DeleteCriticalSection (S.L'Access); 1122 1123 -- Destroy internal condition variable 1124 1125 Result := CloseHandle (S.CV); 1126 pragma Assert (Result = Win32.TRUE); 1127 end Finalize; 1128 1129 ------------------- 1130 -- Current_State -- 1131 ------------------- 1132 1133 function Current_State (S : Suspension_Object) return Boolean is 1134 begin 1135 -- We do not want to use lock on this read operation. State is marked 1136 -- as Atomic so that we ensure that the value retrieved is correct. 1137 1138 return S.State; 1139 end Current_State; 1140 1141 --------------- 1142 -- Set_False -- 1143 --------------- 1144 1145 procedure Set_False (S : in out Suspension_Object) is 1146 begin 1147 SSL.Abort_Defer.all; 1148 1149 EnterCriticalSection (S.L'Access); 1150 1151 S.State := False; 1152 1153 LeaveCriticalSection (S.L'Access); 1154 1155 SSL.Abort_Undefer.all; 1156 end Set_False; 1157 1158 -------------- 1159 -- Set_True -- 1160 -------------- 1161 1162 procedure Set_True (S : in out Suspension_Object) is 1163 Result : BOOL; 1164 1165 begin 1166 SSL.Abort_Defer.all; 1167 1168 EnterCriticalSection (S.L'Access); 1169 1170 -- If there is already a task waiting on this suspension object then 1171 -- we resume it, leaving the state of the suspension object to False, 1172 -- as it is specified in ARM D.10 par. 9. Otherwise, it just leaves 1173 -- the state to True. 1174 1175 if S.Waiting then 1176 S.Waiting := False; 1177 S.State := False; 1178 1179 Result := SetEvent (S.CV); 1180 pragma Assert (Result = Win32.TRUE); 1181 1182 else 1183 S.State := True; 1184 end if; 1185 1186 LeaveCriticalSection (S.L'Access); 1187 1188 SSL.Abort_Undefer.all; 1189 end Set_True; 1190 1191 ------------------------ 1192 -- Suspend_Until_True -- 1193 ------------------------ 1194 1195 procedure Suspend_Until_True (S : in out Suspension_Object) is 1196 Result : DWORD; 1197 Result_Bool : BOOL; 1198 1199 begin 1200 SSL.Abort_Defer.all; 1201 1202 EnterCriticalSection (S.L'Access); 1203 1204 if S.Waiting then 1205 1206 -- Program_Error must be raised upon calling Suspend_Until_True 1207 -- if another task is already waiting on that suspension object 1208 -- (ARM D.10 par. 10). 1209 1210 LeaveCriticalSection (S.L'Access); 1211 1212 SSL.Abort_Undefer.all; 1213 1214 raise Program_Error; 1215 1216 else 1217 -- Suspend the task if the state is False. Otherwise, the task 1218 -- continues its execution, and the state of the suspension object 1219 -- is set to False (ARM D.10 par. 9). 1220 1221 if S.State then 1222 S.State := False; 1223 1224 LeaveCriticalSection (S.L'Access); 1225 1226 SSL.Abort_Undefer.all; 1227 1228 else 1229 S.Waiting := True; 1230 1231 -- Must reset CV BEFORE L is unlocked 1232 1233 Result_Bool := ResetEvent (S.CV); 1234 pragma Assert (Result_Bool = Win32.TRUE); 1235 1236 LeaveCriticalSection (S.L'Access); 1237 1238 SSL.Abort_Undefer.all; 1239 1240 Result := WaitForSingleObject (S.CV, Wait_Infinite); 1241 pragma Assert (Result = 0); 1242 end if; 1243 end if; 1244 end Suspend_Until_True; 1245 1246 ---------------- 1247 -- Check_Exit -- 1248 ---------------- 1249 1250 -- Dummy versions, currently this only works for solaris (native) 1251 1252 function Check_Exit (Self_ID : ST.Task_Id) return Boolean is 1253 pragma Unreferenced (Self_ID); 1254 begin 1255 return True; 1256 end Check_Exit; 1257 1258 -------------------- 1259 -- Check_No_Locks -- 1260 -------------------- 1261 1262 function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is 1263 pragma Unreferenced (Self_ID); 1264 begin 1265 return True; 1266 end Check_No_Locks; 1267 1268 ------------------ 1269 -- Suspend_Task -- 1270 ------------------ 1271 1272 function Suspend_Task 1273 (T : ST.Task_Id; 1274 Thread_Self : Thread_Id) return Boolean 1275 is 1276 begin 1277 if T.Common.LL.Thread /= Thread_Self then 1278 return SuspendThread (T.Common.LL.Thread) = NO_ERROR; 1279 else 1280 return True; 1281 end if; 1282 end Suspend_Task; 1283 1284 ----------------- 1285 -- Resume_Task -- 1286 ----------------- 1287 1288 function Resume_Task 1289 (T : ST.Task_Id; 1290 Thread_Self : Thread_Id) return Boolean 1291 is 1292 begin 1293 if T.Common.LL.Thread /= Thread_Self then 1294 return ResumeThread (T.Common.LL.Thread) = NO_ERROR; 1295 else 1296 return True; 1297 end if; 1298 end Resume_Task; 1299 1300 -------------------- 1301 -- Stop_All_Tasks -- 1302 -------------------- 1303 1304 procedure Stop_All_Tasks is 1305 begin 1306 null; 1307 end Stop_All_Tasks; 1308 1309 --------------- 1310 -- Stop_Task -- 1311 --------------- 1312 1313 function Stop_Task (T : ST.Task_Id) return Boolean is 1314 pragma Unreferenced (T); 1315 begin 1316 return False; 1317 end Stop_Task; 1318 1319 ------------------- 1320 -- Continue_Task -- 1321 ------------------- 1322 1323 function Continue_Task (T : ST.Task_Id) return Boolean is 1324 pragma Unreferenced (T); 1325 begin 1326 return False; 1327 end Continue_Task; 1328 1329 ----------------------- 1330 -- Set_Task_Affinity -- 1331 ----------------------- 1332 1333 procedure Set_Task_Affinity (T : ST.Task_Id) is 1334 Result : DWORD; 1335 1336 use type System.Multiprocessors.CPU_Range; 1337 1338 begin 1339 -- Do nothing if the underlying thread has not yet been created. If the 1340 -- thread has not yet been created then the proper affinity will be set 1341 -- during its creation. 1342 1343 if T.Common.LL.Thread = Null_Thread_Id then 1344 null; 1345 1346 -- pragma CPU 1347 1348 elsif T.Common.Base_CPU /= Multiprocessors.Not_A_Specific_CPU then 1349 1350 -- The CPU numbering in pragma CPU starts at 1 while the subprogram 1351 -- to set the affinity starts at 0, therefore we must substract 1. 1352 1353 Result := 1354 SetThreadIdealProcessor 1355 (T.Common.LL.Thread, ProcessorId (T.Common.Base_CPU) - 1); 1356 pragma Assert (Result = 1); 1357 1358 -- Task_Info 1359 1360 elsif T.Common.Task_Info /= null then 1361 if T.Common.Task_Info.CPU /= Task_Info.Any_CPU then 1362 Result := 1363 SetThreadIdealProcessor 1364 (T.Common.LL.Thread, T.Common.Task_Info.CPU); 1365 pragma Assert (Result = 1); 1366 end if; 1367 1368 -- Dispatching domains 1369 1370 elsif T.Common.Domain /= null 1371 and then (T.Common.Domain /= ST.System_Domain 1372 or else 1373 T.Common.Domain.all /= 1374 (Multiprocessors.CPU'First .. 1375 Multiprocessors.Number_Of_CPUs => True)) 1376 then 1377 declare 1378 CPU_Set : DWORD := 0; 1379 1380 begin 1381 for Proc in T.Common.Domain'Range loop 1382 if T.Common.Domain (Proc) then 1383 1384 -- The thread affinity mask is a bit vector in which each 1385 -- bit represents a logical processor. 1386 1387 CPU_Set := CPU_Set + 2 ** (Integer (Proc) - 1); 1388 end if; 1389 end loop; 1390 1391 Result := SetThreadAffinityMask (T.Common.LL.Thread, CPU_Set); 1392 pragma Assert (Result = 1); 1393 end; 1394 end if; 1395 end Set_Task_Affinity; 1396 1397end System.Task_Primitives.Operations; 1398