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