gcc/ada/s-taprop-linux.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS               --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-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 GNU/Linux (GNU/LinuxThreads) 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 Interfaces.C;
  44 --  used for int
  45 --           size_t
  46
  47 with System.Tasking.Debug;
  48 --  used for Known_Tasks
  49
  50 with System.Interrupt_Management;
  51 --  used for Keep_Unmasked
  52 --           Abort_Task_Interrupt
  53 --           Interrupt_ID
  54
  55 with System.OS_Primitives;
  56 --  used for Delay_Modes
  57
  58 with System.Soft_Links;
  59 --  used for Abort_Defer/Undefer
  60
  61 --  We use System.Soft_Links instead of System.Tasking.Initialization
  62 --  because the later is a higher level package that we shouldn't depend on.
  63 --  For example when using the restricted run time, it is replaced by
  64 --  System.Tasking.Restricted.Stages.
  65
  66 with Ada.Exceptions;
  67 --  used for Raise_Exception
  68 --           Raise_From_Signal_Handler
  69 --           Exception_Id
  70
  71 with Unchecked_Conversion;
  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 be unblocked in all tasks
 105
 106    --  The followings are internal configuration constants needed
 107
 108    Next_Serial_Number : Task_Serial_Number := 100;
 109    --  We start at 100, to reserve some special values for
 110    --  using in error checking.
 111
 112    Time_Slice_Val : Integer;
 113    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 114
 115    Dispatching_Policy : Character;
 116    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 117
 118    --  The following are effectively constants, but they need to
 119    --  be initialized by calling a pthread_ function.
 120
 121    Mutex_Attr   : aliased pthread_mutexattr_t;
 122    Cond_Attr    : aliased pthread_condattr_t;
 123
 124    Foreign_Task_Elaborated : aliased Boolean := True;
 125    --  Used to identified fake tasks (i.e., non-Ada Threads)
 126
 127    --------------------
 128    -- Local Packages --
 129    --------------------
 130
 131    package Specific is
 132
 133       procedure Initialize (Environment_Task : Task_Id);
 134       pragma Inline (Initialize);
 135       --  Initialize various data needed by this package
 136
 137       function Is_Valid_Task return Boolean;
 138       pragma Inline (Is_Valid_Task);
 139       --  Does executing thread have a TCB?
 140
 141       procedure Set (Self_Id : Task_Id);
 142       pragma Inline (Set);
 143       --  Set the self id for the current task
 144
 145       function Self return Task_Id;
 146       pragma Inline (Self);
 147       --  Return a pointer to the Ada Task Control Block of the calling task.
 148
 149    end Specific;
 150
 151    package body Specific is separate;
 152    --  The body of this package is target specific
 153
 154    ---------------------------------
 155    -- Support for foreign threads --
 156    ---------------------------------
 157
 158    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
 159    --  Allocate and Initialize a new ATCB for the current Thread
 160
 161    function Register_Foreign_Thread
 162      (Thread : Thread_Id) return Task_Id is separate;
 163
 164    -----------------------
 165    -- Local Subprograms --
 166    -----------------------
 167
 168    subtype unsigned_long is Interfaces.C.unsigned_long;
 169
 170    procedure Abort_Handler (signo : Signal);
 171
 172    function To_pthread_t is new Unchecked_Conversion
 173      (unsigned_long, System.OS_Interface.pthread_t);
 174
 175    -------------------
 176    -- Abort_Handler --
 177    -------------------
 178
 179    procedure Abort_Handler (signo : Signal) is
 180       pragma Unreferenced (signo);
 181
 182       Self_Id : constant Task_Id := Self;
 183       Result  : Interfaces.C.int;
 184       Old_Set : aliased sigset_t;
 185
 186    begin
 187       if ZCX_By_Default and then GCC_ZCX_Support then
 188          return;
 189       end if;
 190
 191       if Self_Id.Deferral_Level = 0
 192         and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
 193         and then not Self_Id.Aborting
 194       then
 195          Self_Id.Aborting := True;
 196
 197          --  Make sure signals used for RTS internal purpose are unmasked
 198
 199          Result := pthread_sigmask (SIG_UNBLOCK,
 200            Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
 201          pragma Assert (Result = 0);
 202
 203          raise Standard'Abort_Signal;
 204       end if;
 205    end Abort_Handler;
 206
 207    --------------
 208    -- Lock_RTS --
 209    --------------
 210
 211    procedure Lock_RTS is
 212    begin
 213       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 214    end Lock_RTS;
 215
 216    ----------------
 217    -- Unlock_RTS --
 218    ----------------
 219
 220    procedure Unlock_RTS is
 221    begin
 222       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 223    end Unlock_RTS;
 224
 225    -----------------
 226    -- Stack_Guard --
 227    -----------------
 228
 229    --  The underlying thread system extends the memory (up to 2MB) when needed
 230
 231    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 232       pragma Unreferenced (T);
 233       pragma Unreferenced (On);
 234    begin
 235       null;
 236    end Stack_Guard;
 237
 238    --------------------
 239    -- Get_Thread_Id  --
 240    --------------------
 241
 242    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 243    begin
 244       return T.Common.LL.Thread;
 245    end Get_Thread_Id;
 246
 247    ----------
 248    -- Self --
 249    ----------
 250
 251    function Self return Task_Id renames Specific.Self;
 252
 253    ---------------------
 254    -- Initialize_Lock --
 255    ---------------------
 256
 257    --  Note: mutexes and cond_variables needed per-task basis are
 258    --  initialized in Initialize_TCB and the Storage_Error is
 259    --  handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 260    --  used in RTS is initialized before any status change of RTS.
 261    --  Therefore rasing Storage_Error in the following routines
 262    --  should be able to be handled safely.
 263
 264    procedure Initialize_Lock
 265      (Prio : System.Any_Priority;
 266       L    : access Lock)
 267    is
 268       pragma Unreferenced (Prio);
 269
 270       Result : Interfaces.C.int;
 271    begin
 272       Result := pthread_mutex_init (L, Mutex_Attr'Access);
 273
 274       pragma Assert (Result = 0 or else Result = ENOMEM);
 275
 276       if Result = ENOMEM then
 277          Ada.Exceptions.Raise_Exception (Storage_Error'Identity,
 278            "Failed to allocate a lock");
 279       end if;
 280    end Initialize_Lock;
 281
 282    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 283       pragma Unreferenced (Level);
 284
 285       Result : Interfaces.C.int;
 286
 287    begin
 288       Result := pthread_mutex_init (L, Mutex_Attr'Access);
 289
 290       pragma Assert (Result = 0 or else Result = ENOMEM);
 291
 292       if Result = ENOMEM then
 293          raise Storage_Error;
 294       end if;
 295    end Initialize_Lock;
 296
 297    -------------------
 298    -- Finalize_Lock --
 299    -------------------
 300
 301    procedure Finalize_Lock (L : access Lock) is
 302       Result : Interfaces.C.int;
 303    begin
 304       Result := pthread_mutex_destroy (L);
 305       pragma Assert (Result = 0);
 306    end Finalize_Lock;
 307
 308    procedure Finalize_Lock (L : access RTS_Lock) is
 309       Result : Interfaces.C.int;
 310    begin
 311       Result := pthread_mutex_destroy (L);
 312       pragma Assert (Result = 0);
 313    end Finalize_Lock;
 314
 315    ----------------
 316    -- Write_Lock --
 317    ----------------
 318
 319    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 320       Result : Interfaces.C.int;
 321    begin
 322       Result := pthread_mutex_lock (L);
 323       Ceiling_Violation := Result = EINVAL;
 324
 325       --  Assume the cause of EINVAL is a priority ceiling violation
 326
 327       pragma Assert (Result = 0 or else Result = EINVAL);
 328    end Write_Lock;
 329
 330    procedure Write_Lock
 331      (L           : access RTS_Lock;
 332       Global_Lock : Boolean := False)
 333    is
 334       Result : Interfaces.C.int;
 335    begin
 336       if not Single_Lock or else Global_Lock then
 337          Result := pthread_mutex_lock (L);
 338          pragma Assert (Result = 0);
 339       end if;
 340    end Write_Lock;
 341
 342    procedure Write_Lock (T : Task_Id) is
 343       Result : Interfaces.C.int;
 344    begin
 345       if not Single_Lock then
 346          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 347          pragma Assert (Result = 0);
 348       end if;
 349    end Write_Lock;
 350
 351    ---------------
 352    -- Read_Lock --
 353    ---------------
 354
 355    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 356    begin
 357       Write_Lock (L, Ceiling_Violation);
 358    end Read_Lock;
 359
 360    ------------
 361    -- Unlock --
 362    ------------
 363
 364    procedure Unlock (L : access Lock) is
 365       Result : Interfaces.C.int;
 366    begin
 367       Result := pthread_mutex_unlock (L);
 368       pragma Assert (Result = 0);
 369    end Unlock;
 370
 371    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 372       Result : Interfaces.C.int;
 373    begin
 374       if not Single_Lock or else Global_Lock then
 375          Result := pthread_mutex_unlock (L);
 376          pragma Assert (Result = 0);
 377       end if;
 378    end Unlock;
 379
 380    procedure Unlock (T : Task_Id) is
 381       Result : Interfaces.C.int;
 382    begin
 383       if not Single_Lock then
 384          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 385          pragma Assert (Result = 0);
 386       end if;
 387    end Unlock;
 388
 389    -----------
 390    -- Sleep --
 391    -----------
 392
 393    procedure Sleep
 394      (Self_ID  : Task_Id;
 395       Reason   : System.Tasking.Task_States)
 396    is
 397       pragma Unreferenced (Reason);
 398
 399       Result : Interfaces.C.int;
 400
 401    begin
 402       pragma Assert (Self_ID = Self);
 403
 404       if Single_Lock then
 405          Result := pthread_cond_wait
 406            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 407       else
 408          Result := pthread_cond_wait
 409            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 410       end if;
 411
 412       --  EINTR is not considered a failure
 413
 414       pragma Assert (Result = 0 or else Result = EINTR);
 415    end Sleep;
 416
 417    -----------------
 418    -- Timed_Sleep --
 419    -----------------
 420
 421    --  This is for use within the run-time system, so abort is
 422    --  assumed to be already deferred, and the caller should be
 423    --  holding its own ATCB lock.
 424
 425    procedure Timed_Sleep
 426      (Self_ID  : Task_Id;
 427       Time     : Duration;
 428       Mode     : ST.Delay_Modes;
 429       Reason   : System.Tasking.Task_States;
 430       Timedout : out Boolean;
 431       Yielded  : out Boolean)
 432    is
 433       pragma Unreferenced (Reason);
 434
 435       Check_Time : constant Duration := Monotonic_Clock;
 436       Abs_Time   : Duration;
 437       Request    : aliased timespec;
 438       Result     : Interfaces.C.int;
 439
 440    begin
 441       Timedout := True;
 442       Yielded := False;
 443
 444       if Mode = Relative then
 445          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 446       else
 447          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 448       end if;
 449
 450       if Abs_Time > Check_Time then
 451          Request := To_Timespec (Abs_Time);
 452
 453          loop
 454             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 455               or else Self_ID.Pending_Priority_Change;
 456
 457             if Single_Lock then
 458                Result := pthread_cond_timedwait
 459                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
 460                   Request'Access);
 461
 462             else
 463                Result := pthread_cond_timedwait
 464                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
 465                   Request'Access);
 466             end if;
 467
 468             exit when Abs_Time <= Monotonic_Clock;
 469
 470             if Result = 0 or Result = EINTR then
 471                --  somebody may have called Wakeup for us
 472                Timedout := False;
 473                exit;
 474             end if;
 475
 476             pragma Assert (Result = ETIMEDOUT);
 477          end loop;
 478       end if;
 479    end Timed_Sleep;
 480
 481    -----------------
 482    -- Timed_Delay --
 483    -----------------
 484
 485    --  This is for use in implementing delay statements, so
 486    --  we assume the caller is abort-deferred but is holding
 487    --  no locks.
 488
 489    procedure Timed_Delay
 490      (Self_ID  : Task_Id;
 491       Time     : Duration;
 492       Mode     : ST.Delay_Modes)
 493    is
 494       Check_Time : constant Duration := Monotonic_Clock;
 495       Abs_Time   : Duration;
 496       Request    : aliased timespec;
 497       Result     : Interfaces.C.int;
 498
 499    begin
 500       if Single_Lock then
 501          Lock_RTS;
 502       end if;
 503
 504       Write_Lock (Self_ID);
 505
 506       if Mode = Relative then
 507          Abs_Time := Time + Check_Time;
 508       else
 509          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 510       end if;
 511
 512       if Abs_Time > Check_Time then
 513          Request := To_Timespec (Abs_Time);
 514          Self_ID.Common.State := Delay_Sleep;
 515
 516          loop
 517             if Self_ID.Pending_Priority_Change then
 518                Self_ID.Pending_Priority_Change := False;
 519                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 520                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 521             end if;
 522
 523             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 524
 525             if Single_Lock then
 526                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 527                  Single_RTS_Lock'Access, Request'Access);
 528             else
 529                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 530                  Self_ID.Common.LL.L'Access, Request'Access);
 531             end if;
 532
 533             exit when Abs_Time <= Monotonic_Clock;
 534
 535             pragma Assert (Result = 0 or else
 536               Result = ETIMEDOUT or else
 537               Result = EINTR);
 538          end loop;
 539
 540          Self_ID.Common.State := Runnable;
 541       end if;
 542
 543       Unlock (Self_ID);
 544
 545       if Single_Lock then
 546          Unlock_RTS;
 547       end if;
 548
 549       Result := sched_yield;
 550    end Timed_Delay;
 551
 552    ---------------------
 553    -- Monotonic_Clock --
 554    ---------------------
 555
 556    function Monotonic_Clock return Duration is
 557       TV     : aliased struct_timeval;
 558       Result : Interfaces.C.int;
 559    begin
 560       Result := gettimeofday (TV'Access, System.Null_Address);
 561       pragma Assert (Result = 0);
 562       return To_Duration (TV);
 563    end Monotonic_Clock;
 564
 565    -------------------
 566    -- RT_Resolution --
 567    -------------------
 568
 569    function RT_Resolution return Duration is
 570    begin
 571       return 10#1.0#E-6;
 572    end RT_Resolution;
 573
 574    ------------
 575    -- Wakeup --
 576    ------------
 577
 578    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 579       pragma Unreferenced (Reason);
 580       Result : Interfaces.C.int;
 581    begin
 582       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 583       pragma Assert (Result = 0);
 584    end Wakeup;
 585
 586    -----------
 587    -- Yield --
 588    -----------
 589
 590    procedure Yield (Do_Yield : Boolean := True) is
 591       Result : Interfaces.C.int;
 592       pragma Unreferenced (Result);
 593    begin
 594       if Do_Yield then
 595          Result := sched_yield;
 596       end if;
 597    end Yield;
 598
 599    ------------------
 600    -- Set_Priority --
 601    ------------------
 602
 603    procedure Set_Priority
 604      (T                   : Task_Id;
 605       Prio                : System.Any_Priority;
 606       Loss_Of_Inheritance : Boolean := False)
 607    is
 608       pragma Unreferenced (Loss_Of_Inheritance);
 609
 610       Result : Interfaces.C.int;
 611       Param  : aliased struct_sched_param;
 612
 613    begin
 614       T.Common.Current_Priority := Prio;
 615
 616       --  Priorities are in range 1 .. 99 on GNU/Linux, so we map
 617       --  map 0 .. 31 to 1 .. 32
 618
 619       Param.sched_priority := Interfaces.C.int (Prio) + 1;
 620
 621       if Time_Slice_Val > 0 then
 622          Result := pthread_setschedparam
 623            (T.Common.LL.Thread, SCHED_RR, Param'Access);
 624
 625       elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
 626          Result := pthread_setschedparam
 627            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 628
 629       else
 630          Param.sched_priority := 0;
 631          Result := pthread_setschedparam
 632            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 633       end if;
 634
 635       pragma Assert (Result = 0 or else Result = EPERM);
 636    end Set_Priority;
 637
 638    ------------------
 639    -- Get_Priority --
 640    ------------------
 641
 642    function Get_Priority (T : Task_Id) return System.Any_Priority is
 643    begin
 644       return T.Common.Current_Priority;
 645    end Get_Priority;
 646
 647    ----------------
 648    -- Enter_Task --
 649    ----------------
 650
 651    procedure Enter_Task (Self_ID : Task_Id) is
 652    begin
 653       Self_ID.Common.LL.Thread := pthread_self;
 654
 655       Specific.Set (Self_ID);
 656
 657       Lock_RTS;
 658
 659       for J in Known_Tasks'Range loop
 660          if Known_Tasks (J) = null then
 661             Known_Tasks (J) := Self_ID;
 662             Self_ID.Known_Tasks_Index := J;
 663             exit;
 664          end if;
 665       end loop;
 666
 667       Unlock_RTS;
 668    end Enter_Task;
 669
 670    --------------
 671    -- New_ATCB --
 672    --------------
 673
 674    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 675    begin
 676       return new Ada_Task_Control_Block (Entry_Num);
 677    end New_ATCB;
 678
 679    -------------------
 680    -- Is_Valid_Task --
 681    -------------------
 682
 683    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 684
 685    -----------------------------
 686    -- Register_Foreign_Thread --
 687    -----------------------------
 688
 689    function Register_Foreign_Thread return Task_Id is
 690    begin
 691       if Is_Valid_Task then
 692          return Self;
 693       else
 694          return Register_Foreign_Thread (pthread_self);
 695       end if;
 696    end Register_Foreign_Thread;
 697
 698    --------------------
 699    -- Initialize_TCB --
 700    --------------------
 701
 702    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 703       Result : Interfaces.C.int;
 704
 705    begin
 706       --  Give the task a unique serial number
 707
 708       Self_ID.Serial_Number := Next_Serial_Number;
 709       Next_Serial_Number := Next_Serial_Number + 1;
 710       pragma Assert (Next_Serial_Number /= 0);
 711
 712       Self_ID.Common.LL.Thread := To_pthread_t (-1);
 713
 714       if not Single_Lock then
 715          Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
 716            Mutex_Attr'Access);
 717          pragma Assert (Result = 0 or else Result = ENOMEM);
 718
 719          if Result /= 0 then
 720             Succeeded := False;
 721             return;
 722          end if;
 723       end if;
 724
 725       Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 726         Cond_Attr'Access);
 727       pragma Assert (Result = 0 or else Result = ENOMEM);
 728
 729       if Result = 0 then
 730          Succeeded := True;
 731       else
 732          if not Single_Lock then
 733             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 734             pragma Assert (Result = 0);
 735          end if;
 736
 737          Succeeded := False;
 738       end if;
 739    end Initialize_TCB;
 740
 741    -----------------
 742    -- Create_Task --
 743    -----------------
 744
 745    procedure Create_Task
 746      (T          : Task_Id;
 747       Wrapper    : System.Address;
 748       Stack_Size : System.Parameters.Size_Type;
 749       Priority   : System.Any_Priority;
 750       Succeeded  : out Boolean)
 751    is
 752       Attributes : aliased pthread_attr_t;
 753       Result     : Interfaces.C.int;
 754
 755    begin
 756       Result := pthread_attr_init (Attributes'Access);
 757       pragma Assert (Result = 0 or else Result = ENOMEM);
 758
 759       if Result /= 0 then
 760          Succeeded := False;
 761          return;
 762       end if;
 763
 764       Result :=
 765         pthread_attr_setstacksize
 766           (Attributes'Access, Interfaces.C.size_t (Stack_Size));
 767       pragma Assert (Result = 0);
 768
 769       Result :=
 770         pthread_attr_setdetachstate
 771           (Attributes'Access, PTHREAD_CREATE_DETACHED);
 772       pragma Assert (Result = 0);
 773
 774       --  Since the initial signal mask of a thread is inherited from the
 775       --  creator, and the Environment task has all its signals masked, we
 776       --  do not need to manipulate caller's signal mask at this point.
 777       --  All tasks in RTS will have All_Tasks_Mask initially.
 778
 779       Result := pthread_create
 780         (T.Common.LL.Thread'Access,
 781          Attributes'Access,
 782          Thread_Body_Access (Wrapper),
 783          To_Address (T));
 784       pragma Assert (Result = 0 or else Result = EAGAIN);
 785
 786       Succeeded := Result = 0;
 787
 788       Result := pthread_attr_destroy (Attributes'Access);
 789       pragma Assert (Result = 0);
 790
 791       Set_Priority (T, Priority);
 792    end Create_Task;
 793
 794    ------------------
 795    -- Finalize_TCB --
 796    ------------------
 797
 798    procedure Finalize_TCB (T : Task_Id) is
 799       Result  : Interfaces.C.int;
 800       Tmp     : Task_Id := T;
 801       Is_Self : constant Boolean := T = Self;
 802
 803       procedure Free is new
 804         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 805
 806    begin
 807       if not Single_Lock then
 808          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 809          pragma Assert (Result = 0);
 810       end if;
 811
 812       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 813       pragma Assert (Result = 0);
 814
 815       if T.Known_Tasks_Index /= -1 then
 816          Known_Tasks (T.Known_Tasks_Index) := null;
 817       end if;
 818
 819       Free (Tmp);
 820
 821       if Is_Self then
 822          Specific.Set (null);
 823       end if;
 824    end Finalize_TCB;
 825
 826    ---------------
 827    -- Exit_Task --
 828    ---------------
 829
 830    procedure Exit_Task is
 831    begin
 832       Specific.Set (null);
 833    end Exit_Task;
 834
 835    ----------------
 836    -- Abort_Task --
 837    ----------------
 838
 839    procedure Abort_Task (T : Task_Id) is
 840       Result : Interfaces.C.int;
 841    begin
 842       Result := pthread_kill (T.Common.LL.Thread,
 843         Signal (System.Interrupt_Management.Abort_Task_Interrupt));
 844       pragma Assert (Result = 0);
 845    end Abort_Task;
 846
 847    ----------------
 848    -- Initialize --
 849    ----------------
 850
 851    procedure Initialize (S : in out Suspension_Object) is
 852       Result : Interfaces.C.int;
 853    begin
 854       --  Initialize internal state. It is always initialized to False (ARM
 855       --  D.10 par. 6).
 856
 857       S.State := False;
 858       S.Waiting := False;
 859
 860       --  Initialize internal mutex
 861
 862       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
 863
 864       pragma Assert (Result = 0 or else Result = ENOMEM);
 865
 866       if Result = ENOMEM then
 867          raise Storage_Error;
 868       end if;
 869
 870       --  Initialize internal condition variable
 871
 872       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
 873
 874       pragma Assert (Result = 0 or else Result = ENOMEM);
 875
 876       if Result /= 0 then
 877          Result := pthread_mutex_destroy (S.L'Access);
 878          pragma Assert (Result = 0);
 879
 880          if Result = ENOMEM then
 881             raise Storage_Error;
 882          end if;
 883       end if;
 884    end Initialize;
 885
 886    --------------
 887    -- Finalize --
 888    --------------
 889
 890    procedure Finalize (S : in out Suspension_Object) is
 891       Result  : Interfaces.C.int;
 892    begin
 893       --  Destroy internal mutex
 894
 895       Result := pthread_mutex_destroy (S.L'Access);
 896       pragma Assert (Result = 0);
 897
 898       --  Destroy internal condition variable
 899
 900       Result := pthread_cond_destroy (S.CV'Access);
 901       pragma Assert (Result = 0);
 902    end Finalize;
 903
 904    -------------------
 905    -- Current_State --
 906    -------------------
 907
 908    function Current_State (S : Suspension_Object) return Boolean is
 909    begin
 910       --  We do not want to use lock on this read operation. State is marked
 911       --  as Atomic so that we ensure that the value retrieved is correct.
 912
 913       return S.State;
 914    end Current_State;
 915
 916    ---------------
 917    -- Set_False --
 918    ---------------
 919
 920    procedure Set_False (S : in out Suspension_Object) is
 921       Result  : Interfaces.C.int;
 922    begin
 923       SSL.Abort_Defer.all;
 924
 925       Result := pthread_mutex_lock (S.L'Access);
 926       pragma Assert (Result = 0);
 927
 928       S.State := False;
 929
 930       Result := pthread_mutex_unlock (S.L'Access);
 931       pragma Assert (Result = 0);
 932
 933       SSL.Abort_Undefer.all;
 934    end Set_False;
 935
 936    --------------
 937    -- Set_True --
 938    --------------
 939
 940    procedure Set_True (S : in out Suspension_Object) is
 941       Result : Interfaces.C.int;
 942    begin
 943       SSL.Abort_Defer.all;
 944
 945       Result := pthread_mutex_lock (S.L'Access);
 946       pragma Assert (Result = 0);
 947
 948       --  If there is already a task waiting on this suspension object then
 949       --  we resume it, leaving the state of the suspension object to False,
 950       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
 951       --  the state to True.
 952
 953       if S.Waiting then
 954          S.Waiting := False;
 955          S.State := False;
 956
 957          Result := pthread_cond_signal (S.CV'Access);
 958          pragma Assert (Result = 0);
 959       else
 960          S.State := True;
 961       end if;
 962
 963       Result := pthread_mutex_unlock (S.L'Access);
 964       pragma Assert (Result = 0);
 965
 966       SSL.Abort_Undefer.all;
 967    end Set_True;
 968
 969    ------------------------
 970    -- Suspend_Until_True --
 971    ------------------------
 972
 973    procedure Suspend_Until_True (S : in out Suspension_Object) is
 974       Result : Interfaces.C.int;
 975    begin
 976       SSL.Abort_Defer.all;
 977
 978       Result := pthread_mutex_lock (S.L'Access);
 979       pragma Assert (Result = 0);
 980
 981       if S.Waiting then
 982          --  Program_Error must be raised upon calling Suspend_Until_True
 983          --  if another task is already waiting on that suspension object
 984          --  (ARM D.10 par. 10).
 985
 986          Result := pthread_mutex_unlock (S.L'Access);
 987          pragma Assert (Result = 0);
 988
 989          SSL.Abort_Undefer.all;
 990
 991          raise Program_Error;
 992       else
 993          --  Suspend the task if the state is False. Otherwise, the task
 994          --  continues its execution, and the state of the suspension object
 995          --  is set to False (ARM D.10 par. 9).
 996
 997          if S.State then
 998             S.State := False;
 999          else
1000             S.Waiting := True;
1001             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1002          end if;
1003
1004          Result := pthread_mutex_unlock (S.L'Access);
1005          pragma Assert (Result = 0);
1006
1007          SSL.Abort_Undefer.all;
1008       end if;
1009    end Suspend_Until_True;
1010
1011    ----------------
1012    -- Check_Exit --
1013    ----------------
1014
1015    --  Dummy version
1016
1017    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1018       pragma Unreferenced (Self_ID);
1019    begin
1020       return True;
1021    end Check_Exit;
1022
1023    --------------------
1024    -- Check_No_Locks --
1025    --------------------
1026
1027    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1028       pragma Unreferenced (Self_ID);
1029    begin
1030       return True;
1031    end Check_No_Locks;
1032
1033    ----------------------
1034    -- Environment_Task --
1035    ----------------------
1036
1037    function Environment_Task return Task_Id is
1038    begin
1039       return Environment_Task_Id;
1040    end Environment_Task;
1041
1042    ------------------
1043    -- Suspend_Task --
1044    ------------------
1045
1046    function Suspend_Task
1047      (T           : ST.Task_Id;
1048       Thread_Self : Thread_Id) return Boolean
1049    is
1050    begin
1051       if T.Common.LL.Thread /= Thread_Self then
1052          return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0;
1053       else
1054          return True;
1055       end if;
1056    end Suspend_Task;
1057
1058    -----------------
1059    -- Resume_Task --
1060    -----------------
1061
1062    function Resume_Task
1063      (T           : ST.Task_Id;
1064       Thread_Self : Thread_Id) return Boolean
1065    is
1066    begin
1067       if T.Common.LL.Thread /= Thread_Self then
1068          return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0;
1069       else
1070          return True;
1071       end if;
1072    end Resume_Task;
1073
1074    ----------------
1075    -- Initialize --
1076    ----------------
1077
1078    procedure Initialize (Environment_Task : Task_Id) is
1079       act     : aliased struct_sigaction;
1080       old_act : aliased struct_sigaction;
1081       Tmp_Set : aliased sigset_t;
1082       Result  : Interfaces.C.int;
1083
1084       function State
1085         (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1086       pragma Import (C, State, "__gnat_get_interrupt_state");
1087       --  Get interrupt state.  Defined in a-init.c
1088       --  The input argument is the interrupt number,
1089       --  and the result is one of the following:
1090
1091       Default : constant Character := 's';
1092       --    'n'   this interrupt not set by any Interrupt_State pragma
1093       --    'u'   Interrupt_State pragma set state to User
1094       --    'r'   Interrupt_State pragma set state to Runtime
1095       --    's'   Interrupt_State pragma set state to System (use "default"
1096       --           system handler)
1097
1098    begin
1099       Environment_Task_Id := Environment_Task;
1100
1101       Interrupt_Management.Initialize;
1102
1103       --  Prepare the set of signals that should be unblocked in all tasks
1104
1105       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1106       pragma Assert (Result = 0);
1107
1108       for J in Interrupt_Management.Interrupt_ID loop
1109          if System.Interrupt_Management.Keep_Unmasked (J) then
1110             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1111             pragma Assert (Result = 0);
1112          end if;
1113       end loop;
1114
1115       Result := pthread_mutexattr_init (Mutex_Attr'Access);
1116       pragma Assert (Result = 0);
1117
1118       Result := pthread_condattr_init (Cond_Attr'Access);
1119       pragma Assert (Result = 0);
1120
1121       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1122
1123       --  Initialize the global RTS lock
1124
1125       Specific.Initialize (Environment_Task);
1126
1127       Enter_Task (Environment_Task);
1128
1129       --  Install the abort-signal handler
1130
1131       if State (System.Interrupt_Management.Abort_Task_Interrupt)
1132         /= Default
1133       then
1134          act.sa_flags := 0;
1135          act.sa_handler := Abort_Handler'Address;
1136
1137          Result := sigemptyset (Tmp_Set'Access);
1138          pragma Assert (Result = 0);
1139          act.sa_mask := Tmp_Set;
1140
1141          Result :=
1142            sigaction
1143            (Signal (Interrupt_Management.Abort_Task_Interrupt),
1144             act'Unchecked_Access,
1145             old_act'Unchecked_Access);
1146          pragma Assert (Result = 0);
1147       end if;
1148    end Initialize;
1149
1150 end System.Task_Primitives.Operations;