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