gcc/ada/s-taprop-mingw.adb

   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-2005, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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.Stages.
  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    begin
 404       InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
 405    end Initialize_Lock;
 406
 407    -------------------
 408    -- Finalize_Lock --
 409    -------------------
 410
 411    procedure Finalize_Lock (L : access Lock) is
 412    begin
 413       DeleteCriticalSection (L.Mutex'Access);
 414    end Finalize_Lock;
 415
 416    procedure Finalize_Lock (L : access RTS_Lock) is
 417    begin
 418       DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
 419    end Finalize_Lock;
 420
 421    ----------------
 422    -- Write_Lock --
 423    ----------------
 424
 425    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 426    begin
 427       L.Owner_Priority := Get_Priority (Self);
 428
 429       if L.Priority < L.Owner_Priority then
 430          Ceiling_Violation := True;
 431          return;
 432       end if;
 433
 434       EnterCriticalSection (L.Mutex'Access);
 435
 436       Ceiling_Violation := False;
 437    end Write_Lock;
 438
 439    procedure Write_Lock
 440      (L           : access RTS_Lock;
 441       Global_Lock : Boolean := False)
 442    is
 443    begin
 444       if not Single_Lock or else Global_Lock then
 445          EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
 446       end if;
 447    end Write_Lock;
 448
 449    procedure Write_Lock (T : Task_Id) is
 450    begin
 451       if not Single_Lock then
 452          EnterCriticalSection
 453            (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
 454       end if;
 455    end Write_Lock;
 456
 457    ---------------
 458    -- Read_Lock --
 459    ---------------
 460
 461    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 462    begin
 463       Write_Lock (L, Ceiling_Violation);
 464    end Read_Lock;
 465
 466    ------------
 467    -- Unlock --
 468    ------------
 469
 470    procedure Unlock (L : access Lock) is
 471    begin
 472       LeaveCriticalSection (L.Mutex'Access);
 473    end Unlock;
 474
 475    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 476    begin
 477       if not Single_Lock or else Global_Lock then
 478          LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
 479       end if;
 480    end Unlock;
 481
 482    procedure Unlock (T : Task_Id) is
 483    begin
 484       if not Single_Lock then
 485          LeaveCriticalSection
 486            (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
 487       end if;
 488    end Unlock;
 489
 490    -----------
 491    -- Sleep --
 492    -----------
 493
 494    procedure Sleep
 495      (Self_ID : Task_Id;
 496       Reason  : System.Tasking.Task_States)
 497    is
 498       pragma Unreferenced (Reason);
 499
 500    begin
 501       pragma Assert (Self_ID = Self);
 502
 503       if Single_Lock then
 504          Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 505       else
 506          Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 507       end if;
 508
 509       if Self_ID.Deferral_Level = 0
 510         and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 511       then
 512          Unlock (Self_ID);
 513          raise Standard'Abort_Signal;
 514       end if;
 515    end Sleep;
 516
 517    -----------------
 518    -- Timed_Sleep --
 519    -----------------
 520
 521    --  This is for use within the run-time system, so abort is
 522    --  assumed to be already deferred, and the caller should be
 523    --  holding its own ATCB lock.
 524
 525    procedure Timed_Sleep
 526      (Self_ID  : Task_Id;
 527       Time     : Duration;
 528       Mode     : ST.Delay_Modes;
 529       Reason   : System.Tasking.Task_States;
 530       Timedout : out Boolean;
 531       Yielded  : out Boolean)
 532    is
 533       pragma Unreferenced (Reason);
 534       Check_Time : Duration := Monotonic_Clock;
 535       Rel_Time   : Duration;
 536       Abs_Time   : Duration;
 537       Result     : Integer;
 538
 539       Local_Timedout : Boolean;
 540
 541    begin
 542       Timedout := True;
 543       Yielded  := False;
 544
 545       if Mode = Relative then
 546          Rel_Time := Time;
 547          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 548       else
 549          Rel_Time := Time - Check_Time;
 550          Abs_Time := Time;
 551       end if;
 552
 553       if Rel_Time > 0.0 then
 554          loop
 555             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 556               or else Self_ID.Pending_Priority_Change;
 557
 558             if Single_Lock then
 559                Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
 560                  Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result);
 561             else
 562                Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
 563                  Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
 564             end if;
 565
 566             Check_Time := Monotonic_Clock;
 567             exit when Abs_Time <= Check_Time;
 568
 569             if not Local_Timedout then
 570
 571                --  Somebody may have called Wakeup for us
 572
 573                Timedout := False;
 574                exit;
 575             end if;
 576
 577             Rel_Time := Abs_Time - Check_Time;
 578          end loop;
 579       end if;
 580    end Timed_Sleep;
 581
 582    -----------------
 583    -- Timed_Delay --
 584    -----------------
 585
 586    procedure Timed_Delay
 587      (Self_ID  : Task_Id;
 588       Time     : Duration;
 589       Mode     : ST.Delay_Modes)
 590    is
 591       Check_Time : Duration := Monotonic_Clock;
 592       Rel_Time   : Duration;
 593       Abs_Time   : Duration;
 594       Result     : Integer;
 595       Timedout   : Boolean;
 596
 597    begin
 598       --  Only the little window between deferring abort and
 599       --  locking Self_ID is the reason we need to
 600       --  check for pending abort and priority change below!
 601
 602       SSL.Abort_Defer.all;
 603
 604       if Single_Lock then
 605          Lock_RTS;
 606       end if;
 607
 608       Write_Lock (Self_ID);
 609
 610       if Mode = Relative then
 611          Rel_Time := Time;
 612          Abs_Time := Time + Check_Time;
 613       else
 614          Rel_Time := Time - Check_Time;
 615          Abs_Time := Time;
 616       end if;
 617
 618       if Rel_Time > 0.0 then
 619          Self_ID.Common.State := Delay_Sleep;
 620
 621          loop
 622             if Self_ID.Pending_Priority_Change then
 623                Self_ID.Pending_Priority_Change := False;
 624                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 625                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 626             end if;
 627
 628             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 629
 630             if Single_Lock then
 631                Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
 632                  Single_RTS_Lock'Access, Rel_Time, Timedout, Result);
 633             else
 634                Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
 635                  Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
 636             end if;
 637
 638             Check_Time := Monotonic_Clock;
 639             exit when Abs_Time <= Check_Time;
 640
 641             Rel_Time := Abs_Time - Check_Time;
 642          end loop;
 643
 644          Self_ID.Common.State := Runnable;
 645       end if;
 646
 647       Unlock (Self_ID);
 648
 649       if Single_Lock then
 650          Unlock_RTS;
 651       end if;
 652
 653       Yield;
 654       SSL.Abort_Undefer.all;
 655    end Timed_Delay;
 656
 657    ------------
 658    -- Wakeup --
 659    ------------
 660
 661    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 662       pragma Unreferenced (Reason);
 663    begin
 664       Cond_Signal (T.Common.LL.CV'Access);
 665    end Wakeup;
 666
 667    -----------
 668    -- Yield --
 669    -----------
 670
 671    procedure Yield (Do_Yield : Boolean := True) is
 672    begin
 673       if Do_Yield then
 674          Sleep (0);
 675       end if;
 676    end Yield;
 677
 678    ------------------
 679    -- Set_Priority --
 680    ------------------
 681
 682    type Prio_Array_Type is array (System.Any_Priority) of Integer;
 683    pragma Atomic_Components (Prio_Array_Type);
 684
 685    Prio_Array : Prio_Array_Type;
 686    --  Global array containing the id of the currently running task for
 687    --  each priority.
 688    --
 689    --  Note: we assume that we are on a single processor with run-til-blocked
 690    --  scheduling.
 691
 692    procedure Set_Priority
 693      (T                   : Task_Id;
 694       Prio                : System.Any_Priority;
 695       Loss_Of_Inheritance : Boolean := False)
 696    is
 697       Res        : BOOL;
 698       Array_Item : Integer;
 699
 700    begin
 701       Res := SetThreadPriority
 702         (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
 703       pragma Assert (Res = True);
 704
 705       if FIFO_Within_Priorities then
 706
 707          --  Annex D requirement [RM D.2.2 par. 9]:
 708          --    If the task drops its priority due to the loss of inherited
 709          --    priority, it is added at the head of the ready queue for its
 710          --    new active priority.
 711
 712          if Loss_Of_Inheritance
 713            and then Prio < T.Common.Current_Priority
 714          then
 715             Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
 716             Prio_Array (T.Common.Base_Priority) := Array_Item;
 717
 718             loop
 719                --  Let some processes a chance to arrive
 720
 721                Yield;
 722
 723                --  Then wait for our turn to proceed
 724
 725                exit when Array_Item = Prio_Array (T.Common.Base_Priority)
 726                  or else Prio_Array (T.Common.Base_Priority) = 1;
 727             end loop;
 728
 729             Prio_Array (T.Common.Base_Priority) :=
 730               Prio_Array (T.Common.Base_Priority) - 1;
 731          end if;
 732       end if;
 733
 734       T.Common.Current_Priority := Prio;
 735    end Set_Priority;
 736
 737    ------------------
 738    -- Get_Priority --
 739    ------------------
 740
 741    function Get_Priority (T : Task_Id) return System.Any_Priority is
 742    begin
 743       return T.Common.Current_Priority;
 744    end Get_Priority;
 745
 746    ----------------
 747    -- Enter_Task --
 748    ----------------
 749
 750    --  There were two paths were we needed to call Enter_Task :
 751    --  1) from System.Task_Primitives.Operations.Initialize
 752    --  2) from System.Tasking.Stages.Task_Wrapper
 753    --
 754    --  The thread initialisation has to be done only for the first case.
 755    --
 756    --  This is because the GetCurrentThread NT call does not return the
 757    --  real thread handler but only a "pseudo" one. It is not possible to
 758    --  release the thread handle and free the system ressources from this
 759    --  "pseudo" handle. So we really want to keep the real thread handle
 760    --  set in System.Task_Primitives.Operations.Create_Task during the
 761    --  thread creation.
 762
 763    procedure Enter_Task (Self_ID : Task_Id) is
 764       procedure Init_Float;
 765       pragma Import (C, Init_Float, "__gnat_init_float");
 766       --  Properly initializes the FPU for x86 systems.
 767
 768    begin
 769       Specific.Set (Self_ID);
 770       Init_Float;
 771
 772       Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
 773
 774       Lock_RTS;
 775
 776       for J in Known_Tasks'Range loop
 777          if Known_Tasks (J) = null then
 778             Known_Tasks (J) := Self_ID;
 779             Self_ID.Known_Tasks_Index := J;
 780             exit;
 781          end if;
 782       end loop;
 783
 784       Unlock_RTS;
 785    end Enter_Task;
 786
 787    --------------
 788    -- New_ATCB --
 789    --------------
 790
 791    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 792    begin
 793       return new Ada_Task_Control_Block (Entry_Num);
 794    end New_ATCB;
 795
 796    -------------------
 797    -- Is_Valid_Task --
 798    -------------------
 799
 800    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 801
 802    -----------------------------
 803    -- Register_Foreign_Thread --
 804    -----------------------------
 805
 806    function Register_Foreign_Thread return Task_Id is
 807    begin
 808       if Is_Valid_Task then
 809          return Self;
 810       else
 811          return Register_Foreign_Thread (GetCurrentThread);
 812       end if;
 813    end Register_Foreign_Thread;
 814
 815    --------------------
 816    -- Initialize_TCB --
 817    --------------------
 818
 819    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 820    begin
 821       --  Initialize thread ID to 0, this is needed to detect threads that
 822       --  are not yet activated.
 823
 824       Self_ID.Common.LL.Thread := 0;
 825
 826       Initialize_Cond (Self_ID.Common.LL.CV'Access);
 827
 828       if not Single_Lock then
 829          Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
 830       end if;
 831
 832       Succeeded := True;
 833    end Initialize_TCB;
 834
 835    -----------------
 836    -- Create_Task --
 837    -----------------
 838
 839    procedure Create_Task
 840      (T          : Task_Id;
 841       Wrapper    : System.Address;
 842       Stack_Size : System.Parameters.Size_Type;
 843       Priority   : System.Any_Priority;
 844       Succeeded  : out Boolean)
 845    is
 846       pragma Unreferenced (Stack_Size);
 847
 848       Initial_Stack_Size : constant := 1024;
 849       --  We set the initial stack size to 1024. On Windows there is no way to
 850       --  fix a task stack size. Only the initial stack size can be set, the
 851       --  operating system will raise the task stack size if needed.
 852
 853       hTask          : HANDLE;
 854       TaskId         : aliased DWORD;
 855       pTaskParameter : System.OS_Interface.PVOID;
 856       Result         : DWORD;
 857       Entry_Point    : PTHREAD_START_ROUTINE;
 858
 859    begin
 860       pTaskParameter := To_Address (T);
 861
 862       Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper);
 863
 864       hTask := CreateThread
 865          (null,
 866           Initial_Stack_Size,
 867           Entry_Point,
 868           pTaskParameter,
 869           DWORD (Create_Suspended),
 870           TaskId'Unchecked_Access);
 871
 872       --  Step 1: Create the thread in blocked mode
 873
 874       if hTask = 0 then
 875          raise Storage_Error;
 876       end if;
 877
 878       --  Step 2: set its TCB
 879
 880       T.Common.LL.Thread := hTask;
 881
 882       --  Step 3: set its priority (child has inherited priority from parent)
 883
 884       Set_Priority (T, Priority);
 885
 886       if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
 887          --  Here we need Annex E semantics so we disable the NT priority
 888          --  boost. A priority boost is temporarily given by the system to a
 889          --  thread when it is taken out of a wait state.
 890
 891          SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
 892       end if;
 893
 894       --  Step 4: Now, start it for good:
 895
 896       Result := ResumeThread (hTask);
 897       pragma Assert (Result = 1);
 898
 899       Succeeded := Result = 1;
 900    end Create_Task;
 901
 902    ------------------
 903    -- Finalize_TCB --
 904    ------------------
 905
 906    procedure Finalize_TCB (T : Task_Id) is
 907       Self_ID   : Task_Id := T;
 908       Result    : DWORD;
 909       Succeeded : BOOL;
 910       Is_Self   : constant Boolean := T = Self;
 911
 912       procedure Free is new
 913         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 914
 915    begin
 916       if not Single_Lock then
 917          Finalize_Lock (T.Common.LL.L'Access);
 918       end if;
 919
 920       Finalize_Cond (T.Common.LL.CV'Access);
 921
 922       if T.Known_Tasks_Index /= -1 then
 923          Known_Tasks (T.Known_Tasks_Index) := null;
 924       end if;
 925
 926       if Self_ID.Common.LL.Thread /= 0 then
 927
 928          --  This task has been activated. Wait for the thread to terminate
 929          --  then close it. this is needed to release system ressources.
 930
 931          Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
 932          pragma Assert (Result /= WAIT_FAILED);
 933          Succeeded := CloseHandle (T.Common.LL.Thread);
 934          pragma Assert (Succeeded = True);
 935       end if;
 936
 937       Free (Self_ID);
 938
 939       if Is_Self then
 940          Specific.Set (null);
 941       end if;
 942    end Finalize_TCB;
 943
 944    ---------------
 945    -- Exit_Task --
 946    ---------------
 947
 948    procedure Exit_Task is
 949    begin
 950       Specific.Set (null);
 951    end Exit_Task;
 952
 953    ----------------
 954    -- Abort_Task --
 955    ----------------
 956
 957    procedure Abort_Task (T : Task_Id) is
 958       pragma Unreferenced (T);
 959    begin
 960       null;
 961    end Abort_Task;
 962
 963    ----------------------
 964    -- Environment_Task --
 965    ----------------------
 966
 967    function Environment_Task return Task_Id is
 968    begin
 969       return Environment_Task_Id;
 970    end Environment_Task;
 971
 972    --------------
 973    -- Lock_RTS --
 974    --------------
 975
 976    procedure Lock_RTS is
 977    begin
 978       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 979    end Lock_RTS;
 980
 981    ----------------
 982    -- Unlock_RTS --
 983    ----------------
 984
 985    procedure Unlock_RTS is
 986    begin
 987       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 988    end Unlock_RTS;
 989
 990    ----------------
 991    -- Initialize --
 992    ----------------
 993
 994    procedure Initialize (Environment_Task : Task_Id) is
 995       Discard : BOOL;
 996       pragma Unreferenced (Discard);
 997
 998    begin
 999       Environment_Task_Id := Environment_Task;
1000
1001       if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
1002
1003          --  Here we need Annex E semantics, switch the current process to the
1004          --  High_Priority_Class.
1005
1006          Discard :=
1007            OS_Interface.SetPriorityClass
1008              (GetCurrentProcess, High_Priority_Class);
1009
1010          --  ??? In theory it should be possible to use the priority class
1011          --  Realtime_Prioriry_Class but we suspect a bug in the NT scheduler
1012          --  which prevents (in some obscure cases) a thread to get on top of
1013          --  the running queue by another thread of lower priority. For
1014          --  example cxd8002 ACATS test freeze.
1015       end if;
1016
1017       TlsIndex := TlsAlloc;
1018
1019       --  Initialize the lock used to synchronize chain of all ATCBs.
1020
1021       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1022
1023       Environment_Task.Common.LL.Thread := GetCurrentThread;
1024       Enter_Task (Environment_Task);
1025    end Initialize;
1026
1027    ---------------------
1028    -- Monotonic_Clock --
1029    ---------------------
1030
1031    function Monotonic_Clock return Duration
1032      renames System.OS_Primitives.Monotonic_Clock;
1033
1034    -------------------
1035    -- RT_Resolution --
1036    -------------------
1037
1038    function RT_Resolution return Duration is
1039    begin
1040       return 0.000_001; --  1 micro-second
1041    end RT_Resolution;
1042
1043    ----------------
1044    -- Initialize --
1045    ----------------
1046
1047    procedure Initialize (S : in out Suspension_Object) is
1048    begin
1049       --  Initialize internal state. It is always initialized to False (ARM
1050       --  D.10 par. 6).
1051
1052       S.State := False;
1053       S.Waiting := False;
1054
1055       --  Initialize internal mutex
1056
1057       InitializeCriticalSection (S.L'Access);
1058
1059       --  Initialize internal condition variable
1060
1061       S.CV := CreateEvent (null, True, False, Null_Ptr);
1062       pragma Assert (S.CV /= 0);
1063    end Initialize;
1064
1065    --------------
1066    -- Finalize --
1067    --------------
1068
1069    procedure Finalize (S : in out Suspension_Object) is
1070       Result : BOOL;
1071    begin
1072       --  Destroy internal mutex
1073
1074       DeleteCriticalSection (S.L'Access);
1075
1076       --  Destroy internal condition variable
1077
1078       Result := CloseHandle (S.CV);
1079       pragma Assert (Result = True);
1080    end Finalize;
1081
1082    -------------------
1083    -- Current_State --
1084    -------------------
1085
1086    function Current_State (S : Suspension_Object) return Boolean is
1087    begin
1088       --  We do not want to use lock on this read operation. State is marked
1089       --  as Atomic so that we ensure that the value retrieved is correct.
1090
1091       return S.State;
1092    end Current_State;
1093
1094    ---------------
1095    -- Set_False --
1096    ---------------
1097
1098    procedure Set_False (S : in out Suspension_Object) is
1099    begin
1100       EnterCriticalSection (S.L'Access);
1101
1102       S.State := False;
1103
1104       LeaveCriticalSection (S.L'Access);
1105    end Set_False;
1106
1107    --------------
1108    -- Set_True --
1109    --------------
1110
1111    procedure Set_True (S : in out Suspension_Object) is
1112       Result : BOOL;
1113    begin
1114       EnterCriticalSection (S.L'Access);
1115
1116       --  If there is already a task waiting on this suspension object then
1117       --  we resume it, leaving the state of the suspension object to False,
1118       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1119       --  the state to True.
1120
1121       if S.Waiting then
1122          S.Waiting := False;
1123          S.State := False;
1124
1125          Result := SetEvent (S.CV);
1126          pragma Assert (Result = True);
1127       else
1128          S.State := True;
1129       end if;
1130
1131       LeaveCriticalSection (S.L'Access);
1132    end Set_True;
1133
1134    ------------------------
1135    -- Suspend_Until_True --
1136    ------------------------
1137
1138    procedure Suspend_Until_True (S : in out Suspension_Object) is
1139       Result      : DWORD;
1140       Result_Bool : BOOL;
1141    begin
1142       EnterCriticalSection (S.L'Access);
1143
1144       if S.Waiting then
1145          --  Program_Error must be raised upon calling Suspend_Until_True
1146          --  if another task is already waiting on that suspension object
1147          --  (ARM D.10 par. 10).
1148
1149          LeaveCriticalSection (S.L'Access);
1150
1151          raise Program_Error;
1152       else
1153          --  Suspend the task if the state is False. Otherwise, the task
1154          --  continues its execution, and the state of the suspension object
1155          --  is set to False (ARM D.10 par. 9).
1156
1157          if S.State then
1158             S.State := False;
1159
1160             LeaveCriticalSection (S.L'Access);
1161          else
1162             S.Waiting := True;
1163
1164             --  Must reset CV BEFORE L is unlocked.
1165
1166             Result_Bool := ResetEvent (S.CV);
1167             pragma Assert (Result_Bool = True);
1168
1169             LeaveCriticalSection (S.L'Access);
1170
1171             Result := WaitForSingleObject (S.CV, Wait_Infinite);
1172             pragma Assert (Result = 0);
1173          end if;
1174       end if;
1175    end Suspend_Until_True;
1176
1177    ----------------
1178    -- Check_Exit --
1179    ----------------
1180
1181    --  Dummy versions.  The only currently working versions is for solaris
1182    --  (native).
1183
1184    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1185       pragma Unreferenced (Self_ID);
1186    begin
1187       return True;
1188    end Check_Exit;
1189
1190    --------------------
1191    -- Check_No_Locks --
1192    --------------------
1193
1194    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1195       pragma Unreferenced (Self_ID);
1196    begin
1197       return True;
1198    end Check_No_Locks;
1199
1200    ------------------
1201    -- Suspend_Task --
1202    ------------------
1203
1204    function Suspend_Task
1205      (T           : ST.Task_Id;
1206       Thread_Self : Thread_Id) return Boolean
1207    is
1208    begin
1209       if T.Common.LL.Thread /= Thread_Self then
1210          return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
1211       else
1212          return True;
1213       end if;
1214    end Suspend_Task;
1215
1216    -----------------
1217    -- Resume_Task --
1218    -----------------
1219
1220    function Resume_Task
1221      (T           : ST.Task_Id;
1222       Thread_Self : Thread_Id) return Boolean
1223    is
1224    begin
1225       if T.Common.LL.Thread /= Thread_Self then
1226          return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
1227       else
1228          return True;
1229       end if;
1230    end Resume_Task;
1231
1232 end System.Task_Primitives.Operations;