gcc/ada/5ataprop.adb

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