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