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