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