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