gcc/ada/5staprop.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-2002, 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 Solaris (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 Ada.Exceptions;
  47 --  used for Raise_Exception
  48
  49 with GNAT.OS_Lib;
  50 --  used for String_Access, Getenv
  51
  52 with Interfaces.C;
  53 --  used for int
  54 --           size_t
  55
  56 with System.Interrupt_Management;
  57 --  used for Keep_Unmasked
  58 --           Abort_Task_Interrupt
  59 --           Interrupt_ID
  60
  61 with System.Interrupt_Management.Operations;
  62 --  used for Set_Interrupt_Mask
  63 --           All_Tasks_Mask
  64 pragma Elaborate_All (System.Interrupt_Management.Operations);
  65
  66 with System.Parameters;
  67 --  used for Size_Type
  68
  69 with System.Tasking;
  70 --  used for Ada_Task_Control_Block
  71 --           Task_ID
  72 --           ATCB components and types
  73
  74 with System.Task_Info;
  75 --  to initialize Task_Info for a C thread, in function Self
  76
  77 with System.Soft_Links;
  78 --  used for Defer/Undefer_Abort
  79 --       to initialize TSD for a C thread, in function Self
  80
  81 --  Note that we do not use System.Tasking.Initialization directly since
  82 --  this is a higher level package that we shouldn't depend on. For example
  83 --  when using the restricted run time, it is replaced by
  84 --  System.Tasking.Restricted.Initialization
  85
  86 with System.OS_Primitives;
  87 --  used for Delay_Modes
  88
  89 with Unchecked_Conversion;
  90 with Unchecked_Deallocation;
  91
  92 package body System.Task_Primitives.Operations is
  93
  94    use System.Tasking.Debug;
  95    use System.Tasking;
  96    use Interfaces.C;
  97    use System.OS_Interface;
  98    use System.Parameters;
  99    use Ada.Exceptions;
 100    use System.OS_Primitives;
 101
 102    package SSL renames System.Soft_Links;
 103
 104    ------------------
 105    --  Local Data  --
 106    ------------------
 107
 108    --  The following are logically constants, but need to be initialized
 109    --  at run time.
 110
 111    Environment_Task_ID : Task_ID;
 112    --  A variable to hold Task_ID for the environment task.
 113    --  If we use this variable to get the Task_ID, we need the following
 114    --  ATCB_Key only for non-Ada threads.
 115
 116    Unblocked_Signal_Mask : aliased sigset_t;
 117    --  The set of signals that should unblocked in all tasks
 118
 119    ATCB_Key : aliased thread_key_t;
 120    --  Key used to find the Ada Task_ID associated with a thread,
 121    --  at least for C threads unknown to the Ada run-time system.
 122
 123    Single_RTS_Lock : aliased RTS_Lock;
 124    --  This is a lock to allow only one thread of control in the RTS at
 125    --  a time; it is used to execute in mutual exclusion from all other tasks.
 126    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
 127
 128    Next_Serial_Number : Task_Serial_Number := 100;
 129    --  We start at 100, to reserve some special values for
 130    --  using in error checking.
 131    --  The following are internal configuration constants needed.
 132
 133    ------------------------
 134    --  Priority Support  --
 135    ------------------------
 136
 137    Priority_Ceiling_Emulation : constant Boolean := True;
 138    --  controls whether we emulate priority ceiling locking
 139
 140    --  To get a scheduling close to annex D requirements, we use the real-time
 141    --  class provided for LWP's and map each task/thread to a specific and
 142    --  unique LWP (there is 1 thread per LWP, and 1 LWP per thread).
 143
 144    --  The real time class can only be set when the process has root
 145    --  priviledges, so in the other cases, we use the normal thread scheduling
 146    --  and priority handling.
 147
 148    Using_Real_Time_Class : Boolean := False;
 149    --  indicates wether the real time class is being used (i.e the process
 150    --  has root priviledges).
 151
 152    Prio_Param : aliased struct_pcparms;
 153    --  Hold priority info (Real_Time) initialized during the package
 154    --  elaboration.
 155
 156    -------------------------------------
 157    --  External Configuration Values  --
 158    -------------------------------------
 159
 160    Time_Slice_Val : Interfaces.C.long;
 161    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 162
 163    Locking_Policy : Character;
 164    pragma Import (C, Locking_Policy, "__gl_locking_policy");
 165
 166    Dispatching_Policy : Character;
 167    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 168
 169    --------------------------------
 170    --  Foreign Threads Detection --
 171    --------------------------------
 172
 173    --  The following are used to allow the Self function to
 174    --  automatically generate ATCB's for C threads that happen to call
 175    --  Ada procedure, which in turn happen to call the Ada run-time system.
 176
 177    type Fake_ATCB;
 178    type Fake_ATCB_Ptr is access Fake_ATCB;
 179    type Fake_ATCB is record
 180       Stack_Base : Interfaces.C.unsigned := 0;
 181       --  A value of zero indicates the node is not in use.
 182       Next       : Fake_ATCB_Ptr;
 183       Real_ATCB  : aliased Ada_Task_Control_Block (0);
 184    end record;
 185
 186    Fake_ATCB_List : Fake_ATCB_Ptr;
 187    --  A linear linked list.
 188    --  The list is protected by Single_RTS_Lock;
 189    --  Nodes are added to this list from the front.
 190    --  Once a node is added to this list, it is never removed.
 191
 192    Fake_Task_Elaborated : aliased Boolean := True;
 193    --  Used to identified fake tasks (i.e., non-Ada Threads).
 194
 195    Next_Fake_ATCB : Fake_ATCB_Ptr;
 196    --  Used to allocate one Fake_ATCB in advance. See comment in New_Fake_ATCB
 197
 198    ------------
 199    -- Checks --
 200    ------------
 201
 202    Check_Count  : Integer := 0;
 203    Old_Owner    : Task_ID;
 204    Lock_Count   : Integer := 0;
 205    Unlock_Count : Integer := 0;
 206
 207    function To_Lock_Ptr is
 208      new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
 209    function To_Task_ID is
 210      new Unchecked_Conversion (Owner_ID, Task_ID);
 211    function To_Owner_ID is
 212      new Unchecked_Conversion (Task_ID, Owner_ID);
 213
 214    -----------------------
 215    -- Local Subprograms --
 216    -----------------------
 217
 218    function sysconf (name : System.OS_Interface.int)
 219      return processorid_t;
 220    pragma Import (C, sysconf, "sysconf");
 221
 222    SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14;
 223
 224    function Num_Procs (name : System.OS_Interface.int := SC_NPROCESSORS_CONF)
 225      return processorid_t renames sysconf;
 226
 227    procedure Abort_Handler
 228      (Sig     : Signal;
 229       Code    : access siginfo_t;
 230       Context : access ucontext_t);
 231
 232    function To_thread_t is new Unchecked_Conversion
 233      (Integer, System.OS_Interface.thread_t);
 234
 235    function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
 236
 237    function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
 238
 239    function Thread_Body_Access is
 240      new Unchecked_Conversion (System.Address, Thread_Body);
 241
 242    function New_Fake_ATCB (Stack_Base : Interfaces.C.unsigned) return Task_ID;
 243    --  Allocate and Initialize a new ATCB. This code can safely be called from
 244    --  a foreign thread, as it doesn't access implicitly or explicitly
 245    --  "self" before having initialized the new ATCB.
 246    pragma Warnings (Off, New_Fake_ATCB);
 247    --  Disable warning on this function, since the Solaris x86 version does
 248    --  not use it.
 249
 250    ------------
 251    -- Checks --
 252    ------------
 253
 254    function Check_Initialize_Lock (L : Lock_Ptr; Level : Lock_Level)
 255      return Boolean;
 256    pragma Inline (Check_Initialize_Lock);
 257
 258    function Check_Lock (L : Lock_Ptr) return Boolean;
 259    pragma Inline (Check_Lock);
 260
 261    function Record_Lock (L : Lock_Ptr) return Boolean;
 262    pragma Inline (Record_Lock);
 263
 264    function Check_Sleep (Reason : Task_States) return Boolean;
 265    pragma Inline (Check_Sleep);
 266
 267    function Record_Wakeup
 268      (L : Lock_Ptr;
 269       Reason : Task_States) return Boolean;
 270    pragma Inline (Record_Wakeup);
 271
 272    function Check_Wakeup
 273      (T : Task_ID;
 274       Reason : Task_States) return Boolean;
 275    pragma Inline (Check_Wakeup);
 276
 277    function Check_Unlock (L : Lock_Ptr) return Boolean;
 278    pragma Inline (Check_Lock);
 279
 280    function Check_Finalize_Lock (L : Lock_Ptr) return Boolean;
 281    pragma Inline (Check_Finalize_Lock);
 282
 283    -------------------
 284    -- New_Fake_ATCB --
 285    -------------------
 286
 287    function New_Fake_ATCB (Stack_Base : Interfaces.C.unsigned)
 288      return Task_ID
 289    is
 290       Self_ID   : Task_ID;
 291       P, Q      : Fake_ATCB_Ptr;
 292       Succeeded : Boolean;
 293       Result    : Interfaces.C.int;
 294
 295    begin
 296       --  This section is ticklish.
 297       --  We dare not call anything that might require an ATCB, until
 298       --  we have the new ATCB in place.
 299       --  Note: we don't use Lock_RTS because we don't yet have an ATCB, and
 300       --  so can't pass the safety check.
 301
 302       Result := mutex_lock (Single_RTS_Lock.L'Access);
 303       Q := null;
 304       P := Fake_ATCB_List;
 305
 306       while P /= null loop
 307          if P.Stack_Base = 0 then
 308             Q := P;
 309          elsif thr_kill (P.Real_ATCB.Common.LL.Thread, 0) /= 0 then
 310             --  ????
 311             --  If a C thread that has dependent Ada tasks terminates
 312             --  abruptly, e.g. as a result of cancellation, any dependent
 313             --  tasks are likely to hang up in termination.
 314             P.Stack_Base := 0;
 315             Q := P;
 316          end if;
 317
 318          P := P.Next;
 319       end loop;
 320
 321       if Q = null then
 322
 323          --  Create a new ATCB with zero entries.
 324
 325          Self_ID := Next_Fake_ATCB.Real_ATCB'Access;
 326          Next_Fake_ATCB.Stack_Base := Stack_Base;
 327          Next_Fake_ATCB.Next := Fake_ATCB_List;
 328          Fake_ATCB_List := Next_Fake_ATCB;
 329          Next_Fake_ATCB := null;
 330
 331       else
 332
 333          --  Reuse an existing fake ATCB.
 334
 335          Self_ID := Q.Real_ATCB'Access;
 336          Q.Stack_Base := Stack_Base;
 337       end if;
 338
 339       --  Do the standard initializations
 340
 341       System.Tasking.Initialize_ATCB
 342         (Self_ID, null, Null_Address, Null_Task, Fake_Task_Elaborated'Access,
 343          System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_ID,
 344          Succeeded);
 345       pragma Assert (Succeeded);
 346
 347       --  Record this as the Task_ID for the current thread.
 348
 349       Self_ID.Common.LL.Thread := thr_self;
 350       Result := thr_setspecific (ATCB_Key, To_Address (Self_ID));
 351       pragma Assert (Result = 0);
 352
 353       --  Finally, it is safe to use an allocator in this thread.
 354
 355       if Next_Fake_ATCB = null then
 356          Next_Fake_ATCB := new Fake_ATCB;
 357       end if;
 358
 359       Self_ID.Master_of_Task := 0;
 360       Self_ID.Master_Within := Self_ID.Master_of_Task + 1;
 361
 362       for L in Self_ID.Entry_Calls'Range loop
 363          Self_ID.Entry_Calls (L).Self := Self_ID;
 364          Self_ID.Entry_Calls (L).Level := L;
 365       end loop;
 366
 367       Self_ID.Common.State := Runnable;
 368       Self_ID.Awake_Count := 1;
 369
 370       --  Since this is not an ordinary Ada task, we will start out undeferred
 371
 372       Self_ID.Deferral_Level := 0;
 373
 374       --  Give the task a unique serial number.
 375
 376       Self_ID.Serial_Number := Next_Serial_Number;
 377       Next_Serial_Number := Next_Serial_Number + 1;
 378       pragma Assert (Next_Serial_Number /= 0);
 379
 380       System.Soft_Links.Create_TSD (Self_ID.Common.Compiler_Data);
 381
 382       --  ????
 383       --  The following call is commented out to avoid dependence on
 384       --  the System.Tasking.Initialization package.
 385
 386       --  It seems that if we want Ada.Task_Attributes to work correctly
 387       --  for C threads we will need to raise the visibility of this soft
 388       --  link to System.Soft_Links.
 389
 390       --  We are putting that off until this new functionality is otherwise
 391       --  stable.
 392
 393       --  System.Tasking.Initialization.Initialize_Attributes_Link.all (T);
 394
 395       --  Must not unlock until Next_ATCB is again allocated.
 396
 397       for J in Known_Tasks'Range loop
 398          if Known_Tasks (J) = null then
 399             Known_Tasks (J) := Self_ID;
 400             Self_ID.Known_Tasks_Index := J;
 401             exit;
 402          end if;
 403       end loop;
 404
 405       Result := mutex_unlock (Single_RTS_Lock.L'Access);
 406
 407       --  We cannot use Unlock_RTS because we did not use Write_Lock, and so
 408       --  would not pass the checks.
 409
 410       return Self_ID;
 411    end New_Fake_ATCB;
 412
 413    -------------------
 414    -- Abort_Handler --
 415    -------------------
 416
 417    --  Target-dependent binding of inter-thread Abort signal to
 418    --  the raising of the Abort_Signal exception.
 419
 420    --  The technical issues and alternatives here are essentially
 421    --  the same as for raising exceptions in response to other
 422    --  signals (e.g. Storage_Error).  See code and comments in
 423    --  the package body System.Interrupt_Management.
 424
 425    --  Some implementations may not allow an exception to be propagated
 426    --  out of a handler, and others might leave the signal or
 427    --  interrupt that invoked this handler masked after the exceptional
 428    --  return to the application code.
 429
 430    --  GNAT exceptions are originally implemented using setjmp()/longjmp().
 431    --  On most UNIX systems, this will allow transfer out of a signal handler,
 432    --  which is usually the only mechanism available for implementing
 433    --  asynchronous handlers of this kind.  However, some
 434    --  systems do not restore the signal mask on longjmp(), leaving the
 435    --  abort signal masked.
 436
 437    --  Alternative solutions include:
 438
 439    --       1. Change the PC saved in the system-dependent Context
 440    --          parameter to point to code that raises the exception.
 441    --          Normal return from this handler will then raise
 442    --          the exception after the mask and other system state has
 443    --          been restored (see example below).
 444    --       2. Use siglongjmp()/sigsetjmp() to implement exceptions.
 445    --       3. Unmask the signal in the Abortion_Signal exception handler
 446    --          (in the RTS).
 447
 448    --  The following procedure would be needed if we can't longjmp out of
 449    --  a signal handler.  (See below.)
 450
 451    --  procedure Raise_Abort_Signal is
 452    --  begin
 453    --     raise Standard'Abort_Signal;
 454    --  end if;
 455
 456    --  ???
 457    --  The comments above need revising.  They are partly obsolete.
 458
 459    procedure Abort_Handler
 460      (Sig     : Signal;
 461       Code    : access siginfo_t;
 462       Context : access ucontext_t)
 463    is
 464       Self_ID : Task_ID := Self;
 465       Result  : Interfaces.C.int;
 466       Old_Set : aliased sigset_t;
 467
 468    begin
 469       --  Assuming it is safe to longjmp out of a signal handler, the
 470       --  following code can be used:
 471
 472       if Self_ID.Deferral_Level = 0
 473         and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 474         and then not Self_ID.Aborting
 475       then
 476          --  You can comment the following out,
 477          --  to make all aborts synchronous, for debugging.
 478
 479          Self_ID.Aborting := True;
 480
 481          --  Make sure signals used for RTS internal purpose are unmasked
 482
 483          Result := thr_sigsetmask (SIG_UNBLOCK,
 484            Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
 485          pragma Assert (Result = 0);
 486
 487          raise Standard'Abort_Signal;
 488
 489          --  ?????
 490          --  Must be certain that the implementation of "raise"
 491          --  does not make any OS/thread calls, or at least that
 492          --  if it makes any, they are safe for interruption by
 493          --  async. signals.
 494       end if;
 495
 496       --  Otherwise, something like this is required:
 497       --  if not Abort_Is_Deferred.all then
 498       --    --  Overwrite the return PC address with the address of the
 499       --    --  special raise routine, and "return" to that routine's
 500       --    --  starting address.
 501       --    Context.PC := Raise_Abort_Signal'Address;
 502       --    return;
 503       --  end if;
 504
 505    end Abort_Handler;
 506
 507    -------------------
 508    --  Stack_Guard  --
 509    -------------------
 510
 511    --  The underlying thread system sets a guard page at the
 512    --  bottom of a thread stack, so nothing is needed.
 513
 514    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
 515    begin
 516       null;
 517    end Stack_Guard;
 518
 519    --------------------
 520    -- Get_Thread_Id  --
 521    --------------------
 522
 523    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
 524    begin
 525       return T.Common.LL.Thread;
 526    end Get_Thread_Id;
 527
 528    -----------
 529    -- Self  --
 530    -----------
 531
 532    function Self return Task_ID is separate;
 533
 534    ---------------------
 535    -- Initialize_Lock --
 536    ---------------------
 537
 538    --  Note: mutexes and cond_variables needed per-task basis are
 539    --        initialized in Initialize_TCB and the Storage_Error is
 540    --        handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 541    --        used in RTS is initialized before any status change of RTS.
 542    --        Therefore rasing Storage_Error in the following routines
 543    --        should be able to be handled safely.
 544
 545    procedure Initialize_Lock
 546      (Prio : System.Any_Priority;
 547       L    : access Lock)
 548    is
 549       Result : Interfaces.C.int;
 550
 551    begin
 552       pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level));
 553
 554       if Priority_Ceiling_Emulation then
 555          L.Ceiling := Prio;
 556       end if;
 557
 558       Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
 559       pragma Assert (Result = 0 or else Result = ENOMEM);
 560
 561       if Result = ENOMEM then
 562          Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock");
 563       end if;
 564    end Initialize_Lock;
 565
 566    procedure Initialize_Lock
 567      (L : access RTS_Lock;
 568       Level : Lock_Level)
 569    is
 570       Result : Interfaces.C.int;
 571
 572    begin
 573       pragma Assert (Check_Initialize_Lock
 574         (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level));
 575       Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address);
 576       pragma Assert (Result = 0 or else Result = ENOMEM);
 577
 578       if Result = ENOMEM then
 579          Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock");
 580       end if;
 581    end Initialize_Lock;
 582
 583    -------------------
 584    -- Finalize_Lock --
 585    -------------------
 586
 587    procedure Finalize_Lock (L : access Lock) is
 588       Result : Interfaces.C.int;
 589
 590    begin
 591       pragma Assert (Check_Finalize_Lock (Lock_Ptr (L)));
 592       Result := mutex_destroy (L.L'Access);
 593       pragma Assert (Result = 0);
 594    end Finalize_Lock;
 595
 596    procedure Finalize_Lock (L : access RTS_Lock) is
 597       Result : Interfaces.C.int;
 598
 599    begin
 600       pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
 601       Result := mutex_destroy (L.L'Access);
 602       pragma Assert (Result = 0);
 603    end Finalize_Lock;
 604
 605    ----------------
 606    -- Write_Lock --
 607    ----------------
 608
 609    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 610       Result : Interfaces.C.int;
 611
 612    begin
 613       pragma Assert (Check_Lock (Lock_Ptr (L)));
 614
 615       if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
 616          declare
 617             Self_Id        : constant Task_ID := Self;
 618             Saved_Priority : System.Any_Priority;
 619
 620          begin
 621             if Self_Id.Common.LL.Active_Priority > L.Ceiling then
 622                Ceiling_Violation := True;
 623                return;
 624             end if;
 625
 626             Saved_Priority := Self_Id.Common.LL.Active_Priority;
 627
 628             if Self_Id.Common.LL.Active_Priority < L.Ceiling then
 629                Set_Priority (Self_Id, L.Ceiling);
 630             end if;
 631
 632             Result := mutex_lock (L.L'Access);
 633             pragma Assert (Result = 0);
 634             Ceiling_Violation := False;
 635
 636             L.Saved_Priority := Saved_Priority;
 637          end;
 638
 639       else
 640          Result := mutex_lock (L.L'Access);
 641          pragma Assert (Result = 0);
 642          Ceiling_Violation := False;
 643       end if;
 644
 645       pragma Assert (Record_Lock (Lock_Ptr (L)));
 646    end Write_Lock;
 647
 648    procedure Write_Lock
 649      (L : access RTS_Lock; Global_Lock : Boolean := False)
 650    is
 651       Result : Interfaces.C.int;
 652    begin
 653       if not Single_Lock or else Global_Lock then
 654          pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
 655          Result := mutex_lock (L.L'Access);
 656          pragma Assert (Result = 0);
 657          pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
 658       end if;
 659    end Write_Lock;
 660
 661    procedure Write_Lock (T : Task_ID) is
 662       Result : Interfaces.C.int;
 663    begin
 664       if not Single_Lock then
 665          pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
 666          Result := mutex_lock (T.Common.LL.L.L'Access);
 667          pragma Assert (Result = 0);
 668          pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
 669       end if;
 670    end Write_Lock;
 671
 672    ---------------
 673    -- Read_Lock --
 674    ---------------
 675
 676    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 677    begin
 678       Write_Lock (L, Ceiling_Violation);
 679    end Read_Lock;
 680
 681    ------------
 682    -- Unlock --
 683    ------------
 684
 685    procedure Unlock (L : access Lock) is
 686       Result  : Interfaces.C.int;
 687    begin
 688       pragma Assert (Check_Unlock (Lock_Ptr (L)));
 689
 690       if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then
 691          declare
 692             Self_Id : constant Task_ID := Self;
 693
 694          begin
 695             Result := mutex_unlock (L.L'Access);
 696             pragma Assert (Result = 0);
 697
 698             if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then
 699                Set_Priority (Self_Id, L.Saved_Priority);
 700             end if;
 701          end;
 702       else
 703          Result := mutex_unlock (L.L'Access);
 704          pragma Assert (Result = 0);
 705       end if;
 706    end Unlock;
 707
 708    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 709       Result : Interfaces.C.int;
 710    begin
 711       if not Single_Lock or else Global_Lock then
 712          pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
 713          Result := mutex_unlock (L.L'Access);
 714          pragma Assert (Result = 0);
 715       end if;
 716    end Unlock;
 717
 718    procedure Unlock (T : Task_ID) is
 719       Result : Interfaces.C.int;
 720    begin
 721       if not Single_Lock then
 722          pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
 723          Result := mutex_unlock (T.Common.LL.L.L'Access);
 724          pragma Assert (Result = 0);
 725       end if;
 726    end Unlock;
 727
 728    --  For the time delay implementation, we need to make sure we
 729    --  achieve following criteria:
 730
 731    --  1) We have to delay at least for the amount requested.
 732    --  2) We have to give up CPU even though the actual delay does not
 733    --     result in blocking.
 734    --  3) Except for restricted run-time systems that do not support
 735    --     ATC or task abort, the delay must be interrupted by the
 736    --     abort_task operation.
 737    --  4) The implementation has to be efficient so that the delay overhead
 738    --     is relatively cheap.
 739    --  (1)-(3) are Ada requirements. Even though (2) is an Annex-D
 740    --     requirement we still want to provide the effect in all cases.
 741    --     The reason is that users may want to use short delays to implement
 742    --     their own scheduling effect in the absence of language provided
 743    --     scheduling policies.
 744
 745    ---------------------
 746    -- Monotonic_Clock --
 747    ---------------------
 748
 749    function Monotonic_Clock return Duration is
 750       TS     : aliased timespec;
 751       Result : Interfaces.C.int;
 752
 753    begin
 754       Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
 755       pragma Assert (Result = 0);
 756       return To_Duration (TS);
 757    end Monotonic_Clock;
 758
 759    -------------------
 760    -- RT_Resolution --
 761    -------------------
 762
 763    function RT_Resolution return Duration is
 764    begin
 765       return 10#1.0#E-6;
 766    end RT_Resolution;
 767
 768    -----------
 769    -- Yield --
 770    -----------
 771
 772    procedure Yield (Do_Yield : Boolean := True) is
 773    begin
 774       if Do_Yield then
 775          System.OS_Interface.thr_yield;
 776       end if;
 777    end Yield;
 778
 779    ------------------
 780    -- Set_Priority --
 781    ------------------
 782
 783    procedure Set_Priority
 784      (T : Task_ID;
 785       Prio : System.Any_Priority;
 786       Loss_Of_Inheritance : Boolean := False)
 787    is
 788       Result  : Interfaces.C.int;
 789       Param   : aliased struct_pcparms;
 790
 791       use Task_Info;
 792
 793    begin
 794       T.Common.Current_Priority := Prio;
 795
 796       if Priority_Ceiling_Emulation then
 797          T.Common.LL.Active_Priority := Prio;
 798       end if;
 799
 800       if Using_Real_Time_Class then
 801          Param.pc_cid := Prio_Param.pc_cid;
 802          Param.rt_pri := pri_t (Prio);
 803          Param.rt_tqsecs := Prio_Param.rt_tqsecs;
 804          Param.rt_tqnsecs := Prio_Param.rt_tqnsecs;
 805
 806          Result := Interfaces.C.int (
 807            priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS,
 808              Param'Address));
 809
 810       else
 811          if T.Common.Task_Info /= null
 812            and then not T.Common.Task_Info.Bound_To_LWP
 813          then
 814             --  The task is not bound to a LWP, so use thr_setprio
 815
 816             Result :=
 817               thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
 818
 819          else
 820
 821             --  The task is bound to a LWP, use priocntl
 822             --  ??? TBD
 823
 824             null;
 825          end if;
 826       end if;
 827    end Set_Priority;
 828
 829    ------------------
 830    -- Get_Priority --
 831    ------------------
 832
 833    function Get_Priority (T : Task_ID) return System.Any_Priority is
 834    begin
 835       return T.Common.Current_Priority;
 836    end Get_Priority;
 837
 838    ----------------
 839    -- Enter_Task --
 840    ----------------
 841
 842    procedure Enter_Task (Self_ID : Task_ID) is
 843       Result    : Interfaces.C.int;
 844       Proc      : processorid_t;  --  User processor #
 845       Last_Proc : processorid_t;  --  Last processor #
 846
 847       use System.Task_Info;
 848    begin
 849       Self_ID.Common.LL.Thread := thr_self;
 850
 851       Self_ID.Common.LL.LWP := lwp_self;
 852
 853       if Self_ID.Common.Task_Info /= null then
 854          if Self_ID.Common.Task_Info.New_LWP
 855            and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED
 856          then
 857             Last_Proc := Num_Procs - 1;
 858
 859             if Self_ID.Common.Task_Info.CPU = ANY_CPU then
 860                Result := 0;
 861                Proc := 0;
 862
 863                while Proc < Last_Proc loop
 864                   Result := p_online (Proc, PR_STATUS);
 865                   exit when Result = PR_ONLINE;
 866                   Proc := Proc + 1;
 867                end loop;
 868
 869                Result := processor_bind (P_LWPID, P_MYID, Proc, null);
 870                pragma Assert (Result = 0);
 871
 872             else
 873                --  Use specified processor
 874
 875                if Self_ID.Common.Task_Info.CPU < 0
 876                  or else Self_ID.Common.Task_Info.CPU > Last_Proc
 877                then
 878                   raise Invalid_CPU_Number;
 879                end if;
 880
 881                Result := processor_bind
 882                  (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null);
 883                pragma Assert (Result = 0);
 884             end if;
 885          end if;
 886       end if;
 887
 888       Result := thr_setspecific (ATCB_Key, To_Address (Self_ID));
 889       pragma Assert (Result = 0);
 890
 891       --  We need the above code even if we do direct fetch of Task_ID in Self
 892       --  for the main task on Sun, x86 Solaris and for gcc 2.7.2.
 893
 894       Lock_RTS;
 895
 896       for J in Known_Tasks'Range loop
 897          if Known_Tasks (J) = null then
 898             Known_Tasks (J) := Self_ID;
 899             Self_ID.Known_Tasks_Index := J;
 900             exit;
 901          end if;
 902       end loop;
 903
 904       Unlock_RTS;
 905    end Enter_Task;
 906
 907    --------------
 908    -- New_ATCB --
 909    --------------
 910
 911    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 912    begin
 913       return new Ada_Task_Control_Block (Entry_Num);
 914    end New_ATCB;
 915
 916    --------------------
 917    -- Initialize_TCB --
 918    --------------------
 919
 920    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 921       Result : Interfaces.C.int := 0;
 922    begin
 923       --  Give the task a unique serial number.
 924
 925       Self_ID.Serial_Number := Next_Serial_Number;
 926       Next_Serial_Number := Next_Serial_Number + 1;
 927       pragma Assert (Next_Serial_Number /= 0);
 928
 929       Self_ID.Common.LL.Thread := To_thread_t (-1);
 930
 931       if not Single_Lock then
 932          Result := mutex_init
 933            (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address);
 934          Self_ID.Common.LL.L.Level :=
 935            Private_Task_Serial_Number (Self_ID.Serial_Number);
 936          pragma Assert (Result = 0 or else Result = ENOMEM);
 937       end if;
 938
 939       if Result = 0 then
 940          Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0);
 941          pragma Assert (Result = 0 or else Result = ENOMEM);
 942       end if;
 943
 944       if Result = 0 then
 945          Succeeded := True;
 946       else
 947          if not Single_Lock then
 948             Result := mutex_destroy (Self_ID.Common.LL.L.L'Access);
 949             pragma Assert (Result = 0);
 950          end if;
 951
 952          Succeeded := False;
 953       end if;
 954    end Initialize_TCB;
 955
 956    -----------------
 957    -- Create_Task --
 958    -----------------
 959
 960    procedure Create_Task
 961      (T          : Task_ID;
 962       Wrapper    : System.Address;
 963       Stack_Size : System.Parameters.Size_Type;
 964       Priority   : System.Any_Priority;
 965       Succeeded  : out Boolean)
 966    is
 967       Result     : Interfaces.C.int;
 968       Adjusted_Stack_Size : Interfaces.C.size_t;
 969       Opts       : Interfaces.C.int := THR_DETACHED;
 970
 971       Page_Size  : constant System.Parameters.Size_Type := 4096;
 972       --  This constant is for reserving extra space at the
 973       --  end of the stack, which can be used by the stack
 974       --  checking as guard page. The idea is that we need
 975       --  to have at least Stack_Size bytes available for
 976       --  actual use.
 977
 978       use System.Task_Info;
 979    begin
 980       if Stack_Size = System.Parameters.Unspecified_Size then
 981          Adjusted_Stack_Size :=
 982            Interfaces.C.size_t (Default_Stack_Size + Page_Size);
 983
 984       elsif Stack_Size < Minimum_Stack_Size then
 985          Adjusted_Stack_Size :=
 986            Interfaces.C.size_t (Minimum_Stack_Size + Page_Size);
 987
 988       else
 989          Adjusted_Stack_Size :=
 990            Interfaces.C.size_t (Stack_Size + Page_Size);
 991       end if;
 992
 993       --  Since the initial signal mask of a thread is inherited from the
 994       --  creator, and the Environment task has all its signals masked, we
 995       --  do not need to manipulate caller's signal mask at this point.
 996       --  All tasks in RTS will have All_Tasks_Mask initially.
 997
 998       if T.Common.Task_Info /= null then
 999
1000          if T.Common.Task_Info.New_LWP then
1001             Opts := Opts + THR_NEW_LWP;
1002          end if;
1003
1004          if T.Common.Task_Info.Bound_To_LWP then
1005             Opts := Opts + THR_BOUND;
1006          end if;
1007
1008       else
1009          Opts := THR_DETACHED + THR_BOUND;
1010       end if;
1011
1012       Result := thr_create
1013         (System.Null_Address,
1014          Adjusted_Stack_Size,
1015          Thread_Body_Access (Wrapper),
1016          To_Address (T),
1017          Opts,
1018          T.Common.LL.Thread'Access);
1019
1020       Succeeded := Result = 0;
1021       pragma Assert
1022         (Result = 0
1023           or else Result = ENOMEM
1024           or else Result = EAGAIN);
1025    end Create_Task;
1026
1027    ------------------
1028    -- Finalize_TCB --
1029    ------------------
1030
1031    procedure Finalize_TCB (T : Task_ID) is
1032       Result : Interfaces.C.int;
1033       Tmp    : Task_ID := T;
1034
1035       procedure Free is new
1036         Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
1037
1038    begin
1039       T.Common.LL.Thread := To_thread_t (0);
1040
1041       if not Single_Lock then
1042          Result := mutex_destroy (T.Common.LL.L.L'Access);
1043          pragma Assert (Result = 0);
1044       end if;
1045
1046       Result := cond_destroy (T.Common.LL.CV'Access);
1047       pragma Assert (Result = 0);
1048
1049       if T.Known_Tasks_Index /= -1 then
1050          Known_Tasks (T.Known_Tasks_Index) := null;
1051       end if;
1052
1053       Free (Tmp);
1054    end Finalize_TCB;
1055
1056    ---------------
1057    -- Exit_Task --
1058    ---------------
1059
1060    --  This procedure must be called with abort deferred.
1061    --  It can no longer call Self or access
1062    --  the current task's ATCB, since the ATCB has been deallocated.
1063
1064    procedure Exit_Task is
1065    begin
1066       thr_exit (System.Null_Address);
1067    end Exit_Task;
1068
1069    ----------------
1070    -- Abort_Task --
1071    ----------------
1072
1073    procedure Abort_Task (T : Task_ID) is
1074       Result : Interfaces.C.int;
1075    begin
1076       pragma Assert (T /= Self);
1077
1078       Result := thr_kill (T.Common.LL.Thread,
1079         Signal (System.Interrupt_Management.Abort_Task_Interrupt));
1080       null;
1081
1082       pragma Assert (Result = 0);
1083    end Abort_Task;
1084
1085    -----------
1086    -- Sleep --
1087    -----------
1088
1089    procedure Sleep
1090      (Self_ID : Task_ID;
1091       Reason  : Task_States)
1092    is
1093       Result : Interfaces.C.int;
1094    begin
1095       pragma Assert (Check_Sleep (Reason));
1096
1097       if Dynamic_Priority_Support
1098         and then Self_ID.Pending_Priority_Change
1099       then
1100          Self_ID.Pending_Priority_Change := False;
1101          Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
1102          Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
1103       end if;
1104
1105       if Single_Lock then
1106          Result := cond_wait
1107            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access);
1108       else
1109          Result := cond_wait
1110            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
1111       end if;
1112
1113       pragma Assert (Record_Wakeup
1114         (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
1115       pragma Assert (Result = 0 or else Result = EINTR);
1116    end Sleep;
1117
1118    --  Note that we are relying heaviliy here on the GNAT feature
1119    --  that Calendar.Time, System.Real_Time.Time, Duration, and
1120    --  System.Real_Time.Time_Span are all represented in the same
1121    --  way, i.e., as a 64-bit count of nanoseconds.
1122
1123    --  This allows us to always pass the timeout value as a Duration.
1124
1125    --  ???
1126    --  We are taking liberties here with the semantics of the delays.
1127    --  That is, we make no distinction between delays on the Calendar clock
1128    --  and delays on the Real_Time clock. That is technically incorrect, if
1129    --  the Calendar clock happens to be reset or adjusted.
1130    --  To solve this defect will require modification to the compiler
1131    --  interface, so that it can pass through more information, to tell
1132    --  us here which clock to use!
1133
1134    --  cond_timedwait will return if any of the following happens:
1135    --  1) some other task did cond_signal on this condition variable
1136    --     In this case, the return value is 0
1137    --  2) the call just returned, for no good reason
1138    --     This is called a "spurious wakeup".
1139    --     In this case, the return value may also be 0.
1140    --  3) the time delay expires
1141    --     In this case, the return value is ETIME
1142    --  4) this task received a signal, which was handled by some
1143    --     handler procedure, and now the thread is resuming execution
1144    --     UNIX calls this an "interrupted" system call.
1145    --     In this case, the return value is EINTR
1146
1147    --  If the cond_timedwait returns 0 or EINTR, it is still
1148    --  possible that the time has actually expired, and by chance
1149    --  a signal or cond_signal occurred at around the same time.
1150
1151    --  We have also observed that on some OS's the value ETIME
1152    --  will be returned, but the clock will show that the full delay
1153    --  has not yet expired.
1154
1155    --  For these reasons, we need to check the clock after return
1156    --  from cond_timedwait.  If the time has expired, we will set
1157    --  Timedout = True.
1158
1159    --  This check might be omitted for systems on which the
1160    --  cond_timedwait() never returns early or wakes up spuriously.
1161
1162    --  Annex D requires that completion of a delay cause the task
1163    --  to go to the end of its priority queue, regardless of whether
1164    --  the task actually was suspended by the delay. Since
1165    --  cond_timedwait does not do this on Solaris, we add a call
1166    --  to thr_yield at the end. We might do this at the beginning,
1167    --  instead, but then the round-robin effect would not be the
1168    --  same; the delayed task would be ahead of other tasks of the
1169    --  same priority that awoke while it was sleeping.
1170
1171    --  For Timed_Sleep, we are expecting possible cond_signals
1172    --  to indicate other events (e.g., completion of a RV or
1173    --  completion of the abortable part of an async. select),
1174    --  we want to always return if interrupted. The caller will
1175    --  be responsible for checking the task state to see whether
1176    --  the wakeup was spurious, and to go back to sleep again
1177    --  in that case.  We don't need to check for pending abort
1178    --  or priority change on the way in our out; that is the
1179    --  caller's responsibility.
1180
1181    --  For Timed_Delay, we are not expecting any cond_signals or
1182    --  other interruptions, except for priority changes and aborts.
1183    --  Therefore, we don't want to return unless the delay has
1184    --  actually expired, or the call has been aborted. In this
1185    --  case, since we want to implement the entire delay statement
1186    --  semantics, we do need to check for pending abort and priority
1187    --  changes. We can quietly handle priority changes inside the
1188    --  procedure, since there is no entry-queue reordering involved.
1189
1190    -----------------
1191    -- Timed_Sleep --
1192    -----------------
1193
1194    procedure Timed_Sleep
1195      (Self_ID  : Task_ID;
1196       Time     : Duration;
1197       Mode     : ST.Delay_Modes;
1198       Reason   : System.Tasking.Task_States;
1199       Timedout : out Boolean;
1200       Yielded  : out Boolean)
1201    is
1202       Check_Time : constant Duration := Monotonic_Clock;
1203       Abs_Time   : Duration;
1204       Request    : aliased timespec;
1205       Result     : Interfaces.C.int;
1206
1207    begin
1208       pragma Assert (Check_Sleep (Reason));
1209       Timedout := True;
1210       Yielded := False;
1211
1212       if Mode = Relative then
1213          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
1214       else
1215          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
1216       end if;
1217
1218       if Abs_Time > Check_Time then
1219          Request := To_Timespec (Abs_Time);
1220
1221          loop
1222             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
1223               or else (Dynamic_Priority_Support and then
1224                 Self_ID.Pending_Priority_Change);
1225
1226             if Single_Lock then
1227                Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
1228                  Single_RTS_Lock.L'Access, Request'Access);
1229             else
1230                Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
1231                  Self_ID.Common.LL.L.L'Access, Request'Access);
1232             end if;
1233
1234             Yielded := True;
1235
1236             exit when Abs_Time <= Monotonic_Clock;
1237
1238             if Result = 0 or Result = EINTR then
1239                --  somebody may have called Wakeup for us
1240                Timedout := False;
1241                exit;
1242             end if;
1243
1244             pragma Assert (Result = ETIME);
1245          end loop;
1246       end if;
1247
1248       pragma Assert (Record_Wakeup
1249         (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
1250    end Timed_Sleep;
1251
1252    -----------------
1253    -- Timed_Delay --
1254    -----------------
1255
1256    procedure Timed_Delay
1257      (Self_ID  : Task_ID;
1258       Time     : Duration;
1259       Mode     : ST.Delay_Modes)
1260    is
1261       Check_Time : constant Duration := Monotonic_Clock;
1262       Abs_Time   : Duration;
1263       Request    : aliased timespec;
1264       Result     : Interfaces.C.int;
1265       Yielded    : Boolean := False;
1266
1267    begin
1268       --  Only the little window between deferring abort and
1269       --  locking Self_ID is the reason we need to
1270       --  check for pending abort and priority change below!
1271
1272       SSL.Abort_Defer.all;
1273
1274       if Single_Lock then
1275          Lock_RTS;
1276       end if;
1277
1278       Write_Lock (Self_ID);
1279
1280       if Mode = Relative then
1281          Abs_Time := Time + Check_Time;
1282       else
1283          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
1284       end if;
1285
1286       if Abs_Time > Check_Time then
1287          Request := To_Timespec (Abs_Time);
1288          Self_ID.Common.State := Delay_Sleep;
1289
1290          pragma Assert (Check_Sleep (Delay_Sleep));
1291
1292          loop
1293             if Dynamic_Priority_Support and then
1294               Self_ID.Pending_Priority_Change then
1295                Self_ID.Pending_Priority_Change := False;
1296                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
1297                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
1298             end if;
1299
1300             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
1301
1302             if Single_Lock then
1303                Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
1304                  Single_RTS_Lock.L'Access, Request'Access);
1305             else
1306                Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
1307                  Self_ID.Common.LL.L.L'Access, Request'Access);
1308             end if;
1309
1310             Yielded := True;
1311
1312             exit when Abs_Time <= Monotonic_Clock;
1313
1314             pragma Assert (Result = 0 or else
1315               Result = ETIME or else
1316               Result = EINTR);
1317          end loop;
1318
1319          pragma Assert (Record_Wakeup
1320            (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
1321
1322          Self_ID.Common.State := Runnable;
1323       end if;
1324
1325       Unlock (Self_ID);
1326
1327       if Single_Lock then
1328          Unlock_RTS;
1329       end if;
1330
1331       if not Yielded then
1332          thr_yield;
1333       end if;
1334
1335       SSL.Abort_Undefer.all;
1336    end Timed_Delay;
1337
1338    ------------
1339    -- Wakeup --
1340    ------------
1341
1342    procedure Wakeup
1343      (T : Task_ID;
1344       Reason : Task_States)
1345    is
1346       Result : Interfaces.C.int;
1347    begin
1348       pragma Assert (Check_Wakeup (T, Reason));
1349       Result := cond_signal (T.Common.LL.CV'Access);
1350       pragma Assert (Result = 0);
1351    end Wakeup;
1352
1353    ---------------------------
1354    -- Check_Initialize_Lock --
1355    ---------------------------
1356
1357    --  The following code is intended to check some of the invariant
1358    --  assertions related to lock usage, on which we depend.
1359
1360    function Check_Initialize_Lock
1361      (L     : Lock_Ptr;
1362       Level : Lock_Level)
1363       return  Boolean
1364    is
1365       Self_ID : constant Task_ID := Self;
1366
1367    begin
1368       --  Check that caller is abort-deferred
1369
1370       if Self_ID.Deferral_Level <= 0 then
1371          return False;
1372       end if;
1373
1374       --  Check that the lock is not yet initialized
1375
1376       if L.Level /= 0 then
1377          return False;
1378       end if;
1379
1380       L.Level := Lock_Level'Pos (Level) + 1;
1381       return True;
1382    end Check_Initialize_Lock;
1383
1384    ----------------
1385    -- Check_Lock --
1386    ----------------
1387
1388    function Check_Lock (L : Lock_Ptr) return Boolean is
1389       Self_ID : Task_ID := Self;
1390       P       : Lock_Ptr;
1391
1392    begin
1393       --  Check that the argument is not null
1394
1395       if L = null then
1396          return False;
1397       end if;
1398
1399       --  Check that L is not frozen
1400
1401       if L.Frozen then
1402          return False;
1403       end if;
1404
1405       --  Check that caller is abort-deferred
1406
1407       if Self_ID.Deferral_Level <= 0 then
1408          return False;
1409       end if;
1410
1411       --  Check that caller is not holding this lock already
1412
1413       if L.Owner = To_Owner_ID (Self_ID) then
1414          return False;
1415       end if;
1416
1417       if Single_Lock then
1418          return True;
1419       end if;
1420
1421       --  Check that TCB lock order rules are satisfied
1422
1423       P := Self_ID.Common.LL.Locks;
1424       if P /= null then
1425          if P.Level >= L.Level
1426            and then (P.Level > 2 or else L.Level > 2)
1427          then
1428             return False;
1429          end if;
1430       end if;
1431
1432       return True;
1433    end Check_Lock;
1434
1435    -----------------
1436    -- Record_Lock --
1437    -----------------
1438
1439    function Record_Lock (L : Lock_Ptr) return Boolean is
1440       Self_ID : Task_ID := Self;
1441       P       : Lock_Ptr;
1442
1443    begin
1444       Lock_Count := Lock_Count + 1;
1445
1446       --  There should be no owner for this lock at this point
1447
1448       if L.Owner /= null then
1449          return False;
1450       end if;
1451
1452       --  Record new owner
1453
1454       L.Owner := To_Owner_ID (Self_ID);
1455
1456       if Single_Lock then
1457          return True;
1458       end if;
1459
1460       --  Check that TCB lock order rules are satisfied
1461
1462       P := Self_ID.Common.LL.Locks;
1463
1464       if P /= null then
1465          L.Next := P;
1466       end if;
1467
1468       Self_ID.Common.LL.Locking := null;
1469       Self_ID.Common.LL.Locks := L;
1470       return True;
1471    end Record_Lock;
1472
1473    -----------------
1474    -- Check_Sleep --
1475    -----------------
1476
1477    function Check_Sleep (Reason : Task_States) return Boolean is
1478       Self_ID : Task_ID := Self;
1479       P       : Lock_Ptr;
1480
1481    begin
1482       --  Check that caller is abort-deferred
1483
1484       if Self_ID.Deferral_Level <= 0 then
1485          return False;
1486       end if;
1487
1488       if Single_Lock then
1489          return True;
1490       end if;
1491
1492       --  Check that caller is holding own lock, on top of list
1493
1494       if Self_ID.Common.LL.Locks /=
1495         To_Lock_Ptr (Self_ID.Common.LL.L'Access)
1496       then
1497          return False;
1498       end if;
1499
1500       --  Check that TCB lock order rules are satisfied
1501
1502       if Self_ID.Common.LL.Locks.Next /= null then
1503          return False;
1504       end if;
1505
1506       Self_ID.Common.LL.L.Owner := null;
1507       P := Self_ID.Common.LL.Locks;
1508       Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
1509       P.Next := null;
1510       return True;
1511    end Check_Sleep;
1512
1513    -------------------
1514    -- Record_Wakeup --
1515    -------------------
1516
1517    function Record_Wakeup
1518      (L      : Lock_Ptr;
1519       Reason : Task_States)
1520       return   Boolean
1521    is
1522       Self_ID : Task_ID := Self;
1523       P       : Lock_Ptr;
1524
1525    begin
1526       --  Record new owner
1527
1528       L.Owner := To_Owner_ID (Self_ID);
1529
1530       if Single_Lock then
1531          return True;
1532       end if;
1533
1534       --  Check that TCB lock order rules are satisfied
1535
1536       P := Self_ID.Common.LL.Locks;
1537
1538       if P /= null then
1539          L.Next := P;
1540       end if;
1541
1542       Self_ID.Common.LL.Locking := null;
1543       Self_ID.Common.LL.Locks := L;
1544       return True;
1545    end Record_Wakeup;
1546
1547    ------------------
1548    -- Check_Wakeup --
1549    ------------------
1550
1551    function Check_Wakeup
1552      (T      : Task_ID;
1553       Reason : Task_States)
1554       return   Boolean
1555    is
1556       Self_ID : Task_ID := Self;
1557
1558    begin
1559       --  Is caller holding T's lock?
1560
1561       if T.Common.LL.L.Owner /= To_Owner_ID (Self_ID) then
1562          return False;
1563       end if;
1564
1565       --  Are reasons for wakeup and sleep consistent?
1566
1567       if T.Common.State /= Reason then
1568          return False;
1569       end if;
1570
1571       return True;
1572    end Check_Wakeup;
1573
1574    ------------------
1575    -- Check_Unlock --
1576    ------------------
1577
1578    function Check_Unlock (L : Lock_Ptr) return Boolean is
1579       Self_ID : Task_ID := Self;
1580       P       : Lock_Ptr;
1581
1582    begin
1583       Unlock_Count := Unlock_Count + 1;
1584
1585       if L = null then
1586          return False;
1587       end if;
1588
1589       if L.Buddy /= null then
1590          return False;
1591       end if;
1592
1593       if L.Level = 4 then
1594          Check_Count := Unlock_Count;
1595       end if;
1596
1597       if Unlock_Count - Check_Count > 1000 then
1598          Check_Count := Unlock_Count;
1599          Old_Owner   := To_Task_ID (Single_RTS_Lock.Owner);
1600       end if;
1601
1602       --  Check that caller is abort-deferred
1603
1604       if Self_ID.Deferral_Level <= 0 then
1605          return False;
1606       end if;
1607
1608       --  Check that caller is holding this lock, on top of list
1609
1610       if Self_ID.Common.LL.Locks /= L then
1611          return False;
1612       end if;
1613
1614       --  Record there is no owner now
1615
1616       L.Owner := null;
1617       P := Self_ID.Common.LL.Locks;
1618       Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
1619       P.Next := null;
1620       return True;
1621    end Check_Unlock;
1622
1623    --------------------
1624    -- Check_Finalize --
1625    --------------------
1626
1627    function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
1628       Self_ID : Task_ID := Self;
1629    begin
1630       --  Check that caller is abort-deferred
1631
1632       if Self_ID.Deferral_Level <= 0 then
1633          return False;
1634       end if;
1635
1636       --  Check that no one is holding this lock
1637
1638       if L.Owner /= null then
1639          return False;
1640       end if;
1641
1642       L.Frozen := True;
1643       return True;
1644    end Check_Finalize_Lock;
1645
1646    ----------------
1647    -- Check_Exit --
1648    ----------------
1649
1650    function Check_Exit (Self_ID : Task_ID) return Boolean is
1651    begin
1652       --  Check that caller is just holding Global_Task_Lock
1653       --  and no other locks
1654
1655       if Self_ID.Common.LL.Locks = null then
1656          return False;
1657       end if;
1658
1659       --  2 = Global_Task_Level
1660
1661       if Self_ID.Common.LL.Locks.Level /= 2 then
1662          return False;
1663       end if;
1664
1665       if Self_ID.Common.LL.Locks.Next /= null then
1666          return False;
1667       end if;
1668
1669       --  Check that caller is abort-deferred
1670
1671       if Self_ID.Deferral_Level <= 0 then
1672          return False;
1673       end if;
1674
1675       return True;
1676    end Check_Exit;
1677
1678    --------------------
1679    -- Check_No_Locks --
1680    --------------------
1681
1682    function Check_No_Locks (Self_ID : Task_ID) return Boolean is
1683    begin
1684       return Self_ID.Common.LL.Locks = null;
1685    end Check_No_Locks;
1686
1687    ----------------------
1688    -- Environment_Task --
1689    ----------------------
1690
1691    function Environment_Task return Task_ID is
1692    begin
1693       return Environment_Task_ID;
1694    end Environment_Task;
1695
1696    --------------
1697    -- Lock_RTS --
1698    --------------
1699
1700    procedure Lock_RTS is
1701    begin
1702       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1703    end Lock_RTS;
1704
1705    ----------------
1706    -- Unlock_RTS --
1707    ----------------
1708
1709    procedure Unlock_RTS is
1710    begin
1711       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1712    end Unlock_RTS;
1713
1714    ------------------
1715    -- Suspend_Task --
1716    ------------------
1717
1718    function Suspend_Task
1719      (T           : ST.Task_ID;
1720       Thread_Self : Thread_Id) return Boolean is
1721    begin
1722       if T.Common.LL.Thread /= Thread_Self then
1723          return thr_suspend (T.Common.LL.Thread) = 0;
1724       else
1725          return True;
1726       end if;
1727    end Suspend_Task;
1728
1729    -----------------
1730    -- Resume_Task --
1731    -----------------
1732
1733    function Resume_Task
1734      (T           : ST.Task_ID;
1735       Thread_Self : Thread_Id) return Boolean is
1736    begin
1737       if T.Common.LL.Thread /= Thread_Self then
1738          return thr_continue (T.Common.LL.Thread) = 0;
1739       else
1740          return True;
1741       end if;
1742    end Resume_Task;
1743
1744    ----------------
1745    -- Initialize --
1746    ----------------
1747
1748    procedure Initialize (Environment_Task : ST.Task_ID) is
1749       act     : aliased struct_sigaction;
1750       old_act : aliased struct_sigaction;
1751       Tmp_Set : aliased sigset_t;
1752       Result  : Interfaces.C.int;
1753
1754       procedure Configure_Processors;
1755       --  Processors configuration
1756       --  The user can specify a processor which the program should run
1757       --  on to emulate a single-processor system. This can be easily
1758       --  done by setting environment variable GNAT_PROCESSOR to one of
1759       --  the following :
1760       --
1761       --    -2 : use the default configuration (run the program on all
1762       --         available processors) - this is the same as having
1763       --         GNAT_PROCESSOR unset
1764       --    -1 : let the RTS choose one processor and run the program on
1765       --         that processor
1766       --    0 .. Last_Proc : run the program on the specified processor
1767       --
1768       --  Last_Proc is equal to the value of the system variable
1769       --  _SC_NPROCESSORS_CONF, minus one.
1770
1771       procedure Configure_Processors is
1772          Proc_Acc  : constant GNAT.OS_Lib.String_Access :=
1773            GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR");
1774          Proc      : aliased processorid_t;  --  User processor #
1775          Last_Proc : processorid_t;          --  Last processor #
1776
1777       begin
1778          if Proc_Acc.all'Length /= 0 then
1779             --  Environment variable is defined
1780
1781             Last_Proc := Num_Procs - 1;
1782
1783             if Last_Proc /= -1 then
1784                Proc := processorid_t'Value (Proc_Acc.all);
1785
1786                if Proc <= -2  or else Proc > Last_Proc then
1787                   --  Use the default configuration
1788                   null;
1789                elsif Proc = -1 then
1790                   --  Choose a processor
1791
1792                   Result := 0;
1793
1794                   while Proc < Last_Proc loop
1795                      Proc := Proc + 1;
1796                      Result := p_online (Proc, PR_STATUS);
1797                      exit when Result = PR_ONLINE;
1798                   end loop;
1799
1800                   pragma Assert (Result = PR_ONLINE);
1801                   Result := processor_bind (P_PID, P_MYID, Proc, null);
1802                   pragma Assert (Result = 0);
1803
1804                else
1805                   --  Use user processor
1806
1807                   Result := processor_bind (P_PID, P_MYID, Proc, null);
1808                   pragma Assert (Result = 0);
1809                end if;
1810             end if;
1811          end if;
1812
1813       exception
1814          when Constraint_Error =>
1815             --  Illegal environment variable GNAT_PROCESSOR - ignored
1816             null;
1817       end Configure_Processors;
1818
1819    --  Start of processing for Initialize
1820
1821    begin
1822       Environment_Task_ID := Environment_Task;
1823
1824       --  This is done in Enter_Task, but this is too late for the
1825       --  Environment Task, since we need to call Self in Check_Locks when
1826       --  the run time is compiled with assertions on.
1827
1828       Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task));
1829       pragma Assert (Result = 0);
1830
1831       --  Initialize the lock used to synchronize chain of all ATCBs.
1832
1833       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1834
1835       Enter_Task (Environment_Task);
1836
1837       --  Install the abort-signal handler
1838
1839       --  Set sa_flags to SA_NODEFER so that during the handler execution
1840       --  we do not change the Signal_Mask to be masked for the Abort_Signal.
1841       --  This is a temporary fix to the problem that the Signal_Mask is
1842       --  not restored after the exception (longjmp) from the handler.
1843       --  The right fix should be made in sigsetjmp so that we save
1844       --  the Signal_Set and restore it after a longjmp.
1845       --  In that case, this field should be changed back to 0. ???
1846
1847       act.sa_flags := 16;
1848
1849       act.sa_handler := Abort_Handler'Address;
1850       Result := sigemptyset (Tmp_Set'Access);
1851       pragma Assert (Result = 0);
1852       act.sa_mask := Tmp_Set;
1853
1854       Result :=
1855         sigaction (
1856           Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1857           act'Unchecked_Access,
1858           old_act'Unchecked_Access);
1859       pragma Assert (Result = 0);
1860
1861       Configure_Processors;
1862
1863       --  Create a free ATCB for use on the Fake_ATCB_List.
1864
1865       Next_Fake_ATCB := new Fake_ATCB;
1866    end Initialize;
1867
1868 --  Package elaboration
1869
1870 begin
1871    declare
1872       Result : Interfaces.C.int;
1873    begin
1874       --  Mask Environment task for all signals. The original mask of the
1875       --  Environment task will be recovered by Interrupt_Server task
1876       --  during the elaboration of s-interr.adb.
1877
1878       System.Interrupt_Management.Operations.Set_Interrupt_Mask
1879         (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
1880
1881       --  Prepare the set of signals that should unblocked in all tasks
1882
1883       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1884       pragma Assert (Result = 0);
1885
1886       for J in Interrupt_Management.Interrupt_ID loop
1887          if System.Interrupt_Management.Keep_Unmasked (J) then
1888             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1889             pragma Assert (Result = 0);
1890          end if;
1891       end loop;
1892
1893       --  We need the following code to support automatic creation of fake
1894       --  ATCB's for C threads that call the Ada run-time system, even if
1895       --  we use a faster way of getting Self for real Ada tasks.
1896
1897       Result := thr_keycreate (ATCB_Key'Access, System.Null_Address);
1898       pragma Assert (Result = 0);
1899    end;
1900
1901    if Dispatching_Policy = 'F' then
1902       declare
1903          Result      : Interfaces.C.long;
1904          Class_Info  : aliased struct_pcinfo;
1905          Secs, Nsecs : Interfaces.C.long;
1906
1907       begin
1908          --  If a pragma Time_Slice is specified, takes the value in account.
1909
1910          if Time_Slice_Val > 0 then
1911             --  Convert Time_Slice_Val (microseconds) into seconds and
1912             --  nanoseconds
1913
1914             Secs := Time_Slice_Val / 1_000_000;
1915             Nsecs := (Time_Slice_Val rem 1_000_000) * 1_000;
1916
1917          --  Otherwise, default to no time slicing (i.e run until blocked)
1918
1919          else
1920             Secs := RT_TQINF;
1921             Nsecs := RT_TQINF;
1922          end if;
1923
1924          --  Get the real time class id.
1925
1926          Class_Info.pc_clname (1) := 'R';
1927          Class_Info.pc_clname (2) := 'T';
1928          Class_Info.pc_clname (3) := ASCII.NUL;
1929
1930          Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
1931            Class_Info'Address);
1932
1933          --  Request the real time class
1934
1935          Prio_Param.pc_cid := Class_Info.pc_cid;
1936          Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri);
1937          Prio_Param.rt_tqsecs := Secs;
1938          Prio_Param.rt_tqnsecs := Nsecs;
1939
1940          Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS,
1941            Prio_Param'Address);
1942
1943          Using_Real_Time_Class := Result /= -1;
1944       end;
1945    end if;
1946 end System.Task_Primitives.Operations;