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 LWPs 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    --  privileges, 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 whether the real time class is being used (i.e. the process
 119    --  has root privileges).
 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 raising 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 heavily here on GNAT representing
1143    --  Calendar.Time, System.Real_Time.Time, Duration,
1144    --  System.Real_Time.Time_Span in the same way, i.e., as a 64-bit count of
1145    --  nanoseconds.
1146
1147    --  This allows us to always pass the timeout value as a Duration.
1148
1149    --  ???
1150    --  We are taking liberties here with the semantics of the delays. That is,
1151    --  we make no distinction between delays on the Calendar clock and delays
1152    --  on the Real_Time clock. That is technically incorrect, if the Calendar
1153    --  clock happens to be reset or adjusted. To solve this defect will require
1154    --  modification to the compiler interface, so that it can pass through more
1155    --  information, to tell us here which clock to use!
1156
1157    --  cond_timedwait will return if any of the following happens:
1158    --  1) some other task did cond_signal on this condition variable
1159    --     In this case, the return value is 0
1160    --  2) the call just returned, for no good reason
1161    --     This is called a "spurious wakeup".
1162    --     In this case, the return value may also be 0.
1163    --  3) the time delay expires
1164    --     In this case, the return value is ETIME
1165    --  4) this task received a signal, which was handled by some
1166    --     handler procedure, and now the thread is resuming execution
1167    --     UNIX calls this an "interrupted" system call.
1168    --     In this case, the return value is EINTR
1169
1170    --  If the cond_timedwait returns 0 or EINTR, it is still possible that the
1171    --  time has actually expired, and by chance a signal or cond_signal
1172    --  occurred at around the same time.
1173
1174    --  We have also observed that on some OS's the value ETIME will be
1175    --  returned, but the clock will show that the full delay has not yet
1176    --  expired.
1177
1178    --  For these reasons, we need to check the clock after return from
1179    --  cond_timedwait. If the time has expired, we will set Timedout = True.
1180
1181    --  This check might be omitted for systems on which the cond_timedwait()
1182    --  never returns early or wakes up spuriously.
1183
1184    --  Annex D requires that completion of a delay cause the task to go to the
1185    --  end of its priority queue, regardless of whether the task actually was
1186    --  suspended by the delay. Since cond_timedwait does not do this on
1187    --  Solaris, we add a call to thr_yield at the end. We might do this at the
1188    --  beginning, instead, but then the round-robin effect would not be the
1189    --  same; the delayed task would be ahead of other tasks of the same
1190    --  priority that awoke while it was sleeping.
1191
1192    --  For Timed_Sleep, we are expecting possible cond_signals to indicate
1193    --  other events (e.g., completion of a RV or completion of the abortable
1194    --  part of an async. select), we want to always return if interrupted. The
1195    --  caller will be responsible for checking the task state to see whether
1196    --  the wakeup was spurious, and to go back to sleep again in that case. We
1197    --  don't need to check for pending abort or priority change on the way in
1198    --  our out; that is the caller's responsibility.
1199
1200    --  For Timed_Delay, we are not expecting any cond_signals or other
1201    --  interruptions, except for priority changes and aborts. Therefore, we
1202    --  don't want to return unless the delay has actually expired, or the call
1203    --  has been aborted. In this case, since we want to implement the entire
1204    --  delay statement semantics, we do need to check for pending abort and
1205    --  priority changes. We can quietly handle priority changes inside the
1206    --  procedure, since there is no entry-queue reordering involved.
1207
1208    -----------------
1209    -- Timed_Sleep --
1210    -----------------
1211
1212    procedure Timed_Sleep
1213      (Self_ID  : Task_Id;
1214       Time     : Duration;
1215       Mode     : ST.Delay_Modes;
1216       Reason   : System.Tasking.Task_States;
1217       Timedout : out Boolean;
1218       Yielded  : out Boolean)
1219    is
1220       Base_Time  : constant Duration := Monotonic_Clock;
1221       Check_Time : Duration := Base_Time;
1222       Abs_Time   : Duration;
1223       Request    : aliased timespec;
1224       Result     : Interfaces.C.int;
1225
1226    begin
1227       pragma Assert (Check_Sleep (Reason));
1228       Timedout := True;
1229       Yielded := False;
1230
1231       if Mode = Relative then
1232          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
1233       else
1234          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
1235       end if;
1236
1237       if Abs_Time > Check_Time then
1238          Request := To_Timespec (Abs_Time);
1239
1240          loop
1241             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
1242
1243             if Single_Lock then
1244                Result :=
1245                  cond_timedwait
1246                    (Self_ID.Common.LL.CV'Access,
1247                     Single_RTS_Lock.L'Access, Request'Access);
1248             else
1249                Result :=
1250                  cond_timedwait
1251                    (Self_ID.Common.LL.CV'Access,
1252                     Self_ID.Common.LL.L.L'Access, Request'Access);
1253             end if;
1254
1255             Yielded := True;
1256
1257             Check_Time := Monotonic_Clock;
1258             exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
1259
1260             if Result = 0 or Result = EINTR then
1261
1262                --  Somebody may have called Wakeup for us
1263
1264                Timedout := False;
1265                exit;
1266             end if;
1267
1268             pragma Assert (Result = ETIME);
1269          end loop;
1270       end if;
1271
1272       pragma Assert
1273         (Record_Wakeup (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason));
1274    end Timed_Sleep;
1275
1276    -----------------
1277    -- Timed_Delay --
1278    -----------------
1279
1280    procedure Timed_Delay
1281      (Self_ID : Task_Id;
1282       Time    : Duration;
1283       Mode    : ST.Delay_Modes)
1284    is
1285       Base_Time  : constant Duration := Monotonic_Clock;
1286       Check_Time : Duration := Base_Time;
1287       Abs_Time   : Duration;
1288       Request    : aliased timespec;
1289       Result     : Interfaces.C.int;
1290       Yielded    : Boolean := False;
1291
1292    begin
1293       if Single_Lock then
1294          Lock_RTS;
1295       end if;
1296
1297       Write_Lock (Self_ID);
1298
1299       if Mode = Relative then
1300          Abs_Time := Time + Check_Time;
1301       else
1302          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
1303       end if;
1304
1305       if Abs_Time > Check_Time then
1306          Request := To_Timespec (Abs_Time);
1307          Self_ID.Common.State := Delay_Sleep;
1308
1309          pragma Assert (Check_Sleep (Delay_Sleep));
1310
1311          loop
1312             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
1313
1314             if Single_Lock then
1315                Result :=
1316                  cond_timedwait
1317                    (Self_ID.Common.LL.CV'Access,
1318                     Single_RTS_Lock.L'Access,
1319                     Request'Access);
1320             else
1321                Result :=
1322                  cond_timedwait
1323                    (Self_ID.Common.LL.CV'Access,
1324                     Self_ID.Common.LL.L.L'Access,
1325                     Request'Access);
1326             end if;
1327
1328             Yielded := True;
1329
1330             Check_Time := Monotonic_Clock;
1331             exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
1332
1333             pragma Assert
1334               (Result = 0     or else
1335                Result = ETIME or else
1336                Result = EINTR);
1337          end loop;
1338
1339          pragma Assert
1340            (Record_Wakeup
1341               (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep));
1342
1343          Self_ID.Common.State := Runnable;
1344       end if;
1345
1346       Unlock (Self_ID);
1347
1348       if Single_Lock then
1349          Unlock_RTS;
1350       end if;
1351
1352       if not Yielded then
1353          thr_yield;
1354       end if;
1355    end Timed_Delay;
1356
1357    ------------
1358    -- Wakeup --
1359    ------------
1360
1361    procedure Wakeup
1362      (T : Task_Id;
1363       Reason : Task_States)
1364    is
1365       Result : Interfaces.C.int;
1366    begin
1367       pragma Assert (Check_Wakeup (T, Reason));
1368       Result := cond_signal (T.Common.LL.CV'Access);
1369       pragma Assert (Result = 0);
1370    end Wakeup;
1371
1372    ---------------------------
1373    -- Check_Initialize_Lock --
1374    ---------------------------
1375
1376    --  The following code is intended to check some of the invariant assertions
1377    --  related to lock usage, on which we depend.
1378
1379    function Check_Initialize_Lock
1380      (L     : Lock_Ptr;
1381       Level : Lock_Level) return Boolean
1382    is
1383       Self_ID : constant Task_Id := Self;
1384
1385    begin
1386       --  Check that caller is abort-deferred
1387
1388       if Self_ID.Deferral_Level = 0 then
1389          return False;
1390       end if;
1391
1392       --  Check that the lock is not yet initialized
1393
1394       if L.Level /= 0 then
1395          return False;
1396       end if;
1397
1398       L.Level := Lock_Level'Pos (Level) + 1;
1399       return True;
1400    end Check_Initialize_Lock;
1401
1402    ----------------
1403    -- Check_Lock --
1404    ----------------
1405
1406    function Check_Lock (L : Lock_Ptr) return Boolean is
1407       Self_ID : constant Task_Id := Self;
1408       P       : Lock_Ptr;
1409
1410    begin
1411       --  Check that the argument is not null
1412
1413       if L = null then
1414          return False;
1415       end if;
1416
1417       --  Check that L is not frozen
1418
1419       if L.Frozen then
1420          return False;
1421       end if;
1422
1423       --  Check that caller is abort-deferred
1424
1425       if Self_ID.Deferral_Level = 0 then
1426          return False;
1427       end if;
1428
1429       --  Check that caller is not holding this lock already
1430
1431       if L.Owner = To_Owner_ID (To_Address (Self_ID)) then
1432          return False;
1433       end if;
1434
1435       if Single_Lock then
1436          return True;
1437       end if;
1438
1439       --  Check that TCB lock order rules are satisfied
1440
1441       P := Self_ID.Common.LL.Locks;
1442       if P /= null then
1443          if P.Level >= L.Level
1444            and then (P.Level > 2 or else L.Level > 2)
1445          then
1446             return False;
1447          end if;
1448       end if;
1449
1450       return True;
1451    end Check_Lock;
1452
1453    -----------------
1454    -- Record_Lock --
1455    -----------------
1456
1457    function Record_Lock (L : Lock_Ptr) return Boolean is
1458       Self_ID : constant Task_Id := Self;
1459       P       : Lock_Ptr;
1460
1461    begin
1462       Lock_Count := Lock_Count + 1;
1463
1464       --  There should be no owner for this lock at this point
1465
1466       if L.Owner /= null then
1467          return False;
1468       end if;
1469
1470       --  Record new owner
1471
1472       L.Owner := To_Owner_ID (To_Address (Self_ID));
1473
1474       if Single_Lock then
1475          return True;
1476       end if;
1477
1478       --  Check that TCB lock order rules are satisfied
1479
1480       P := Self_ID.Common.LL.Locks;
1481
1482       if P /= null then
1483          L.Next := P;
1484       end if;
1485
1486       Self_ID.Common.LL.Locking := null;
1487       Self_ID.Common.LL.Locks := L;
1488       return True;
1489    end Record_Lock;
1490
1491    -----------------
1492    -- Check_Sleep --
1493    -----------------
1494
1495    function Check_Sleep (Reason : Task_States) return Boolean is
1496       pragma Unreferenced (Reason);
1497
1498       Self_ID : constant Task_Id := Self;
1499       P       : Lock_Ptr;
1500
1501    begin
1502       --  Check that caller is abort-deferred
1503
1504       if Self_ID.Deferral_Level = 0 then
1505          return False;
1506       end if;
1507
1508       if Single_Lock then
1509          return True;
1510       end if;
1511
1512       --  Check that caller is holding own lock, on top of list
1513
1514       if Self_ID.Common.LL.Locks /=
1515         To_Lock_Ptr (Self_ID.Common.LL.L'Access)
1516       then
1517          return False;
1518       end if;
1519
1520       --  Check that TCB lock order rules are satisfied
1521
1522       if Self_ID.Common.LL.Locks.Next /= null then
1523          return False;
1524       end if;
1525
1526       Self_ID.Common.LL.L.Owner := null;
1527       P := Self_ID.Common.LL.Locks;
1528       Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
1529       P.Next := null;
1530       return True;
1531    end Check_Sleep;
1532
1533    -------------------
1534    -- Record_Wakeup --
1535    -------------------
1536
1537    function Record_Wakeup
1538      (L      : Lock_Ptr;
1539       Reason : Task_States) return Boolean
1540    is
1541       pragma Unreferenced (Reason);
1542
1543       Self_ID : constant Task_Id := Self;
1544       P       : Lock_Ptr;
1545
1546    begin
1547       --  Record new owner
1548
1549       L.Owner := To_Owner_ID (To_Address (Self_ID));
1550
1551       if Single_Lock then
1552          return True;
1553       end if;
1554
1555       --  Check that TCB lock order rules are satisfied
1556
1557       P := Self_ID.Common.LL.Locks;
1558
1559       if P /= null then
1560          L.Next := P;
1561       end if;
1562
1563       Self_ID.Common.LL.Locking := null;
1564       Self_ID.Common.LL.Locks := L;
1565       return True;
1566    end Record_Wakeup;
1567
1568    ------------------
1569    -- Check_Wakeup --
1570    ------------------
1571
1572    function Check_Wakeup
1573      (T      : Task_Id;
1574       Reason : Task_States) return Boolean
1575    is
1576       Self_ID : constant Task_Id := Self;
1577
1578    begin
1579       --  Is caller holding T's lock?
1580
1581       if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then
1582          return False;
1583       end if;
1584
1585       --  Are reasons for wakeup and sleep consistent?
1586
1587       if T.Common.State /= Reason then
1588          return False;
1589       end if;
1590
1591       return True;
1592    end Check_Wakeup;
1593
1594    ------------------
1595    -- Check_Unlock --
1596    ------------------
1597
1598    function Check_Unlock (L : Lock_Ptr) return Boolean is
1599       Self_ID : constant Task_Id := Self;
1600       P       : Lock_Ptr;
1601
1602    begin
1603       Unlock_Count := Unlock_Count + 1;
1604
1605       if L = null then
1606          return False;
1607       end if;
1608
1609       if L.Buddy /= null then
1610          return False;
1611       end if;
1612
1613       --  Magic constant 4???
1614
1615       if L.Level = 4 then
1616          Check_Count := Unlock_Count;
1617       end if;
1618
1619       --  Magic constant 1000???
1620
1621       if Unlock_Count - Check_Count > 1000 then
1622          Check_Count := Unlock_Count;
1623       end if;
1624
1625       --  Check that caller is abort-deferred
1626
1627       if Self_ID.Deferral_Level = 0 then
1628          return False;
1629       end if;
1630
1631       --  Check that caller is holding this lock, on top of list
1632
1633       if Self_ID.Common.LL.Locks /= L then
1634          return False;
1635       end if;
1636
1637       --  Record there is no owner now
1638
1639       L.Owner := null;
1640       P := Self_ID.Common.LL.Locks;
1641       Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next;
1642       P.Next := null;
1643       return True;
1644    end Check_Unlock;
1645
1646    --------------------
1647    -- Check_Finalize --
1648    --------------------
1649
1650    function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
1651       Self_ID : constant Task_Id := Self;
1652
1653    begin
1654       --  Check that caller is abort-deferred
1655
1656       if Self_ID.Deferral_Level = 0 then
1657          return False;
1658       end if;
1659
1660       --  Check that no one is holding this lock
1661
1662       if L.Owner /= null then
1663          return False;
1664       end if;
1665
1666       L.Frozen := True;
1667       return True;
1668    end Check_Finalize_Lock;
1669
1670    ----------------
1671    -- Initialize --
1672    ----------------
1673
1674    procedure Initialize (S : in out Suspension_Object) is
1675       Result : Interfaces.C.int;
1676
1677    begin
1678       --  Initialize internal state (always to zero (RM D.10(6)))
1679
1680       S.State := False;
1681       S.Waiting := False;
1682
1683       --  Initialize internal mutex
1684
1685       Result := mutex_init (S.L'Access, USYNC_THREAD, System.Null_Address);
1686       pragma Assert (Result = 0 or else Result = ENOMEM);
1687
1688       if Result = ENOMEM then
1689          raise Storage_Error with "Failed to allocate a lock";
1690       end if;
1691
1692       --  Initialize internal condition variable
1693
1694       Result := cond_init (S.CV'Access, USYNC_THREAD, 0);
1695       pragma Assert (Result = 0 or else Result = ENOMEM);
1696
1697       if Result /= 0 then
1698          Result := mutex_destroy (S.L'Access);
1699          pragma Assert (Result = 0);
1700
1701          if Result = ENOMEM then
1702             raise Storage_Error;
1703          end if;
1704       end if;
1705    end Initialize;
1706
1707    --------------
1708    -- Finalize --
1709    --------------
1710
1711    procedure Finalize (S : in out Suspension_Object) is
1712       Result  : Interfaces.C.int;
1713
1714    begin
1715       --  Destroy internal mutex
1716
1717       Result := mutex_destroy (S.L'Access);
1718       pragma Assert (Result = 0);
1719
1720       --  Destroy internal condition variable
1721
1722       Result := cond_destroy (S.CV'Access);
1723       pragma Assert (Result = 0);
1724    end Finalize;
1725
1726    -------------------
1727    -- Current_State --
1728    -------------------
1729
1730    function Current_State (S : Suspension_Object) return Boolean is
1731    begin
1732       --  We do not want to use lock on this read operation. State is marked
1733       --  as Atomic so that we ensure that the value retrieved is correct.
1734
1735       return S.State;
1736    end Current_State;
1737
1738    ---------------
1739    -- Set_False --
1740    ---------------
1741
1742    procedure Set_False (S : in out Suspension_Object) is
1743       Result  : Interfaces.C.int;
1744
1745    begin
1746       SSL.Abort_Defer.all;
1747
1748       Result := mutex_lock (S.L'Access);
1749       pragma Assert (Result = 0);
1750
1751       S.State := False;
1752
1753       Result := mutex_unlock (S.L'Access);
1754       pragma Assert (Result = 0);
1755
1756       SSL.Abort_Undefer.all;
1757    end Set_False;
1758
1759    --------------
1760    -- Set_True --
1761    --------------
1762
1763    procedure Set_True (S : in out Suspension_Object) is
1764       Result : Interfaces.C.int;
1765
1766    begin
1767       SSL.Abort_Defer.all;
1768
1769       Result := mutex_lock (S.L'Access);
1770       pragma Assert (Result = 0);
1771
1772       --  If there is already a task waiting on this suspension object then
1773       --  we resume it, leaving the state of the suspension object to False,
1774       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1775       --  the state to True.
1776
1777       if S.Waiting then
1778          S.Waiting := False;
1779          S.State := False;
1780
1781          Result := cond_signal (S.CV'Access);
1782          pragma Assert (Result = 0);
1783
1784       else
1785          S.State := True;
1786       end if;
1787
1788       Result := mutex_unlock (S.L'Access);
1789       pragma Assert (Result = 0);
1790
1791       SSL.Abort_Undefer.all;
1792    end Set_True;
1793
1794    ------------------------
1795    -- Suspend_Until_True --
1796    ------------------------
1797
1798    procedure Suspend_Until_True (S : in out Suspension_Object) is
1799       Result : Interfaces.C.int;
1800
1801    begin
1802       SSL.Abort_Defer.all;
1803
1804       Result := mutex_lock (S.L'Access);
1805       pragma Assert (Result = 0);
1806
1807       if S.Waiting then
1808
1809          --  Program_Error must be raised upon calling Suspend_Until_True
1810          --  if another task is already waiting on that suspension object
1811          --  (RM D.10(10)).
1812
1813          Result := mutex_unlock (S.L'Access);
1814          pragma Assert (Result = 0);
1815
1816          SSL.Abort_Undefer.all;
1817
1818          raise Program_Error;
1819
1820       else
1821          --  Suspend the task if the state is False. Otherwise, the task
1822          --  continues its execution, and the state of the suspension object
1823          --  is set to False (ARM D.10 par. 9).
1824
1825          if S.State then
1826             S.State := False;
1827          else
1828             S.Waiting := True;
1829             Result := cond_wait (S.CV'Access, S.L'Access);
1830          end if;
1831
1832          Result := mutex_unlock (S.L'Access);
1833          pragma Assert (Result = 0);
1834
1835          SSL.Abort_Undefer.all;
1836       end if;
1837    end Suspend_Until_True;
1838
1839    ----------------
1840    -- Check_Exit --
1841    ----------------
1842
1843    function Check_Exit (Self_ID : Task_Id) return Boolean is
1844    begin
1845       --  Check that caller is just holding Global_Task_Lock and no other locks
1846
1847       if Self_ID.Common.LL.Locks = null then
1848          return False;
1849       end if;
1850
1851       --  2 = Global_Task_Level
1852
1853       if Self_ID.Common.LL.Locks.Level /= 2 then
1854          return False;
1855       end if;
1856
1857       if Self_ID.Common.LL.Locks.Next /= null then
1858          return False;
1859       end if;
1860
1861       --  Check that caller is abort-deferred
1862
1863       if Self_ID.Deferral_Level = 0 then
1864          return False;
1865       end if;
1866
1867       return True;
1868    end Check_Exit;
1869
1870    --------------------
1871    -- Check_No_Locks --
1872    --------------------
1873
1874    function Check_No_Locks (Self_ID : Task_Id) return Boolean is
1875    begin
1876       return Self_ID.Common.LL.Locks = null;
1877    end Check_No_Locks;
1878
1879    ----------------------
1880    -- Environment_Task --
1881    ----------------------
1882
1883    function Environment_Task return Task_Id is
1884    begin
1885       return Environment_Task_Id;
1886    end Environment_Task;
1887
1888    --------------
1889    -- Lock_RTS --
1890    --------------
1891
1892    procedure Lock_RTS is
1893    begin
1894       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1895    end Lock_RTS;
1896
1897    ----------------
1898    -- Unlock_RTS --
1899    ----------------
1900
1901    procedure Unlock_RTS is
1902    begin
1903       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1904    end Unlock_RTS;
1905
1906    ------------------
1907    -- Suspend_Task --
1908    ------------------
1909
1910    function Suspend_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_suspend (T.Common.LL.Thread) = 0;
1917       else
1918          return True;
1919       end if;
1920    end Suspend_Task;
1921
1922    -----------------
1923    -- Resume_Task --
1924    -----------------
1925
1926    function Resume_Task
1927      (T           : ST.Task_Id;
1928       Thread_Self : Thread_Id) return Boolean
1929    is
1930    begin
1931       if T.Common.LL.Thread /= Thread_Self then
1932          return thr_continue (T.Common.LL.Thread) = 0;
1933       else
1934          return True;
1935       end if;
1936    end Resume_Task;
1937
1938    --------------------
1939    -- Stop_All_Tasks --
1940    --------------------
1941
1942    procedure Stop_All_Tasks is
1943    begin
1944       null;
1945    end Stop_All_Tasks;
1946
1947    ---------------
1948    -- Stop_Task --
1949    ---------------
1950
1951    function Stop_Task (T : ST.Task_Id) return Boolean is
1952       pragma Unreferenced (T);
1953    begin
1954       return False;
1955    end Stop_Task;
1956
1957    -------------------
1958    -- Continue_Task --
1959    -------------------
1960
1961    function Continue_Task (T : ST.Task_Id) return Boolean is
1962       pragma Unreferenced (T);
1963    begin
1964       return False;
1965    end Continue_Task;
1966
1967 end System.Task_Primitives.Operations;