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