gcc/ada/s-taprop-solaris.adb

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