gcc/ada/s-taprop-tru64.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-2006, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is a DEC Unix 4.0d 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 System.Interrupt_Management;
  47 --  used for Keep_Unmasked
  48 --           Abort_Task_Interrupt
  49 --           Interrupt_ID
  50
  51 with System.OS_Primitives;
  52 --  used for Delay_Modes
  53
  54 with System.Task_Info;
  55 --  used for Task_Info_Type
  56
  57 with Interfaces;
  58 --  used for Shift_Left
  59
  60 with Interfaces.C;
  61 --  used for int
  62 --           size_t
  63
  64 with System.Soft_Links;
  65 --  used for Abort_Defer/Undefer
  66
  67 --  We use System.Soft_Links instead of System.Tasking.Initialization
  68 --  because the later is a higher level package that we shouldn't depend on.
  69 --  For example when using the restricted run time, it is replaced by
  70 --  System.Tasking.Restricted.Stages.
  71
  72 with Unchecked_Deallocation;
  73
  74 package body System.Task_Primitives.Operations is
  75
  76    package SSL renames System.Soft_Links;
  77
  78    use System.Tasking.Debug;
  79    use System.Tasking;
  80    use Interfaces.C;
  81    use System.OS_Interface;
  82    use System.Parameters;
  83    use System.OS_Primitives;
  84
  85    ----------------
  86    -- Local Data --
  87    ----------------
  88
  89    --  The followings are logically constants, but need to be initialized
  90    --  at run time.
  91
  92    Single_RTS_Lock : aliased RTS_Lock;
  93    --  This is a lock to allow only one thread of control in the RTS at
  94    --  a time; it is used to execute in mutual exclusion from all other tasks.
  95    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
  96
  97    ATCB_Key : aliased pthread_key_t;
  98    --  Key used to find the Ada Task_Id associated with a thread
  99
 100    Environment_Task_Id : Task_Id;
 101    --  A variable to hold Task_Id for the environment task
 102
 103    Unblocked_Signal_Mask : aliased sigset_t;
 104    --  The set of signals that should unblocked in all tasks
 105
 106    Time_Slice_Val : Integer;
 107    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 108
 109    Locking_Policy : Character;
 110    pragma Import (C, Locking_Policy, "__gl_locking_policy");
 111
 112    Dispatching_Policy : Character;
 113    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 114
 115    Curpid : pid_t;
 116
 117    Foreign_Task_Elaborated : aliased Boolean := True;
 118    --  Used to identified fake tasks (i.e., non-Ada Threads)
 119
 120    --------------------
 121    -- Local Packages --
 122    --------------------
 123
 124    package Specific is
 125
 126       procedure Initialize (Environment_Task : Task_Id);
 127       pragma Inline (Initialize);
 128       --  Initialize various data needed by this package
 129
 130       function Is_Valid_Task return Boolean;
 131       pragma Inline (Is_Valid_Task);
 132       --  Does executing thread have a TCB?
 133
 134       procedure Set (Self_Id : Task_Id);
 135       pragma Inline (Set);
 136       --  Set the self id for the current task
 137
 138       function Self return Task_Id;
 139       pragma Inline (Self);
 140       --  Return a pointer to the Ada Task Control Block of the calling task
 141
 142    end Specific;
 143
 144    package body Specific is separate;
 145    --  The body of this package is target specific
 146
 147    ---------------------------------
 148    -- Support for foreign threads --
 149    ---------------------------------
 150
 151    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
 152    --  Allocate and initialize a new ATCB for the current Thread
 153
 154    function Register_Foreign_Thread
 155      (Thread : Thread_Id) return Task_Id is separate;
 156
 157    -----------------------
 158    -- Local Subprograms --
 159    -----------------------
 160
 161    procedure Abort_Handler (Sig : Signal);
 162    --  Signal handler used to implement asynchronous abort
 163
 164    function Get_Policy (Prio : System.Any_Priority) return Character;
 165    pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
 166    --  Get priority specific dispatching policy
 167
 168    -------------------
 169    -- Abort_Handler --
 170    -------------------
 171
 172    procedure Abort_Handler (Sig : Signal) is
 173       pragma Unreferenced (Sig);
 174
 175       T       : constant Task_Id := Self;
 176       Result  : Interfaces.C.int;
 177       Old_Set : aliased sigset_t;
 178
 179    begin
 180       --  It is not safe to raise an exception when using ZCX and the GCC
 181       --  exception handling mechanism.
 182
 183       if ZCX_By_Default and then GCC_ZCX_Support then
 184          return;
 185       end if;
 186
 187       if T.Deferral_Level = 0
 188         and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
 189         not T.Aborting
 190       then
 191          T.Aborting := True;
 192
 193          --  Make sure signals used for RTS internal purpose are unmasked
 194
 195          Result := pthread_sigmask (SIG_UNBLOCK,
 196            Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
 197          pragma Assert (Result = 0);
 198
 199          raise Standard'Abort_Signal;
 200       end if;
 201    end Abort_Handler;
 202
 203    ------------------
 204    -- Stack_Guard  --
 205    ------------------
 206
 207    --  The underlying thread system sets a guard page at the
 208    --  bottom of a thread stack, so nothing is needed.
 209
 210    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 211       pragma Unreferenced (T);
 212       pragma Unreferenced (On);
 213    begin
 214       null;
 215    end Stack_Guard;
 216
 217    --------------------
 218    -- Get_Thread_Id  --
 219    --------------------
 220
 221    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 222    begin
 223       return T.Common.LL.Thread;
 224    end Get_Thread_Id;
 225
 226    ----------
 227    -- Self --
 228    ----------
 229
 230    function Self return Task_Id renames Specific.Self;
 231
 232    ---------------------
 233    -- Initialize_Lock --
 234    ---------------------
 235
 236    --  Note: mutexes and cond_variables needed per-task basis are
 237    --        initialized in Initialize_TCB and the Storage_Error is
 238    --        handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 239    --        used in RTS is initialized before any status change of RTS.
 240    --        Therefore rasing Storage_Error in the following routines
 241    --        should be able to be handled safely.
 242
 243    procedure Initialize_Lock
 244      (Prio : System.Any_Priority;
 245       L    : access Lock)
 246    is
 247       Attributes : aliased pthread_mutexattr_t;
 248       Result     : Interfaces.C.int;
 249
 250    begin
 251       Result := pthread_mutexattr_init (Attributes'Access);
 252       pragma Assert (Result = 0 or else Result = ENOMEM);
 253
 254       if Result = ENOMEM then
 255          raise Storage_Error;
 256       end if;
 257
 258       if Locking_Policy = 'C' then
 259          L.Ceiling := Interfaces.C.int (Prio);
 260       end if;
 261
 262       Result := pthread_mutex_init (L.L'Access, Attributes'Access);
 263       pragma Assert (Result = 0 or else Result = ENOMEM);
 264
 265       if Result = ENOMEM then
 266          Result := pthread_mutexattr_destroy (Attributes'Access);
 267          raise Storage_Error;
 268       end if;
 269
 270       Result := pthread_mutexattr_destroy (Attributes'Access);
 271       pragma Assert (Result = 0);
 272    end Initialize_Lock;
 273
 274    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 275       pragma Unreferenced (Level);
 276
 277       Attributes : aliased pthread_mutexattr_t;
 278       Result     : Interfaces.C.int;
 279
 280    begin
 281       Result := pthread_mutexattr_init (Attributes'Access);
 282       pragma Assert (Result = 0 or else Result = ENOMEM);
 283
 284       if Result = ENOMEM then
 285          raise Storage_Error;
 286       end if;
 287
 288       Result := pthread_mutex_init (L, Attributes'Access);
 289       pragma Assert (Result = 0 or else Result = ENOMEM);
 290
 291       if Result = ENOMEM then
 292          Result := pthread_mutexattr_destroy (Attributes'Access);
 293          raise Storage_Error;
 294       end if;
 295
 296       Result := pthread_mutexattr_destroy (Attributes'Access);
 297       pragma Assert (Result = 0);
 298    end Initialize_Lock;
 299
 300    -------------------
 301    -- Finalize_Lock --
 302    -------------------
 303
 304    procedure Finalize_Lock (L : access Lock) is
 305       Result : Interfaces.C.int;
 306    begin
 307       Result := pthread_mutex_destroy (L.L'Access);
 308       pragma Assert (Result = 0);
 309    end Finalize_Lock;
 310
 311    procedure Finalize_Lock (L : access RTS_Lock) is
 312       Result : Interfaces.C.int;
 313    begin
 314       Result := pthread_mutex_destroy (L);
 315       pragma Assert (Result = 0);
 316    end Finalize_Lock;
 317
 318    ----------------
 319    -- Write_Lock --
 320    ----------------
 321
 322    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 323       Result         : Interfaces.C.int;
 324       Self_ID        : Task_Id;
 325       All_Tasks_Link : Task_Id;
 326       Current_Prio   : System.Any_Priority;
 327
 328    begin
 329       --  Perform ceiling checks only when this is the locking policy in use
 330
 331       if Locking_Policy = 'C' then
 332          Self_ID := Self;
 333          All_Tasks_Link := Self_ID.Common.All_Tasks_Link;
 334          Current_Prio := Get_Priority (Self_ID);
 335
 336          --  If there is no other task, no need to check priorities
 337
 338          if All_Tasks_Link /= Null_Task
 339            and then L.Ceiling < Interfaces.C.int (Current_Prio)
 340          then
 341             Ceiling_Violation := True;
 342             return;
 343          end if;
 344       end if;
 345
 346       Result := pthread_mutex_lock (L.L'Access);
 347       pragma Assert (Result = 0);
 348
 349       Ceiling_Violation := False;
 350    end Write_Lock;
 351
 352    procedure Write_Lock
 353      (L : access RTS_Lock; Global_Lock : Boolean := False)
 354    is
 355       Result : Interfaces.C.int;
 356    begin
 357       if not Single_Lock or else Global_Lock then
 358          Result := pthread_mutex_lock (L);
 359          pragma Assert (Result = 0);
 360       end if;
 361    end Write_Lock;
 362
 363    procedure Write_Lock (T : Task_Id) is
 364       Result : Interfaces.C.int;
 365    begin
 366       if not Single_Lock then
 367          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 368          pragma Assert (Result = 0);
 369       end if;
 370    end Write_Lock;
 371
 372    ---------------
 373    -- Read_Lock --
 374    ---------------
 375
 376    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 377    begin
 378       Write_Lock (L, Ceiling_Violation);
 379    end Read_Lock;
 380
 381    ------------
 382    -- Unlock --
 383    ------------
 384
 385    procedure Unlock (L : access Lock) is
 386       Result : Interfaces.C.int;
 387    begin
 388       Result := pthread_mutex_unlock (L.L'Access);
 389       pragma Assert (Result = 0);
 390    end Unlock;
 391
 392    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 393       Result : Interfaces.C.int;
 394    begin
 395       if not Single_Lock or else Global_Lock then
 396          Result := pthread_mutex_unlock (L);
 397          pragma Assert (Result = 0);
 398       end if;
 399    end Unlock;
 400
 401    procedure Unlock (T : Task_Id) is
 402       Result : Interfaces.C.int;
 403    begin
 404       if not Single_Lock then
 405          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 406          pragma Assert (Result = 0);
 407       end if;
 408    end Unlock;
 409
 410    -----------
 411    -- Sleep --
 412    -----------
 413
 414    procedure Sleep
 415      (Self_ID : Task_Id;
 416       Reason  : System.Tasking.Task_States)
 417    is
 418       pragma Unreferenced (Reason);
 419
 420       Result : Interfaces.C.int;
 421
 422    begin
 423       if Single_Lock then
 424          Result := pthread_cond_wait
 425                      (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 426       else
 427          Result := pthread_cond_wait
 428                      (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 429       end if;
 430
 431       --  EINTR is not considered a failure
 432
 433       pragma Assert (Result = 0 or else Result = EINTR);
 434    end Sleep;
 435
 436    -----------------
 437    -- Timed_Sleep --
 438    -----------------
 439
 440    --  This is for use within the run-time system, so abort is
 441    --  assumed to be already deferred, and the caller should be
 442    --  holding its own ATCB lock.
 443
 444    procedure Timed_Sleep
 445      (Self_ID  : Task_Id;
 446       Time     : Duration;
 447       Mode     : ST.Delay_Modes;
 448       Reason   : System.Tasking.Task_States;
 449       Timedout : out Boolean;
 450       Yielded  : out Boolean)
 451    is
 452       pragma Unreferenced (Reason);
 453
 454       Check_Time : constant Duration := Monotonic_Clock;
 455       Abs_Time   : Duration;
 456       Request    : aliased timespec;
 457       Result     : Interfaces.C.int;
 458
 459    begin
 460       Timedout := True;
 461       Yielded := False;
 462
 463       if Mode = Relative then
 464          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 465       else
 466          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 467       end if;
 468
 469       if Abs_Time > Check_Time then
 470          Request := To_Timespec (Abs_Time);
 471
 472          loop
 473             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 474               or else Self_ID.Pending_Priority_Change;
 475
 476             if Single_Lock then
 477                Result := pthread_cond_timedwait
 478                            (Self_ID.Common.LL.CV'Access,
 479                             Single_RTS_Lock'Access,
 480                             Request'Access);
 481
 482             else
 483                Result := pthread_cond_timedwait
 484                            (Self_ID.Common.LL.CV'Access,
 485                             Self_ID.Common.LL.L'Access,
 486                             Request'Access);
 487             end if;
 488
 489             exit when Abs_Time <= Monotonic_Clock;
 490
 491             if Result = 0 or Result = EINTR then
 492
 493                --  Somebody may have called Wakeup for us
 494
 495                Timedout := False;
 496                exit;
 497             end if;
 498
 499             pragma Assert (Result = ETIMEDOUT);
 500          end loop;
 501       end if;
 502    end Timed_Sleep;
 503
 504    -----------------
 505    -- Timed_Delay --
 506    -----------------
 507
 508    --  This is for use in implementing delay statements, so
 509    --  we assume the caller is abort-deferred but is holding
 510    --  no locks.
 511
 512    procedure Timed_Delay
 513      (Self_ID  : Task_Id;
 514       Time     : Duration;
 515       Mode     : ST.Delay_Modes)
 516    is
 517       Check_Time : constant Duration := Monotonic_Clock;
 518       Abs_Time   : Duration;
 519       Request    : aliased timespec;
 520       Result     : Interfaces.C.int;
 521
 522    begin
 523       if Single_Lock then
 524          Lock_RTS;
 525       end if;
 526
 527       Write_Lock (Self_ID);
 528
 529       if Mode = Relative then
 530          Abs_Time := Time + Check_Time;
 531       else
 532          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 533       end if;
 534
 535       if Abs_Time > Check_Time then
 536          Request := To_Timespec (Abs_Time);
 537          Self_ID.Common.State := Delay_Sleep;
 538
 539          loop
 540             if Self_ID.Pending_Priority_Change then
 541                Self_ID.Pending_Priority_Change := False;
 542                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 543                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 544             end if;
 545
 546             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 547
 548             if Single_Lock then
 549                Result := pthread_cond_timedwait
 550                            (Self_ID.Common.LL.CV'Access,
 551                             Single_RTS_Lock'Access,
 552                             Request'Access);
 553             else
 554                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 555                  Self_ID.Common.LL.L'Access, Request'Access);
 556             end if;
 557
 558             exit when Abs_Time <= Monotonic_Clock;
 559
 560             pragma Assert (Result = 0 or else
 561               Result = ETIMEDOUT or else
 562               Result = EINTR);
 563          end loop;
 564
 565          Self_ID.Common.State := Runnable;
 566       end if;
 567
 568       Unlock (Self_ID);
 569
 570       if Single_Lock then
 571          Unlock_RTS;
 572       end if;
 573
 574       Yield;
 575    end Timed_Delay;
 576
 577    ---------------------
 578    -- Monotonic_Clock --
 579    ---------------------
 580
 581    function Monotonic_Clock return Duration is
 582       TS     : aliased timespec;
 583       Result : Interfaces.C.int;
 584    begin
 585       Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
 586       pragma Assert (Result = 0);
 587       return To_Duration (TS);
 588    end Monotonic_Clock;
 589
 590    -------------------
 591    -- RT_Resolution --
 592    -------------------
 593
 594    function RT_Resolution return Duration is
 595    begin
 596       --  Returned value must be an integral multiple of Duration'Small (1 ns)
 597       --  The following is the best approximation of 1/1024. The clock on the
 598       --  DEC Alpha ticks at 1024 Hz.
 599
 600       return 0.000_976_563;
 601    end RT_Resolution;
 602
 603    ------------
 604    -- Wakeup --
 605    ------------
 606
 607    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 608       pragma Unreferenced (Reason);
 609       Result : Interfaces.C.int;
 610    begin
 611       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 612       pragma Assert (Result = 0);
 613    end Wakeup;
 614
 615    -----------
 616    -- Yield --
 617    -----------
 618
 619    procedure Yield (Do_Yield : Boolean := True) is
 620       Result : Interfaces.C.int;
 621       pragma Unreferenced (Result);
 622    begin
 623       if Do_Yield then
 624          Result := sched_yield;
 625       end if;
 626    end Yield;
 627
 628    ------------------
 629    -- Set_Priority --
 630    ------------------
 631
 632    procedure Set_Priority
 633      (T                   : Task_Id;
 634       Prio                : System.Any_Priority;
 635       Loss_Of_Inheritance : Boolean := False)
 636    is
 637       pragma Unreferenced (Loss_Of_Inheritance);
 638
 639       Result : Interfaces.C.int;
 640       Param  : aliased struct_sched_param;
 641
 642       Priority_Specific_Policy : constant Character := Get_Policy (Prio);
 643       --  Upper case first character of the policy name corresponding to the
 644       --  task as set by a Priority_Specific_Dispatching pragma.
 645
 646    begin
 647       T.Common.Current_Priority := Prio;
 648       Param.sched_priority  := Interfaces.C.int (Underlying_Priorities (Prio));
 649
 650       if Dispatching_Policy = 'R'
 651         or else Priority_Specific_Policy = 'R'
 652         or else Time_Slice_Val > 0
 653       then
 654          Result := pthread_setschedparam
 655                      (T.Common.LL.Thread, SCHED_RR, Param'Access);
 656
 657       elsif Dispatching_Policy = 'F'
 658         or else Priority_Specific_Policy = 'F'
 659         or else Time_Slice_Val = 0
 660       then
 661          Result := pthread_setschedparam
 662                      (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 663
 664       else
 665          Result := pthread_setschedparam
 666                      (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 667       end if;
 668
 669       pragma Assert (Result = 0);
 670    end Set_Priority;
 671
 672    ------------------
 673    -- Get_Priority --
 674    ------------------
 675
 676    function Get_Priority (T : Task_Id) return System.Any_Priority is
 677    begin
 678       return T.Common.Current_Priority;
 679    end Get_Priority;
 680
 681    ----------------
 682    -- Enter_Task --
 683    ----------------
 684
 685    procedure Enter_Task (Self_ID : Task_Id) is
 686    begin
 687       Hide_Yellow_Zone;
 688       Self_ID.Common.LL.Thread := pthread_self;
 689       Specific.Set (Self_ID);
 690
 691       Lock_RTS;
 692
 693       for J in Known_Tasks'Range loop
 694          if Known_Tasks (J) = null then
 695             Known_Tasks (J) := Self_ID;
 696             Self_ID.Known_Tasks_Index := J;
 697             exit;
 698          end if;
 699       end loop;
 700
 701       Unlock_RTS;
 702    end Enter_Task;
 703
 704    --------------
 705    -- New_ATCB --
 706    --------------
 707
 708    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 709    begin
 710       return new Ada_Task_Control_Block (Entry_Num);
 711    end New_ATCB;
 712
 713    -------------------
 714    -- Is_Valid_Task --
 715    -------------------
 716
 717    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 718
 719    -----------------------------
 720    -- Register_Foreign_Thread --
 721    -----------------------------
 722
 723    function Register_Foreign_Thread return Task_Id is
 724    begin
 725       if Is_Valid_Task then
 726          return Self;
 727       else
 728          return Register_Foreign_Thread (pthread_self);
 729       end if;
 730    end Register_Foreign_Thread;
 731
 732    --------------------
 733    -- Initialize_TCB --
 734    --------------------
 735
 736    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 737       Mutex_Attr : aliased pthread_mutexattr_t;
 738       Result     : Interfaces.C.int;
 739       Cond_Attr  : aliased pthread_condattr_t;
 740
 741    begin
 742       if not Single_Lock then
 743          Result := pthread_mutexattr_init (Mutex_Attr'Access);
 744          pragma Assert (Result = 0 or else Result = ENOMEM);
 745
 746          if Result = 0 then
 747             Result := pthread_mutex_init
 748                         (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
 749             pragma Assert (Result = 0 or else Result = ENOMEM);
 750          end if;
 751
 752          if Result /= 0 then
 753             Succeeded := False;
 754             return;
 755          end if;
 756
 757          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 758          pragma Assert (Result = 0);
 759       end if;
 760
 761       Result := pthread_condattr_init (Cond_Attr'Access);
 762       pragma Assert (Result = 0 or else Result = ENOMEM);
 763
 764       if Result = 0 then
 765          Result := pthread_cond_init
 766                      (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
 767          pragma Assert (Result = 0 or else Result = ENOMEM);
 768       end if;
 769
 770       if Result = 0 then
 771          Succeeded := True;
 772       else
 773          if not Single_Lock then
 774             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 775             pragma Assert (Result = 0);
 776          end if;
 777
 778          Succeeded := False;
 779       end if;
 780
 781       Result := pthread_condattr_destroy (Cond_Attr'Access);
 782       pragma Assert (Result = 0);
 783    end Initialize_TCB;
 784
 785    -----------------
 786    -- Create_Task --
 787    -----------------
 788
 789    procedure Create_Task
 790      (T          : Task_Id;
 791       Wrapper    : System.Address;
 792       Stack_Size : System.Parameters.Size_Type;
 793       Priority   : System.Any_Priority;
 794       Succeeded  : out Boolean)
 795    is
 796       Attributes          : aliased pthread_attr_t;
 797       Adjusted_Stack_Size : Interfaces.C.size_t;
 798       Result              : Interfaces.C.int;
 799       Param               : aliased System.OS_Interface.struct_sched_param;
 800
 801       Priority_Specific_Policy : constant Character := Get_Policy (Priority);
 802       --  Upper case first character of the policy name corresponding to the
 803       --  task as set by a Priority_Specific_Dispatching pragma.
 804
 805       use System.Task_Info;
 806
 807    begin
 808       --  Account for the Yellow Zone (2 pages) and the guard page
 809       --  right above. See Hide_Yellow_Zone for the rationale.
 810
 811       Adjusted_Stack_Size :=
 812         Interfaces.C.size_t (Stack_Size) + 3 * Get_Page_Size;
 813
 814       Result := pthread_attr_init (Attributes'Access);
 815       pragma Assert (Result = 0 or else Result = ENOMEM);
 816
 817       if Result /= 0 then
 818          Succeeded := False;
 819          return;
 820       end if;
 821
 822       Result := pthread_attr_setdetachstate
 823                   (Attributes'Access, PTHREAD_CREATE_DETACHED);
 824       pragma Assert (Result = 0);
 825
 826       Result := pthread_attr_setstacksize
 827                   (Attributes'Access, Adjusted_Stack_Size);
 828       pragma Assert (Result = 0);
 829
 830       Param.sched_priority :=
 831         Interfaces.C.int (Underlying_Priorities (Priority));
 832       Result := pthread_attr_setschedparam
 833                   (Attributes'Access, Param'Access);
 834       pragma Assert (Result = 0);
 835
 836       if Dispatching_Policy = 'R'
 837         or else Priority_Specific_Policy = 'R'
 838         or else Time_Slice_Val > 0
 839       then
 840          Result := pthread_attr_setschedpolicy
 841                      (Attributes'Access, System.OS_Interface.SCHED_RR);
 842
 843       elsif Dispatching_Policy = 'F'
 844         or else Priority_Specific_Policy = 'F'
 845         or else Time_Slice_Val = 0
 846       then
 847          Result := pthread_attr_setschedpolicy
 848                      (Attributes'Access, System.OS_Interface.SCHED_FIFO);
 849
 850       else
 851          Result := pthread_attr_setschedpolicy
 852                      (Attributes'Access, System.OS_Interface.SCHED_OTHER);
 853       end if;
 854
 855       pragma Assert (Result = 0);
 856
 857       --  Set the scheduling parameters explicitly, since this is the
 858       --  only way to force the OS to take e.g. the sched policy and scope
 859       --  attributes into account.
 860
 861       Result := pthread_attr_setinheritsched
 862                   (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
 863       pragma Assert (Result = 0);
 864
 865       T.Common.Current_Priority := Priority;
 866
 867       if T.Common.Task_Info /= null then
 868          case T.Common.Task_Info.Contention_Scope is
 869             when System.Task_Info.Process_Scope =>
 870                Result := pthread_attr_setscope
 871                            (Attributes'Access, PTHREAD_SCOPE_PROCESS);
 872
 873             when System.Task_Info.System_Scope =>
 874                Result := pthread_attr_setscope
 875                            (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
 876
 877             when System.Task_Info.Default_Scope =>
 878                Result := 0;
 879          end case;
 880
 881          pragma Assert (Result = 0);
 882       end if;
 883
 884       --  Since the initial signal mask of a thread is inherited from the
 885       --  creator, and the Environment task has all its signals masked, we
 886       --  do not need to manipulate caller's signal mask at this point.
 887       --  All tasks in RTS will have All_Tasks_Mask initially.
 888
 889       Result := pthread_create
 890                   (T.Common.LL.Thread'Access,
 891                    Attributes'Access,
 892                    Thread_Body_Access (Wrapper),
 893                    To_Address (T));
 894       pragma Assert (Result = 0 or else Result = EAGAIN);
 895
 896       Succeeded := Result = 0;
 897
 898       Result := pthread_attr_destroy (Attributes'Access);
 899       pragma Assert (Result = 0);
 900
 901       if T.Common.Task_Info /= null then
 902          --  ??? We're using a process-wide function to implement a task
 903          --  specific characteristic.
 904
 905          if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then
 906             Result := bind_to_cpu (Curpid, 0);
 907          elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then
 908             Result := bind_to_cpu
 909               (Curpid,
 910                Interfaces.C.unsigned_long (
 911                  Interfaces.Shift_Left
 912                    (Interfaces.Unsigned_64'(1),
 913                     T.Common.Task_Info.Bind_To_Cpu_Number - 1)));
 914             pragma Assert (Result = 0);
 915          end if;
 916       end if;
 917    end Create_Task;
 918
 919    ------------------
 920    -- Finalize_TCB --
 921    ------------------
 922
 923    procedure Finalize_TCB (T : Task_Id) is
 924       Result  : Interfaces.C.int;
 925       Tmp     : Task_Id := T;
 926       Is_Self : constant Boolean := T = Self;
 927
 928       procedure Free is new
 929         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 930
 931    begin
 932       if not Single_Lock then
 933          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 934          pragma Assert (Result = 0);
 935       end if;
 936
 937       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 938       pragma Assert (Result = 0);
 939
 940       if T.Known_Tasks_Index /= -1 then
 941          Known_Tasks (T.Known_Tasks_Index) := null;
 942       end if;
 943
 944       Free (Tmp);
 945
 946       if Is_Self then
 947          Specific.Set (null);
 948       end if;
 949    end Finalize_TCB;
 950
 951    ---------------
 952    -- Exit_Task --
 953    ---------------
 954
 955    procedure Exit_Task is
 956    begin
 957       Specific.Set (null);
 958    end Exit_Task;
 959
 960    ----------------
 961    -- Abort_Task --
 962    ----------------
 963
 964    procedure Abort_Task (T : Task_Id) is
 965       Result : Interfaces.C.int;
 966    begin
 967       Result := pthread_kill (T.Common.LL.Thread,
 968         Signal (System.Interrupt_Management.Abort_Task_Interrupt));
 969       pragma Assert (Result = 0);
 970    end Abort_Task;
 971
 972    ----------------
 973    -- Initialize --
 974    ----------------
 975
 976    procedure Initialize (S : in out Suspension_Object) is
 977       Mutex_Attr : aliased pthread_mutexattr_t;
 978       Cond_Attr  : aliased pthread_condattr_t;
 979       Result     : Interfaces.C.int;
 980    begin
 981       --  Initialize internal state. It is always initialized to False (ARM
 982       --  D.10 par. 6).
 983
 984       S.State := False;
 985       S.Waiting := False;
 986
 987       --  Initialize internal mutex
 988
 989       Result := pthread_mutexattr_init (Mutex_Attr'Access);
 990       pragma Assert (Result = 0 or else Result = ENOMEM);
 991
 992       if Result = ENOMEM then
 993          raise Storage_Error;
 994       end if;
 995
 996       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
 997       pragma Assert (Result = 0 or else Result = ENOMEM);
 998
 999       if Result = ENOMEM then
1000          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1001          raise Storage_Error;
1002       end if;
1003
1004       Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1005       pragma Assert (Result = 0);
1006
1007       --  Initialize internal condition variable
1008
1009       Result := pthread_condattr_init (Cond_Attr'Access);
1010       pragma Assert (Result = 0 or else Result = ENOMEM);
1011
1012       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1013
1014       pragma Assert (Result = 0 or else Result = ENOMEM);
1015
1016       if Result /= 0 then
1017          Result := pthread_mutex_destroy (S.L'Access);
1018          pragma Assert (Result = 0);
1019
1020          if Result = ENOMEM then
1021             raise Storage_Error;
1022          end if;
1023       end if;
1024    end Initialize;
1025
1026    --------------
1027    -- Finalize --
1028    --------------
1029
1030    procedure Finalize (S : in out Suspension_Object) is
1031       Result  : Interfaces.C.int;
1032    begin
1033       --  Destroy internal mutex
1034
1035       Result := pthread_mutex_destroy (S.L'Access);
1036       pragma Assert (Result = 0);
1037
1038       --  Destroy internal condition variable
1039
1040       Result := pthread_cond_destroy (S.CV'Access);
1041       pragma Assert (Result = 0);
1042    end Finalize;
1043
1044    -------------------
1045    -- Current_State --
1046    -------------------
1047
1048    function Current_State (S : Suspension_Object) return Boolean is
1049    begin
1050       --  We do not want to use lock on this read operation. State is marked
1051       --  as Atomic so that we ensure that the value retrieved is correct.
1052
1053       return S.State;
1054    end Current_State;
1055
1056    ---------------
1057    -- Set_False --
1058    ---------------
1059
1060    procedure Set_False (S : in out Suspension_Object) is
1061       Result  : Interfaces.C.int;
1062    begin
1063       SSL.Abort_Defer.all;
1064
1065       Result := pthread_mutex_lock (S.L'Access);
1066       pragma Assert (Result = 0);
1067
1068       S.State := False;
1069
1070       Result := pthread_mutex_unlock (S.L'Access);
1071       pragma Assert (Result = 0);
1072
1073       SSL.Abort_Undefer.all;
1074    end Set_False;
1075
1076    --------------
1077    -- Set_True --
1078    --------------
1079
1080    procedure Set_True (S : in out Suspension_Object) is
1081       Result : Interfaces.C.int;
1082    begin
1083       SSL.Abort_Defer.all;
1084
1085       Result := pthread_mutex_lock (S.L'Access);
1086       pragma Assert (Result = 0);
1087
1088       --  If there is already a task waiting on this suspension object then
1089       --  we resume it, leaving the state of the suspension object to False,
1090       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1091       --  the state to True.
1092
1093       if S.Waiting then
1094          S.Waiting := False;
1095          S.State := False;
1096
1097          Result := pthread_cond_signal (S.CV'Access);
1098          pragma Assert (Result = 0);
1099       else
1100          S.State := True;
1101       end if;
1102
1103       Result := pthread_mutex_unlock (S.L'Access);
1104       pragma Assert (Result = 0);
1105
1106       SSL.Abort_Undefer.all;
1107    end Set_True;
1108
1109    ------------------------
1110    -- Suspend_Until_True --
1111    ------------------------
1112
1113    procedure Suspend_Until_True (S : in out Suspension_Object) is
1114       Result : Interfaces.C.int;
1115    begin
1116       SSL.Abort_Defer.all;
1117
1118       Result := pthread_mutex_lock (S.L'Access);
1119       pragma Assert (Result = 0);
1120
1121       if S.Waiting then
1122          --  Program_Error must be raised upon calling Suspend_Until_True
1123          --  if another task is already waiting on that suspension object
1124          --  (ARM D.10 par. 10).
1125
1126          Result := pthread_mutex_unlock (S.L'Access);
1127          pragma Assert (Result = 0);
1128
1129          SSL.Abort_Undefer.all;
1130
1131          raise Program_Error;
1132       else
1133          --  Suspend the task if the state is False. Otherwise, the task
1134          --  continues its execution, and the state of the suspension object
1135          --  is set to False (ARM D.10 par. 9).
1136
1137          if S.State then
1138             S.State := False;
1139          else
1140             S.Waiting := True;
1141             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1142          end if;
1143
1144          Result := pthread_mutex_unlock (S.L'Access);
1145          pragma Assert (Result = 0);
1146
1147          SSL.Abort_Undefer.all;
1148       end if;
1149    end Suspend_Until_True;
1150
1151    ----------------
1152    -- Check_Exit --
1153    ----------------
1154
1155    --  Dummy version
1156
1157    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1158       pragma Unreferenced (Self_ID);
1159    begin
1160       return True;
1161    end Check_Exit;
1162
1163    --------------------
1164    -- Check_No_Locks --
1165    --------------------
1166
1167    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1168       pragma Unreferenced (Self_ID);
1169    begin
1170       return True;
1171    end Check_No_Locks;
1172
1173    ----------------------
1174    -- Environment_Task --
1175    ----------------------
1176
1177    function Environment_Task return Task_Id is
1178    begin
1179       return Environment_Task_Id;
1180    end Environment_Task;
1181
1182    --------------
1183    -- Lock_RTS --
1184    --------------
1185
1186    procedure Lock_RTS is
1187    begin
1188       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1189    end Lock_RTS;
1190
1191    ----------------
1192    -- Unlock_RTS --
1193    ----------------
1194
1195    procedure Unlock_RTS is
1196    begin
1197       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1198    end Unlock_RTS;
1199
1200    ------------------
1201    -- Suspend_Task --
1202    ------------------
1203
1204    function Suspend_Task
1205      (T           : ST.Task_Id;
1206       Thread_Self : Thread_Id) return Boolean
1207    is
1208       pragma Warnings (Off, T);
1209       pragma Warnings (Off, Thread_Self);
1210    begin
1211       return False;
1212    end Suspend_Task;
1213
1214    -----------------
1215    -- Resume_Task --
1216    -----------------
1217
1218    function Resume_Task
1219      (T           : ST.Task_Id;
1220       Thread_Self : Thread_Id) return Boolean
1221    is
1222       pragma Warnings (Off, T);
1223       pragma Warnings (Off, Thread_Self);
1224    begin
1225       return False;
1226    end Resume_Task;
1227
1228    ----------------
1229    -- Initialize --
1230    ----------------
1231
1232    procedure Initialize (Environment_Task : Task_Id) is
1233       act     : aliased struct_sigaction;
1234       old_act : aliased struct_sigaction;
1235       Tmp_Set : aliased sigset_t;
1236       Result  : Interfaces.C.int;
1237
1238       function State
1239         (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1240       pragma Import (C, State, "__gnat_get_interrupt_state");
1241       --  Get interrupt state. Defined in a-init.c. The input argument is
1242       --  the interrupt number, and the result is one of the following:
1243
1244       Default : constant Character := 's';
1245       --    'n'   this interrupt not set by any Interrupt_State pragma
1246       --    'u'   Interrupt_State pragma set state to User
1247       --    'r'   Interrupt_State pragma set state to Runtime
1248       --    's'   Interrupt_State pragma set state to System (use "default"
1249       --           system handler)
1250
1251    begin
1252       Environment_Task_Id := Environment_Task;
1253
1254       Interrupt_Management.Initialize;
1255
1256       --  Prepare the set of signals that should unblocked in all tasks
1257
1258       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1259       pragma Assert (Result = 0);
1260
1261       for J in Interrupt_Management.Interrupt_ID loop
1262          if System.Interrupt_Management.Keep_Unmasked (J) then
1263             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1264             pragma Assert (Result = 0);
1265          end if;
1266       end loop;
1267
1268       Curpid := getpid;
1269
1270       --  Initialize the lock used to synchronize chain of all ATCBs
1271
1272       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1273
1274       Specific.Initialize (Environment_Task);
1275
1276       Enter_Task (Environment_Task);
1277
1278       --  Install the abort-signal handler
1279
1280       if State (System.Interrupt_Management.Abort_Task_Interrupt)
1281         /= Default
1282       then
1283          act.sa_flags := 0;
1284          act.sa_handler := Abort_Handler'Address;
1285
1286          Result := sigemptyset (Tmp_Set'Access);
1287          pragma Assert (Result = 0);
1288          act.sa_mask := Tmp_Set;
1289
1290          Result :=
1291            sigaction
1292            (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1293             act'Unchecked_Access,
1294             old_act'Unchecked_Access);
1295          pragma Assert (Result = 0);
1296       end if;
1297    end Initialize;
1298
1299 end System.Task_Primitives.Operations;