gcc/ada/s-taprop-mingw.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA 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-2004, 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 2,  or (at your option) any later ver- --
  14 -- sion. GNARL 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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is a NT (native) version of this package
  35
  36 --  This package contains all the GNULL primitives that interface directly
  37 --  with the underlying OS.
  38
  39 pragma Polling (Off);
  40 --  Turn off polling, we do not want ATC polling to take place during
  41 --  tasking operations. It causes infinite loops and other problems.
  42
  43 with System.Tasking.Debug;
  44 --  used for Known_Tasks
  45
  46 with Interfaces.C;
  47 --  used for int
  48 --           size_t
  49
  50 with Interfaces.C.Strings;
  51 --  used for Null_Ptr
  52
  53 with System.OS_Interface;
  54 --  used for various type, constant, and operations
  55
  56 with System.Parameters;
  57 --  used for Size_Type
  58
  59 with System.Tasking;
  60 --  used for Ada_Task_Control_Block
  61 --           Task_Id
  62
  63 with System.Soft_Links;
  64 --  used for Defer/Undefer_Abort
  65 --       to initialize TSD for a C thread, in function Self
  66
  67 --  Note that we do not use System.Tasking.Initialization directly since
  68 --  this is a higher level package that we shouldn't depend on. For example
  69 --  when using the restricted run time, it is replaced by
  70 --  System.Tasking.Restricted.Initialization
  71
  72 with System.OS_Primitives;
  73 --  used for Delay_Modes
  74
  75 with System.Task_Info;
  76 --  used for Unspecified_Task_Info
  77
  78 with Unchecked_Deallocation;
  79
  80 package body System.Task_Primitives.Operations is
  81
  82    use System.Tasking.Debug;
  83    use System.Tasking;
  84    use Interfaces.C;
  85    use Interfaces.C.Strings;
  86    use System.OS_Interface;
  87    use System.Parameters;
  88    use System.OS_Primitives;
  89
  90    pragma Link_With ("-Xlinker --stack=0x800000,0x1000");
  91    --  Change the stack size (8 MB) for tasking programs on Windows. This
  92    --  permit to have more than 30 tasks running at the same time. Note that
  93    --  we set the stack size for non tasking programs on System unit.
  94
  95    package SSL renames System.Soft_Links;
  96
  97    ----------------
  98    -- Local Data --
  99    ----------------
 100
 101    Environment_Task_Id : Task_Id;
 102    --  A variable to hold Task_Id for the environment task.
 103
 104    Single_RTS_Lock : aliased RTS_Lock;
 105    --  This is a lock to allow only one thread of control in the RTS at
 106    --  a time; it is used to execute in mutual exclusion from all other tasks.
 107    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
 108
 109    Time_Slice_Val : Integer;
 110    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 111
 112    Dispatching_Policy : Character;
 113    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 114
 115    FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
 116    --  Indicates whether FIFO_Within_Priorities is set.
 117
 118    Foreign_Task_Elaborated : aliased Boolean := True;
 119    --  Used to identified fake tasks (i.e., non-Ada Threads).
 120
 121    ------------------------------------
 122    -- The thread local storage index --
 123    ------------------------------------
 124
 125    TlsIndex : DWORD;
 126    pragma Export (Ada, TlsIndex);
 127    --  To ensure that this variable won't be local to this package, since
 128    --  in some cases, inlining forces this variable to be global anyway.
 129
 130    --------------------
 131    -- Local Packages --
 132    --------------------
 133
 134    package Specific is
 135
 136       function Is_Valid_Task return Boolean;
 137       pragma Inline (Is_Valid_Task);
 138       --  Does executing thread have a TCB?
 139
 140       procedure Set (Self_Id : Task_Id);
 141       pragma Inline (Set);
 142       --  Set the self id for the current task.
 143
 144    end Specific;
 145
 146    package body Specific is
 147
 148       function Is_Valid_Task return Boolean is
 149       begin
 150          return TlsGetValue (TlsIndex) /= System.Null_Address;
 151       end Is_Valid_Task;
 152
 153       procedure Set (Self_Id : Task_Id) is
 154          Succeeded : BOOL;
 155       begin
 156          Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
 157          pragma Assert (Succeeded = True);
 158       end Set;
 159
 160    end Specific;
 161
 162    ---------------------------------
 163    -- Support for foreign threads --
 164    ---------------------------------
 165
 166    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
 167    --  Allocate and Initialize a new ATCB for the current Thread.
 168
 169    function Register_Foreign_Thread
 170      (Thread : Thread_Id) return Task_Id is separate;
 171
 172    ----------------------------------
 173    -- Condition Variable Functions --
 174    ----------------------------------
 175
 176    procedure Initialize_Cond (Cond : access Condition_Variable);
 177    --  Initialize given condition variable Cond
 178
 179    procedure Finalize_Cond (Cond : access Condition_Variable);
 180    --  Finalize given condition variable Cond.
 181
 182    procedure Cond_Signal (Cond : access Condition_Variable);
 183    --  Signal condition variable Cond
 184
 185    procedure Cond_Wait
 186      (Cond : access Condition_Variable;
 187       L    : access RTS_Lock);
 188    --  Wait on conditional variable Cond, using lock L
 189
 190    procedure Cond_Timed_Wait
 191      (Cond      : access Condition_Variable;
 192       L         : access RTS_Lock;
 193       Rel_Time  : Duration;
 194       Timed_Out : out Boolean;
 195       Status    : out Integer);
 196    --  Do timed wait on condition variable Cond using lock L. The duration
 197    --  of the timed wait is given by Rel_Time. When the condition is
 198    --  signalled, Timed_Out shows whether or not a time out occurred.
 199    --  Status is only valid if Timed_Out is False, in which case it
 200    --  shows whether Cond_Timed_Wait completed successfully.
 201
 202    ---------------------
 203    -- Initialize_Cond --
 204    ---------------------
 205
 206    procedure Initialize_Cond (Cond : access Condition_Variable) is
 207       hEvent : HANDLE;
 208
 209    begin
 210       hEvent := CreateEvent (null, True, False, Null_Ptr);
 211       pragma Assert (hEvent /= 0);
 212       Cond.all := Condition_Variable (hEvent);
 213    end Initialize_Cond;
 214
 215    -------------------
 216    -- Finalize_Cond --
 217    -------------------
 218
 219    --  No such problem here, DosCloseEventSem has been derived.
 220    --  What does such refer to in above comment???
 221
 222    procedure Finalize_Cond (Cond : access Condition_Variable) is
 223       Result : BOOL;
 224    begin
 225       Result := CloseHandle (HANDLE (Cond.all));
 226       pragma Assert (Result = True);
 227    end Finalize_Cond;
 228
 229    -----------------
 230    -- Cond_Signal --
 231    -----------------
 232
 233    procedure Cond_Signal (Cond : access Condition_Variable) is
 234       Result : BOOL;
 235    begin
 236       Result := SetEvent (HANDLE (Cond.all));
 237       pragma Assert (Result = True);
 238    end Cond_Signal;
 239
 240    ---------------
 241    -- Cond_Wait --
 242    ---------------
 243
 244    --  Pre-assertion: Cond is posted
 245    --                 L is locked.
 246
 247    --  Post-assertion: Cond is posted
 248    --                  L is locked.
 249
 250    procedure Cond_Wait
 251      (Cond : access Condition_Variable;
 252       L    : access RTS_Lock)
 253    is
 254       Result      : DWORD;
 255       Result_Bool : BOOL;
 256
 257    begin
 258       --  Must reset Cond BEFORE L is unlocked.
 259
 260       Result_Bool := ResetEvent (HANDLE (Cond.all));
 261       pragma Assert (Result_Bool = True);
 262       Unlock (L);
 263
 264       --  No problem if we are interrupted here: if the condition is signaled,
 265       --  WaitForSingleObject will simply not block
 266
 267       Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite);
 268       pragma Assert (Result = 0);
 269
 270       Write_Lock (L);
 271    end Cond_Wait;
 272
 273    ---------------------
 274    -- Cond_Timed_Wait --
 275    ---------------------
 276
 277    --  Pre-assertion: Cond is posted
 278    --                 L is locked.
 279
 280    --  Post-assertion: Cond is posted
 281    --                  L is locked.
 282
 283    procedure Cond_Timed_Wait
 284      (Cond      : access Condition_Variable;
 285       L         : access RTS_Lock;
 286       Rel_Time  : Duration;
 287       Timed_Out : out Boolean;
 288       Status    : out Integer)
 289    is
 290       Time_Out_Max : constant DWORD := 16#FFFF0000#;
 291       --  NT 4 cannot handle timeout values that are too large,
 292       --  e.g. DWORD'Last - 1
 293
 294       Time_Out     : DWORD;
 295       Result       : BOOL;
 296       Wait_Result  : DWORD;
 297
 298    begin
 299       --  Must reset Cond BEFORE L is unlocked.
 300
 301       Result := ResetEvent (HANDLE (Cond.all));
 302       pragma Assert (Result = True);
 303       Unlock (L);
 304
 305       --  No problem if we are interrupted here: if the condition is signaled,
 306       --  WaitForSingleObject will simply not block
 307
 308       if Rel_Time <= 0.0 then
 309          Timed_Out := True;
 310          Wait_Result := 0;
 311
 312       else
 313          if Rel_Time >= Duration (Time_Out_Max) / 1000 then
 314             Time_Out := Time_Out_Max;
 315          else
 316             Time_Out := DWORD (Rel_Time * 1000);
 317          end if;
 318
 319          Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
 320
 321          if Wait_Result = WAIT_TIMEOUT then
 322             Timed_Out := True;
 323             Wait_Result := 0;
 324          else
 325             Timed_Out := False;
 326          end if;
 327       end if;
 328
 329       Write_Lock (L);
 330
 331       --  Ensure post-condition
 332
 333       if Timed_Out then
 334          Result := SetEvent (HANDLE (Cond.all));
 335          pragma Assert (Result = True);
 336       end if;
 337
 338       Status := Integer (Wait_Result);
 339    end Cond_Timed_Wait;
 340
 341    ------------------
 342    -- Stack_Guard  --
 343    ------------------
 344
 345    --  The underlying thread system sets a guard page at the
 346    --  bottom of a thread stack, so nothing is needed.
 347    --  ??? Check the comment above
 348
 349    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 350       pragma Warnings (Off, T);
 351       pragma Warnings (Off, On);
 352
 353    begin
 354       null;
 355    end Stack_Guard;
 356
 357    --------------------
 358    -- Get_Thread_Id  --
 359    --------------------
 360
 361    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 362    begin
 363       return T.Common.LL.Thread;
 364    end Get_Thread_Id;
 365
 366    ----------
 367    -- Self --
 368    ----------
 369
 370    function Self return Task_Id is
 371       Self_Id : constant Task_Id := To_Task_Id (TlsGetValue (TlsIndex));
 372    begin
 373       if Self_Id = null then
 374          return Register_Foreign_Thread (GetCurrentThread);
 375       else
 376          return Self_Id;
 377       end if;
 378    end Self;
 379
 380    ---------------------
 381    -- Initialize_Lock --
 382    ---------------------
 383
 384    --  Note: mutexes and cond_variables needed per-task basis are
 385    --  initialized in Intialize_TCB and the Storage_Error is handled.
 386    --  Other mutexes (such as RTS_Lock, Memory_Lock...) used in
 387    --  the RTS is initialized before any status change of RTS.
 388    --  Therefore raising Storage_Error in the following routines
 389    --  should be able to be handled safely.
 390
 391    procedure Initialize_Lock
 392      (Prio : System.Any_Priority;
 393       L    : access Lock)
 394    is
 395    begin
 396       InitializeCriticalSection (L.Mutex'Access);
 397       L.Owner_Priority := 0;
 398       L.Priority := Prio;
 399    end Initialize_Lock;
 400
 401    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 402       pragma Unreferenced (Level);
 403
 404    begin
 405       InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
 406    end Initialize_Lock;
 407
 408    -------------------
 409    -- Finalize_Lock --
 410    -------------------
 411
 412    procedure Finalize_Lock (L : access Lock) is
 413    begin
 414       DeleteCriticalSection (L.Mutex'Access);
 415    end Finalize_Lock;
 416
 417    procedure Finalize_Lock (L : access RTS_Lock) is
 418    begin
 419       DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
 420    end Finalize_Lock;
 421
 422    ----------------
 423    -- Write_Lock --
 424    ----------------
 425
 426    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 427    begin
 428       L.Owner_Priority := Get_Priority (Self);
 429
 430       if L.Priority < L.Owner_Priority then
 431          Ceiling_Violation := True;
 432          return;
 433       end if;
 434
 435       EnterCriticalSection (L.Mutex'Access);
 436
 437       Ceiling_Violation := False;
 438    end Write_Lock;
 439
 440    procedure Write_Lock
 441      (L           : access RTS_Lock;
 442       Global_Lock : Boolean := False)
 443    is
 444    begin
 445       if not Single_Lock or else Global_Lock then
 446          EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
 447       end if;
 448    end Write_Lock;
 449
 450    procedure Write_Lock (T : Task_Id) is
 451    begin
 452       if not Single_Lock then
 453          EnterCriticalSection
 454            (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
 455       end if;
 456    end Write_Lock;
 457
 458    ---------------
 459    -- Read_Lock --
 460    ---------------
 461
 462    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 463    begin
 464       Write_Lock (L, Ceiling_Violation);
 465    end Read_Lock;
 466
 467    ------------
 468    -- Unlock --
 469    ------------
 470
 471    procedure Unlock (L : access Lock) is
 472    begin
 473       LeaveCriticalSection (L.Mutex'Access);
 474    end Unlock;
 475
 476    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 477    begin
 478       if not Single_Lock or else Global_Lock then
 479          LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
 480       end if;
 481    end Unlock;
 482
 483    procedure Unlock (T : Task_Id) is
 484    begin
 485       if not Single_Lock then
 486          LeaveCriticalSection
 487            (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
 488       end if;
 489    end Unlock;
 490
 491    -----------
 492    -- Sleep --
 493    -----------
 494
 495    procedure Sleep
 496      (Self_ID : Task_Id;
 497       Reason  : System.Tasking.Task_States)
 498    is
 499       pragma Unreferenced (Reason);
 500
 501    begin
 502       pragma Assert (Self_ID = Self);
 503
 504       if Single_Lock then
 505          Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 506       else
 507          Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 508       end if;
 509
 510       if Self_ID.Deferral_Level = 0
 511         and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 512       then
 513          Unlock (Self_ID);
 514          raise Standard'Abort_Signal;
 515       end if;
 516    end Sleep;
 517
 518    -----------------
 519    -- Timed_Sleep --
 520    -----------------
 521
 522    --  This is for use within the run-time system, so abort is
 523    --  assumed to be already deferred, and the caller should be
 524    --  holding its own ATCB lock.
 525
 526    procedure Timed_Sleep
 527      (Self_ID  : Task_Id;
 528       Time     : Duration;
 529       Mode     : ST.Delay_Modes;
 530       Reason   : System.Tasking.Task_States;
 531       Timedout : out Boolean;
 532       Yielded  : out Boolean)
 533    is
 534       pragma Unreferenced (Reason);
 535       Check_Time : Duration := Monotonic_Clock;
 536       Rel_Time   : Duration;
 537       Abs_Time   : Duration;
 538       Result     : Integer;
 539
 540       Local_Timedout : Boolean;
 541
 542    begin
 543       Timedout := True;
 544       Yielded  := False;
 545
 546       if Mode = Relative then
 547          Rel_Time := Time;
 548          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 549       else
 550          Rel_Time := Time - Check_Time;
 551          Abs_Time := Time;
 552       end if;
 553
 554       if Rel_Time > 0.0 then
 555          loop
 556             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 557               or else Self_ID.Pending_Priority_Change;
 558
 559             if Single_Lock then
 560                Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
 561                  Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result);
 562             else
 563                Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
 564                  Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
 565             end if;
 566
 567             Check_Time := Monotonic_Clock;
 568             exit when Abs_Time <= Check_Time;
 569
 570             if not Local_Timedout then
 571
 572                --  Somebody may have called Wakeup for us
 573
 574                Timedout := False;
 575                exit;
 576             end if;
 577
 578             Rel_Time := Abs_Time - Check_Time;
 579          end loop;
 580       end if;
 581    end Timed_Sleep;
 582
 583    -----------------
 584    -- Timed_Delay --
 585    -----------------
 586
 587    procedure Timed_Delay
 588      (Self_ID  : Task_Id;
 589       Time     : Duration;
 590       Mode     : ST.Delay_Modes)
 591    is
 592       Check_Time : Duration := Monotonic_Clock;
 593       Rel_Time   : Duration;
 594       Abs_Time   : Duration;
 595       Result     : Integer;
 596       Timedout   : Boolean;
 597
 598    begin
 599       --  Only the little window between deferring abort and
 600       --  locking Self_ID is the reason we need to
 601       --  check for pending abort and priority change below!
 602
 603       SSL.Abort_Defer.all;
 604
 605       if Single_Lock then
 606          Lock_RTS;
 607       end if;
 608
 609       Write_Lock (Self_ID);
 610
 611       if Mode = Relative then
 612          Rel_Time := Time;
 613          Abs_Time := Time + Check_Time;
 614       else
 615          Rel_Time := Time - Check_Time;
 616          Abs_Time := Time;
 617       end if;
 618
 619       if Rel_Time > 0.0 then
 620          Self_ID.Common.State := Delay_Sleep;
 621
 622          loop
 623             if Self_ID.Pending_Priority_Change then
 624                Self_ID.Pending_Priority_Change := False;
 625                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 626                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 627             end if;
 628
 629             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 630
 631             if Single_Lock then
 632                Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
 633                  Single_RTS_Lock'Access, Rel_Time, Timedout, Result);
 634             else
 635                Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
 636                  Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
 637             end if;
 638
 639             Check_Time := Monotonic_Clock;
 640             exit when Abs_Time <= Check_Time;
 641
 642             Rel_Time := Abs_Time - Check_Time;
 643          end loop;
 644
 645          Self_ID.Common.State := Runnable;
 646       end if;
 647
 648       Unlock (Self_ID);
 649
 650       if Single_Lock then
 651          Unlock_RTS;
 652       end if;
 653
 654       Yield;
 655       SSL.Abort_Undefer.all;
 656    end Timed_Delay;
 657
 658    ------------
 659    -- Wakeup --
 660    ------------
 661
 662    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 663       pragma Unreferenced (Reason);
 664
 665    begin
 666       Cond_Signal (T.Common.LL.CV'Access);
 667    end Wakeup;
 668
 669    -----------
 670    -- Yield --
 671    -----------
 672
 673    procedure Yield (Do_Yield : Boolean := True) is
 674    begin
 675       if Do_Yield then
 676          Sleep (0);
 677       end if;
 678    end Yield;
 679
 680    ------------------
 681    -- Set_Priority --
 682    ------------------
 683
 684    type Prio_Array_Type is array (System.Any_Priority) of Integer;
 685    pragma Atomic_Components (Prio_Array_Type);
 686
 687    Prio_Array : Prio_Array_Type;
 688    --  Global array containing the id of the currently running task for
 689    --  each priority.
 690    --
 691    --  Note: we assume that we are on a single processor with run-til-blocked
 692    --  scheduling.
 693
 694    procedure Set_Priority
 695      (T                   : Task_Id;
 696       Prio                : System.Any_Priority;
 697       Loss_Of_Inheritance : Boolean := False)
 698    is
 699       Res        : BOOL;
 700       Array_Item : Integer;
 701
 702    begin
 703       Res := SetThreadPriority
 704         (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
 705       pragma Assert (Res = True);
 706
 707       if FIFO_Within_Priorities then
 708
 709          --  Annex D requirement [RM D.2.2 par. 9]:
 710          --    If the task drops its priority due to the loss of inherited
 711          --    priority, it is added at the head of the ready queue for its
 712          --    new active priority.
 713
 714          if Loss_Of_Inheritance
 715            and then Prio < T.Common.Current_Priority
 716          then
 717             Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
 718             Prio_Array (T.Common.Base_Priority) := Array_Item;
 719
 720             loop
 721                --  Let some processes a chance to arrive
 722
 723                Yield;
 724
 725                --  Then wait for our turn to proceed
 726
 727                exit when Array_Item = Prio_Array (T.Common.Base_Priority)
 728                  or else Prio_Array (T.Common.Base_Priority) = 1;
 729             end loop;
 730
 731             Prio_Array (T.Common.Base_Priority) :=
 732               Prio_Array (T.Common.Base_Priority) - 1;
 733          end if;
 734       end if;
 735
 736       T.Common.Current_Priority := Prio;
 737    end Set_Priority;
 738
 739    ------------------
 740    -- Get_Priority --
 741    ------------------
 742
 743    function Get_Priority (T : Task_Id) return System.Any_Priority is
 744    begin
 745       return T.Common.Current_Priority;
 746    end Get_Priority;
 747
 748    ----------------
 749    -- Enter_Task --
 750    ----------------
 751
 752    --  There were two paths were we needed to call Enter_Task :
 753    --  1) from System.Task_Primitives.Operations.Initialize
 754    --  2) from System.Tasking.Stages.Task_Wrapper
 755    --
 756    --  The thread initialisation has to be done only for the first case.
 757    --
 758    --  This is because the GetCurrentThread NT call does not return the
 759    --  real thread handler but only a "pseudo" one. It is not possible to
 760    --  release the thread handle and free the system ressources from this
 761    --  "pseudo" handle. So we really want to keep the real thread handle
 762    --  set in System.Task_Primitives.Operations.Create_Task during the
 763    --  thread creation.
 764
 765    procedure Enter_Task (Self_ID : Task_Id) is
 766       procedure Init_Float;
 767       pragma Import (C, Init_Float, "__gnat_init_float");
 768       --  Properly initializes the FPU for x86 systems.
 769
 770    begin
 771       Specific.Set (Self_ID);
 772       Init_Float;
 773
 774       Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
 775
 776       Lock_RTS;
 777
 778       for J in Known_Tasks'Range loop
 779          if Known_Tasks (J) = null then
 780             Known_Tasks (J) := Self_ID;
 781             Self_ID.Known_Tasks_Index := J;
 782             exit;
 783          end if;
 784       end loop;
 785
 786       Unlock_RTS;
 787    end Enter_Task;
 788
 789    --------------
 790    -- New_ATCB --
 791    --------------
 792
 793    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 794    begin
 795       return new Ada_Task_Control_Block (Entry_Num);
 796    end New_ATCB;
 797
 798    -------------------
 799    -- Is_Valid_Task --
 800    -------------------
 801
 802    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 803
 804    -----------------------------
 805    -- Register_Foreign_Thread --
 806    -----------------------------
 807
 808    function Register_Foreign_Thread return Task_Id is
 809    begin
 810       if Is_Valid_Task then
 811          return Self;
 812       else
 813          return Register_Foreign_Thread (GetCurrentThread);
 814       end if;
 815    end Register_Foreign_Thread;
 816
 817    --------------------
 818    -- Initialize_TCB --
 819    --------------------
 820
 821    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 822    begin
 823       --  Initialize thread ID to 0, this is needed to detect threads that
 824       --  are not yet activated.
 825
 826       Self_ID.Common.LL.Thread := 0;
 827
 828       Initialize_Cond (Self_ID.Common.LL.CV'Access);
 829
 830       if not Single_Lock then
 831          Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
 832       end if;
 833
 834       Succeeded := True;
 835    end Initialize_TCB;
 836
 837    -----------------
 838    -- Create_Task --
 839    -----------------
 840
 841    procedure Create_Task
 842      (T          : Task_Id;
 843       Wrapper    : System.Address;
 844       Stack_Size : System.Parameters.Size_Type;
 845       Priority   : System.Any_Priority;
 846       Succeeded  : out Boolean)
 847    is
 848       hTask          : HANDLE;
 849       TaskId         : aliased DWORD;
 850       pTaskParameter : System.OS_Interface.PVOID;
 851       dwStackSize    : DWORD;
 852       Result         : DWORD;
 853       Entry_Point    : PTHREAD_START_ROUTINE;
 854
 855    begin
 856       pTaskParameter := To_Address (T);
 857
 858       if Stack_Size = Unspecified_Size then
 859          dwStackSize := DWORD (Default_Stack_Size);
 860
 861       elsif Stack_Size < Minimum_Stack_Size then
 862          dwStackSize := DWORD (Minimum_Stack_Size);
 863
 864       else
 865          dwStackSize := DWORD (Stack_Size);
 866       end if;
 867
 868       Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
 869
 870       hTask := CreateThread
 871          (null,
 872           dwStackSize,
 873           Entry_Point,
 874           pTaskParameter,
 875           DWORD (Create_Suspended),
 876           TaskId'Unchecked_Access);
 877
 878       --  Step 1: Create the thread in blocked mode
 879
 880       if hTask = 0 then
 881          raise Storage_Error;
 882       end if;
 883
 884       --  Step 2: set its TCB
 885
 886       T.Common.LL.Thread := hTask;
 887
 888       --  Step 3: set its priority (child has inherited priority from parent)
 889
 890       Set_Priority (T, Priority);
 891
 892       if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
 893          --  Here we need Annex E semantics so we disable the NT priority
 894          --  boost. A priority boost is temporarily given by the system to a
 895          --  thread when it is taken out of a wait state.
 896
 897          SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
 898       end if;
 899
 900       --  Step 4: Now, start it for good:
 901
 902       Result := ResumeThread (hTask);
 903       pragma Assert (Result = 1);
 904
 905       Succeeded := Result = 1;
 906    end Create_Task;
 907
 908    ------------------
 909    -- Finalize_TCB --
 910    ------------------
 911
 912    procedure Finalize_TCB (T : Task_Id) is
 913       Self_ID   : Task_Id := T;
 914       Result    : DWORD;
 915       Succeeded : BOOL;
 916       Is_Self   : constant Boolean := T = Self;
 917
 918       procedure Free is new
 919         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 920
 921    begin
 922       if not Single_Lock then
 923          Finalize_Lock (T.Common.LL.L'Access);
 924       end if;
 925
 926       Finalize_Cond (T.Common.LL.CV'Access);
 927
 928       if T.Known_Tasks_Index /= -1 then
 929          Known_Tasks (T.Known_Tasks_Index) := null;
 930       end if;
 931
 932       if Self_ID.Common.LL.Thread /= 0 then
 933
 934          --  This task has been activated. Wait for the thread to terminate
 935          --  then close it. this is needed to release system ressources.
 936
 937          Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
 938          pragma Assert (Result /= WAIT_FAILED);
 939          Succeeded := CloseHandle (T.Common.LL.Thread);
 940          pragma Assert (Succeeded = True);
 941       end if;
 942
 943       Free (Self_ID);
 944
 945       if Is_Self then
 946          Specific.Set (null);
 947       end if;
 948    end Finalize_TCB;
 949
 950    ---------------
 951    -- Exit_Task --
 952    ---------------
 953
 954    procedure Exit_Task is
 955    begin
 956       Specific.Set (null);
 957    end Exit_Task;
 958
 959    ----------------
 960    -- Abort_Task --
 961    ----------------
 962
 963    procedure Abort_Task (T : Task_Id) is
 964    pragma Unreferenced (T);
 965    begin
 966       null;
 967    end Abort_Task;
 968
 969    ----------------------
 970    -- Environment_Task --
 971    ----------------------
 972
 973    function Environment_Task return Task_Id is
 974    begin
 975       return Environment_Task_Id;
 976    end Environment_Task;
 977
 978    --------------
 979    -- Lock_RTS --
 980    --------------
 981
 982    procedure Lock_RTS is
 983    begin
 984       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 985    end Lock_RTS;
 986
 987    ----------------
 988    -- Unlock_RTS --
 989    ----------------
 990
 991    procedure Unlock_RTS is
 992    begin
 993       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 994    end Unlock_RTS;
 995
 996    ----------------
 997    -- Initialize --
 998    ----------------
 999
1000    procedure Initialize (Environment_Task : Task_Id) is
1001       Discard : BOOL;
1002       pragma Unreferenced (Discard);
1003
1004    begin
1005       Environment_Task_Id := Environment_Task;
1006
1007       if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
1008
1009          --  Here we need Annex E semantics, switch the current process to the
1010          --  High_Priority_Class.
1011
1012          Discard :=
1013            OS_Interface.SetPriorityClass
1014              (GetCurrentProcess, High_Priority_Class);
1015
1016          --  ??? In theory it should be possible to use the priority class
1017          --  Realtime_Prioriry_Class but we suspect a bug in the NT scheduler
1018          --  which prevents (in some obscure cases) a thread to get on top of
1019          --  the running queue by another thread of lower priority. For
1020          --  example cxd8002 ACATS test freeze.
1021       end if;
1022
1023       TlsIndex := TlsAlloc;
1024
1025       --  Initialize the lock used to synchronize chain of all ATCBs.
1026
1027       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1028
1029       Environment_Task.Common.LL.Thread := GetCurrentThread;
1030       Enter_Task (Environment_Task);
1031    end Initialize;
1032
1033    ---------------------
1034    -- Monotonic_Clock --
1035    ---------------------
1036
1037    function Monotonic_Clock return Duration
1038      renames System.OS_Primitives.Monotonic_Clock;
1039
1040    -------------------
1041    -- RT_Resolution --
1042    -------------------
1043
1044    function RT_Resolution return Duration is
1045    begin
1046       return 0.000_001; --  1 micro-second
1047    end RT_Resolution;
1048
1049    ----------------
1050    -- Check_Exit --
1051    ----------------
1052
1053    --  Dummy versions.  The only currently working versions is for solaris
1054    --  (native).
1055
1056    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1057       pragma Unreferenced (Self_ID);
1058
1059    begin
1060       return True;
1061    end Check_Exit;
1062
1063    --------------------
1064    -- Check_No_Locks --
1065    --------------------
1066
1067    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1068       pragma Unreferenced (Self_ID);
1069
1070    begin
1071       return True;
1072    end Check_No_Locks;
1073
1074    ------------------
1075    -- Suspend_Task --
1076    ------------------
1077
1078    function Suspend_Task
1079      (T           : ST.Task_Id;
1080       Thread_Self : Thread_Id) return Boolean
1081    is
1082    begin
1083       if T.Common.LL.Thread /= Thread_Self then
1084          return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
1085       else
1086          return True;
1087       end if;
1088    end Suspend_Task;
1089
1090    -----------------
1091    -- Resume_Task --
1092    -----------------
1093
1094    function Resume_Task
1095      (T           : ST.Task_Id;
1096       Thread_Self : Thread_Id) return Boolean
1097    is
1098    begin
1099       if T.Common.LL.Thread /= Thread_Self then
1100          return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
1101       else
1102          return True;
1103       end if;
1104    end Resume_Task;
1105
1106 end System.Task_Primitives.Operations;