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