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