gcc/ada/5itaprop.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-2003, 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.Initialization
  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    Priority_Ceiling_Emulation : constant Boolean := True;
 123
 124    Next_Serial_Number : Task_Serial_Number := 100;
 125    --  We start at 100, to reserve some special values for
 126    --  using in error checking.
 127    --  The following are internal configuration constants needed.
 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_Address is new Unchecked_Conversion (Task_ID, System.Address);
 193
 194    function To_pthread_t is new Unchecked_Conversion
 195      (unsigned_long, System.OS_Interface.pthread_t);
 196
 197    -------------------
 198    -- Abort_Handler --
 199    -------------------
 200
 201    procedure Abort_Handler (signo : Signal) is
 202       pragma Unreferenced (signo);
 203
 204       Self_Id : Task_ID := Self;
 205       Result  : Interfaces.C.int;
 206       Old_Set : aliased sigset_t;
 207
 208    begin
 209       if ZCX_By_Default and then GCC_ZCX_Support then
 210          return;
 211       end if;
 212
 213       if Self_Id.Deferral_Level = 0
 214         and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
 215         and then not Self_Id.Aborting
 216       then
 217          Self_Id.Aborting := True;
 218
 219          --  Make sure signals used for RTS internal purpose are unmasked
 220
 221          Result := pthread_sigmask (SIG_UNBLOCK,
 222            Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
 223          pragma Assert (Result = 0);
 224
 225          raise Standard'Abort_Signal;
 226       end if;
 227    end Abort_Handler;
 228
 229    --------------
 230    -- Lock_RTS --
 231    --------------
 232
 233    procedure Lock_RTS is
 234    begin
 235       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 236    end Lock_RTS;
 237
 238    ----------------
 239    -- Unlock_RTS --
 240    ----------------
 241
 242    procedure Unlock_RTS is
 243    begin
 244       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 245    end Unlock_RTS;
 246
 247    -----------------
 248    -- Stack_Guard --
 249    -----------------
 250
 251    --  The underlying thread system extends the memory (up to 2MB) when needed
 252
 253    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
 254       pragma Unreferenced (T);
 255       pragma Unreferenced (On);
 256
 257    begin
 258       null;
 259    end Stack_Guard;
 260
 261    --------------------
 262    -- Get_Thread_Id  --
 263    --------------------
 264
 265    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
 266    begin
 267       return T.Common.LL.Thread;
 268    end Get_Thread_Id;
 269
 270    ----------
 271    -- Self --
 272    ----------
 273
 274    function Self return Task_ID renames Specific.Self;
 275
 276    ---------------------
 277    -- Initialize_Lock --
 278    ---------------------
 279
 280    --  Note: mutexes and cond_variables needed per-task basis are
 281    --  initialized in Initialize_TCB and the Storage_Error is
 282    --  handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 283    --  used in RTS is initialized before any status change of RTS.
 284    --  Therefore rasing Storage_Error in the following routines
 285    --  should be able to be handled safely.
 286
 287    procedure Initialize_Lock
 288      (Prio : System.Any_Priority;
 289       L    : access Lock)
 290    is
 291       Result : Interfaces.C.int;
 292
 293    begin
 294       if Priority_Ceiling_Emulation then
 295          L.Ceiling := Prio;
 296       end if;
 297
 298       Result := pthread_mutex_init (L.L'Access, Mutex_Attr'Access);
 299
 300       pragma Assert (Result = 0 or else Result = ENOMEM);
 301
 302       if Result = ENOMEM then
 303          Ada.Exceptions.Raise_Exception (Storage_Error'Identity,
 304            "Failed to allocate a lock");
 305       end if;
 306    end Initialize_Lock;
 307
 308    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 309       pragma Unreferenced (Level);
 310
 311       Result : Interfaces.C.int;
 312
 313    begin
 314       Result := pthread_mutex_init (L, Mutex_Attr'Access);
 315
 316       pragma Assert (Result = 0 or else Result = ENOMEM);
 317
 318       if Result = ENOMEM then
 319          raise Storage_Error;
 320       end if;
 321    end Initialize_Lock;
 322
 323    -------------------
 324    -- Finalize_Lock --
 325    -------------------
 326
 327    procedure Finalize_Lock (L : access Lock) is
 328       Result : Interfaces.C.int;
 329
 330    begin
 331       Result := pthread_mutex_destroy (L.L'Access);
 332       pragma Assert (Result = 0);
 333    end Finalize_Lock;
 334
 335    procedure Finalize_Lock (L : access RTS_Lock) is
 336       Result : Interfaces.C.int;
 337
 338    begin
 339       Result := pthread_mutex_destroy (L);
 340       pragma Assert (Result = 0);
 341    end Finalize_Lock;
 342
 343    ----------------
 344    -- Write_Lock --
 345    ----------------
 346
 347    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 348       Result : Interfaces.C.int;
 349
 350    begin
 351       if Priority_Ceiling_Emulation then
 352          declare
 353             Self_ID : constant Task_ID := Self;
 354
 355          begin
 356             if Self_ID.Common.LL.Active_Priority > L.Ceiling then
 357                Ceiling_Violation := True;
 358                return;
 359             end if;
 360
 361             L.Saved_Priority := Self_ID.Common.LL.Active_Priority;
 362
 363             if Self_ID.Common.LL.Active_Priority < L.Ceiling then
 364                Self_ID.Common.LL.Active_Priority := L.Ceiling;
 365             end if;
 366
 367             Result := pthread_mutex_lock (L.L'Access);
 368             pragma Assert (Result = 0);
 369             Ceiling_Violation := False;
 370          end;
 371
 372       else
 373          Result := pthread_mutex_lock (L.L'Access);
 374          Ceiling_Violation := Result = EINVAL;
 375
 376          --  Assume the cause of EINVAL is a priority ceiling violation
 377
 378          pragma Assert (Result = 0 or else Result = EINVAL);
 379       end if;
 380    end Write_Lock;
 381
 382    procedure Write_Lock
 383      (L           : access RTS_Lock;
 384       Global_Lock : Boolean := False)
 385    is
 386       Result : Interfaces.C.int;
 387
 388    begin
 389       if not Single_Lock or else Global_Lock then
 390          Result := pthread_mutex_lock (L);
 391          pragma Assert (Result = 0);
 392       end if;
 393    end Write_Lock;
 394
 395    procedure Write_Lock (T : Task_ID) is
 396       Result : Interfaces.C.int;
 397
 398    begin
 399       if not Single_Lock then
 400          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 401          pragma Assert (Result = 0);
 402       end if;
 403    end Write_Lock;
 404
 405    ---------------
 406    -- Read_Lock --
 407    ---------------
 408
 409    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 410    begin
 411       Write_Lock (L, Ceiling_Violation);
 412    end Read_Lock;
 413
 414    ------------
 415    -- Unlock --
 416    ------------
 417
 418    procedure Unlock (L : access Lock) is
 419       Result : Interfaces.C.int;
 420
 421    begin
 422       if Priority_Ceiling_Emulation then
 423          declare
 424             Self_ID : constant Task_ID := Self;
 425
 426          begin
 427             Result := pthread_mutex_unlock (L.L'Access);
 428             pragma Assert (Result = 0);
 429
 430             if Self_ID.Common.LL.Active_Priority > L.Saved_Priority then
 431                Self_ID.Common.LL.Active_Priority := L.Saved_Priority;
 432             end if;
 433          end;
 434
 435       else
 436          Result := pthread_mutex_unlock (L.L'Access);
 437          pragma Assert (Result = 0);
 438       end if;
 439    end Unlock;
 440
 441    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 442       Result : Interfaces.C.int;
 443
 444    begin
 445       if not Single_Lock or else Global_Lock then
 446          Result := pthread_mutex_unlock (L);
 447          pragma Assert (Result = 0);
 448       end if;
 449    end Unlock;
 450
 451    procedure Unlock (T : Task_ID) is
 452       Result : Interfaces.C.int;
 453
 454    begin
 455       if not Single_Lock then
 456          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 457          pragma Assert (Result = 0);
 458       end if;
 459    end Unlock;
 460
 461    -----------
 462    -- Sleep --
 463    -----------
 464
 465    procedure Sleep
 466      (Self_ID  : Task_ID;
 467       Reason   : System.Tasking.Task_States)
 468    is
 469       pragma Unreferenced (Reason);
 470
 471       Result : Interfaces.C.int;
 472
 473    begin
 474       pragma Assert (Self_ID = Self);
 475
 476       if Single_Lock then
 477          Result := pthread_cond_wait
 478            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 479       else
 480          Result := pthread_cond_wait
 481            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 482       end if;
 483
 484       --  EINTR is not considered a failure.
 485       pragma Assert (Result = 0 or else Result = EINTR);
 486    end Sleep;
 487
 488    -----------------
 489    -- Timed_Sleep --
 490    -----------------
 491
 492    --  This is for use within the run-time system, so abort is
 493    --  assumed to be already deferred, and the caller should be
 494    --  holding its own ATCB lock.
 495
 496    procedure Timed_Sleep
 497      (Self_ID  : Task_ID;
 498       Time     : Duration;
 499       Mode     : ST.Delay_Modes;
 500       Reason   : System.Tasking.Task_States;
 501       Timedout : out Boolean;
 502       Yielded  : out Boolean)
 503    is
 504       pragma Unreferenced (Reason);
 505
 506       Check_Time : constant Duration := Monotonic_Clock;
 507       Abs_Time   : Duration;
 508       Request    : aliased timespec;
 509       Result     : Interfaces.C.int;
 510
 511    begin
 512       Timedout := True;
 513       Yielded := False;
 514
 515       if Mode = Relative then
 516          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 517       else
 518          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 519       end if;
 520
 521       if Abs_Time > Check_Time then
 522          Request := To_Timespec (Abs_Time);
 523
 524          loop
 525             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 526               or else Self_ID.Pending_Priority_Change;
 527
 528             if Single_Lock then
 529                Result := pthread_cond_timedwait
 530                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
 531                   Request'Access);
 532
 533             else
 534                Result := pthread_cond_timedwait
 535                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
 536                   Request'Access);
 537             end if;
 538
 539             exit when Abs_Time <= Monotonic_Clock;
 540
 541             if Result = 0 or Result = EINTR then
 542                --  somebody may have called Wakeup for us
 543                Timedout := False;
 544                exit;
 545             end if;
 546
 547             pragma Assert (Result = ETIMEDOUT);
 548          end loop;
 549       end if;
 550    end Timed_Sleep;
 551
 552    -----------------
 553    -- Timed_Delay --
 554    -----------------
 555
 556    --  This is for use in implementing delay statements, so
 557    --  we assume the caller is abort-deferred but is holding
 558    --  no locks.
 559
 560    procedure Timed_Delay
 561      (Self_ID  : Task_ID;
 562       Time     : Duration;
 563       Mode     : ST.Delay_Modes)
 564    is
 565       Check_Time : constant Duration := Monotonic_Clock;
 566       Abs_Time   : Duration;
 567       Request    : aliased timespec;
 568       Result     : Interfaces.C.int;
 569    begin
 570
 571       --  Only the little window between deferring abort and
 572       --  locking Self_ID is the reason we need to
 573       --  check for pending abort and priority change below! :(
 574
 575       SSL.Abort_Defer.all;
 576
 577       if Single_Lock then
 578          Lock_RTS;
 579       end if;
 580
 581       Write_Lock (Self_ID);
 582
 583       if Mode = Relative then
 584          Abs_Time := Time + Check_Time;
 585       else
 586          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 587       end if;
 588
 589       if Abs_Time > Check_Time then
 590          Request := To_Timespec (Abs_Time);
 591          Self_ID.Common.State := Delay_Sleep;
 592
 593          loop
 594             if Self_ID.Pending_Priority_Change then
 595                Self_ID.Pending_Priority_Change := False;
 596                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 597                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 598             end if;
 599
 600             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 601
 602             if Single_Lock then
 603                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 604                  Single_RTS_Lock'Access, Request'Access);
 605             else
 606                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 607                  Self_ID.Common.LL.L'Access, Request'Access);
 608             end if;
 609
 610             exit when Abs_Time <= Monotonic_Clock;
 611
 612             pragma Assert (Result = 0 or else
 613               Result = ETIMEDOUT or else
 614               Result = EINTR);
 615          end loop;
 616
 617          Self_ID.Common.State := Runnable;
 618       end if;
 619
 620       Unlock (Self_ID);
 621
 622       if Single_Lock then
 623          Unlock_RTS;
 624       end if;
 625
 626       Result := sched_yield;
 627       SSL.Abort_Undefer.all;
 628    end Timed_Delay;
 629
 630    ---------------------
 631    -- Monotonic_Clock --
 632    ---------------------
 633
 634    function Monotonic_Clock return Duration is
 635       TV     : aliased struct_timeval;
 636       Result : Interfaces.C.int;
 637
 638    begin
 639       Result := gettimeofday (TV'Access, System.Null_Address);
 640       pragma Assert (Result = 0);
 641       return To_Duration (TV);
 642    end Monotonic_Clock;
 643
 644    -------------------
 645    -- RT_Resolution --
 646    -------------------
 647
 648    function RT_Resolution return Duration is
 649    begin
 650       return 10#1.0#E-6;
 651    end RT_Resolution;
 652
 653    ------------
 654    -- Wakeup --
 655    ------------
 656
 657    procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
 658       pragma Unreferenced (Reason);
 659
 660       Result : Interfaces.C.int;
 661
 662    begin
 663       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 664       pragma Assert (Result = 0);
 665    end Wakeup;
 666
 667    -----------
 668    -- Yield --
 669    -----------
 670
 671    procedure Yield (Do_Yield : Boolean := True) is
 672       Result : Interfaces.C.int;
 673       pragma Unreferenced (Result);
 674
 675    begin
 676       if Do_Yield then
 677          Result := sched_yield;
 678       end if;
 679    end Yield;
 680
 681    ------------------
 682    -- Set_Priority --
 683    ------------------
 684
 685    procedure Set_Priority
 686      (T                   : Task_ID;
 687       Prio                : System.Any_Priority;
 688       Loss_Of_Inheritance : Boolean := False)
 689    is
 690       pragma Unreferenced (Loss_Of_Inheritance);
 691
 692       Result : Interfaces.C.int;
 693       Param  : aliased struct_sched_param;
 694
 695    begin
 696       T.Common.Current_Priority := Prio;
 697
 698       if Priority_Ceiling_Emulation then
 699          if T.Common.LL.Active_Priority < Prio then
 700             T.Common.LL.Active_Priority := Prio;
 701          end if;
 702       end if;
 703
 704       --  Priorities are in range 1 .. 99 on GNU/Linux, so we map
 705       --  map 0 .. 31 to 1 .. 32
 706
 707       Param.sched_priority := Interfaces.C.int (Prio) + 1;
 708
 709       if Time_Slice_Val > 0 then
 710          Result := pthread_setschedparam
 711            (T.Common.LL.Thread, SCHED_RR, Param'Access);
 712
 713       elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
 714          Result := pthread_setschedparam
 715            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 716
 717       else
 718          Result := pthread_setschedparam
 719            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 720       end if;
 721
 722       pragma Assert (Result = 0 or else Result = EPERM);
 723    end Set_Priority;
 724
 725    ------------------
 726    -- Get_Priority --
 727    ------------------
 728
 729    function Get_Priority (T : Task_ID) return System.Any_Priority is
 730    begin
 731       return T.Common.Current_Priority;
 732    end Get_Priority;
 733
 734    ----------------
 735    -- Enter_Task --
 736    ----------------
 737
 738    procedure Enter_Task (Self_ID : Task_ID) is
 739    begin
 740       Self_ID.Common.LL.Thread := pthread_self;
 741
 742       Specific.Set (Self_ID);
 743
 744       Lock_RTS;
 745
 746       for J in Known_Tasks'Range loop
 747          if Known_Tasks (J) = null then
 748             Known_Tasks (J) := Self_ID;
 749             Self_ID.Known_Tasks_Index := J;
 750             exit;
 751          end if;
 752       end loop;
 753
 754       Unlock_RTS;
 755    end Enter_Task;
 756
 757    --------------
 758    -- New_ATCB --
 759    --------------
 760
 761    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 762    begin
 763       return new Ada_Task_Control_Block (Entry_Num);
 764    end New_ATCB;
 765
 766    -------------------
 767    -- Is_Valid_Task --
 768    -------------------
 769
 770    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 771
 772    -----------------------------
 773    -- Register_Foreign_Thread --
 774    -----------------------------
 775
 776    function Register_Foreign_Thread return Task_ID is
 777    begin
 778       if Is_Valid_Task then
 779          return Self;
 780       else
 781          return Register_Foreign_Thread (pthread_self);
 782       end if;
 783    end Register_Foreign_Thread;
 784
 785    --------------------
 786    -- Initialize_TCB --
 787    --------------------
 788
 789    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 790       Result : Interfaces.C.int;
 791
 792    begin
 793       --  Give the task a unique serial number.
 794
 795       Self_ID.Serial_Number := Next_Serial_Number;
 796       Next_Serial_Number := Next_Serial_Number + 1;
 797       pragma Assert (Next_Serial_Number /= 0);
 798
 799       Self_ID.Common.LL.Thread := To_pthread_t (-1);
 800
 801       if not Single_Lock then
 802          Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
 803            Mutex_Attr'Access);
 804          pragma Assert (Result = 0 or else Result = ENOMEM);
 805
 806          if Result /= 0 then
 807             Succeeded := False;
 808             return;
 809          end if;
 810       end if;
 811
 812       Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 813         Cond_Attr'Access);
 814       pragma Assert (Result = 0 or else Result = ENOMEM);
 815
 816       if Result = 0 then
 817          Succeeded := True;
 818       else
 819          if not Single_Lock then
 820             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 821             pragma Assert (Result = 0);
 822          end if;
 823
 824          Succeeded := False;
 825       end if;
 826    end Initialize_TCB;
 827
 828    -----------------
 829    -- Create_Task --
 830    -----------------
 831
 832    procedure Create_Task
 833      (T          : Task_ID;
 834       Wrapper    : System.Address;
 835       Stack_Size : System.Parameters.Size_Type;
 836       Priority   : System.Any_Priority;
 837       Succeeded  : out Boolean)
 838    is
 839       Adjusted_Stack_Size : Interfaces.C.size_t;
 840
 841       Attributes : aliased pthread_attr_t;
 842       Result     : Interfaces.C.int;
 843
 844       function Thread_Body_Access is new
 845         Unchecked_Conversion (System.Address, Thread_Body);
 846
 847    begin
 848       if Stack_Size = Unspecified_Size then
 849          Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
 850
 851       elsif Stack_Size < Minimum_Stack_Size then
 852          Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
 853
 854       else
 855          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 856       end if;
 857
 858       Result := pthread_attr_init (Attributes'Access);
 859       pragma Assert (Result = 0 or else Result = ENOMEM);
 860
 861       if Result /= 0 then
 862          Succeeded := False;
 863          return;
 864       end if;
 865
 866       Result :=
 867         pthread_attr_setstacksize
 868           (Attributes'Access, Adjusted_Stack_Size);
 869       pragma Assert (Result = 0);
 870
 871       Result :=
 872         pthread_attr_setdetachstate
 873           (Attributes'Access, PTHREAD_CREATE_DETACHED);
 874       pragma Assert (Result = 0);
 875
 876       --  Since the initial signal mask of a thread is inherited from the
 877       --  creator, and the Environment task has all its signals masked, we
 878       --  do not need to manipulate caller's signal mask at this point.
 879       --  All tasks in RTS will have All_Tasks_Mask initially.
 880
 881       Result := pthread_create
 882         (T.Common.LL.Thread'Access,
 883          Attributes'Access,
 884          Thread_Body_Access (Wrapper),
 885          To_Address (T));
 886       pragma Assert (Result = 0 or else Result = EAGAIN);
 887
 888       Succeeded := Result = 0;
 889
 890       Result := pthread_attr_destroy (Attributes'Access);
 891       pragma Assert (Result = 0);
 892
 893       Set_Priority (T, Priority);
 894    end Create_Task;
 895
 896    ------------------
 897    -- Finalize_TCB --
 898    ------------------
 899
 900    procedure Finalize_TCB (T : Task_ID) is
 901       Result : Interfaces.C.int;
 902       Tmp    : Task_ID := T;
 903       Is_Self : constant Boolean := T = Self;
 904
 905       procedure Free is new
 906         Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
 907
 908    begin
 909       if not Single_Lock then
 910          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 911          pragma Assert (Result = 0);
 912       end if;
 913
 914       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 915       pragma Assert (Result = 0);
 916
 917       if T.Known_Tasks_Index /= -1 then
 918          Known_Tasks (T.Known_Tasks_Index) := null;
 919       end if;
 920
 921       Free (Tmp);
 922
 923       if Is_Self then
 924          Result := pthread_setspecific (ATCB_Key, System.Null_Address);
 925          pragma Assert (Result = 0);
 926       end if;
 927
 928    end Finalize_TCB;
 929
 930    ---------------
 931    -- Exit_Task --
 932    ---------------
 933
 934    procedure Exit_Task is
 935    begin
 936       Specific.Set (null);
 937    end Exit_Task;
 938
 939    ----------------
 940    -- Abort_Task --
 941    ----------------
 942
 943    procedure Abort_Task (T : Task_ID) is
 944       Result : Interfaces.C.int;
 945
 946    begin
 947       Result := pthread_kill (T.Common.LL.Thread,
 948         Signal (System.Interrupt_Management.Abort_Task_Interrupt));
 949       pragma Assert (Result = 0);
 950    end Abort_Task;
 951
 952    ----------------
 953    -- Check_Exit --
 954    ----------------
 955
 956    --  Dummy version
 957
 958    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 959       pragma Unreferenced (Self_ID);
 960
 961    begin
 962       return True;
 963    end Check_Exit;
 964
 965    --------------------
 966    -- Check_No_Locks --
 967    --------------------
 968
 969    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 970       pragma Unreferenced (Self_ID);
 971
 972    begin
 973       return True;
 974    end Check_No_Locks;
 975
 976    ----------------------
 977    -- Environment_Task --
 978    ----------------------
 979
 980    function Environment_Task return Task_ID is
 981    begin
 982       return Environment_Task_ID;
 983    end Environment_Task;
 984
 985    ------------------
 986    -- Suspend_Task --
 987    ------------------
 988
 989    function Suspend_Task
 990      (T           : ST.Task_ID;
 991       Thread_Self : Thread_Id)
 992       return        Boolean
 993    is
 994    begin
 995       if T.Common.LL.Thread /= Thread_Self then
 996          return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0;
 997       else
 998          return True;
 999       end if;
1000    end Suspend_Task;
1001
1002    -----------------
1003    -- Resume_Task --
1004    -----------------
1005
1006    function Resume_Task
1007      (T           : ST.Task_ID;
1008       Thread_Self : Thread_Id)
1009       return        Boolean
1010    is
1011    begin
1012       if T.Common.LL.Thread /= Thread_Self then
1013          return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0;
1014       else
1015          return True;
1016       end if;
1017    end Resume_Task;
1018
1019    ----------------
1020    -- Initialize --
1021    ----------------
1022
1023    procedure Initialize (Environment_Task : Task_ID) is
1024       act     : aliased struct_sigaction;
1025       old_act : aliased struct_sigaction;
1026       Tmp_Set : aliased sigset_t;
1027       Result  : Interfaces.C.int;
1028
1029       function State (Int : System.Interrupt_Management.Interrupt_ID)
1030                      return Character;
1031       pragma Import (C, State, "__gnat_get_interrupt_state");
1032       --  Get interrupt state.  Defined in a-init.c
1033       --  The input argument is the interrupt number,
1034       --  and the result is one of the following:
1035
1036       Default : constant Character := 's';
1037       --    'n'   this interrupt not set by any Interrupt_State pragma
1038       --    'u'   Interrupt_State pragma set state to User
1039       --    'r'   Interrupt_State pragma set state to Runtime
1040       --    's'   Interrupt_State pragma set state to System (use "default"
1041       --           system handler)
1042
1043    begin
1044       Environment_Task_ID := Environment_Task;
1045
1046       Result := pthread_mutexattr_init (Mutex_Attr'Access);
1047       pragma Assert (Result = 0 or else Result = ENOMEM);
1048
1049       Result := pthread_condattr_init (Cond_Attr'Access);
1050       pragma Assert (Result = 0 or else Result = ENOMEM);
1051
1052       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1053
1054       --  Initialize the global RTS lock
1055
1056       Specific.Initialize (Environment_Task);
1057
1058       Enter_Task (Environment_Task);
1059
1060       --  Install the abort-signal handler
1061
1062       if State (System.Interrupt_Management.Abort_Task_Interrupt)
1063         /= Default
1064       then
1065          act.sa_flags := 0;
1066          act.sa_handler := Abort_Handler'Address;
1067
1068          Result := sigemptyset (Tmp_Set'Access);
1069          pragma Assert (Result = 0);
1070          act.sa_mask := Tmp_Set;
1071
1072          Result :=
1073            sigaction
1074            (Signal (Interrupt_Management.Abort_Task_Interrupt),
1075             act'Unchecked_Access,
1076             old_act'Unchecked_Access);
1077          pragma Assert (Result = 0);
1078       end if;
1079    end Initialize;
1080
1081 begin
1082    declare
1083       Result : Interfaces.C.int;
1084
1085    begin
1086       --  Mask Environment task for all signals. The original mask of the
1087       --  Environment task will be recovered by Interrupt_Server task
1088       --  during the elaboration of s-interr.adb.
1089
1090       System.Interrupt_Management.Operations.Set_Interrupt_Mask
1091         (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
1092
1093       --  Prepare the set of signals that should unblocked in all tasks
1094
1095       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1096       pragma Assert (Result = 0);
1097
1098       for J in Interrupt_Management.Interrupt_ID loop
1099          if System.Interrupt_Management.Keep_Unmasked (J) then
1100             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1101             pragma Assert (Result = 0);
1102          end if;
1103       end loop;
1104    end;
1105 end System.Task_Primitives.Operations;