File : s-taprop-solaris.adb


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