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