gcc/ada/5gtaprop.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-2004, 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 an Irix (old athread library) 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 Interfaces.C;
  44 --  used for int
  45 --           size_t
  46
  47 with System.Tasking.Debug;
  48 --  used for Known_Tasks
  49
  50 with System.Task_Info;
  51
  52 with System.Interrupt_Management;
  53 --  used for Keep_Unmasked
  54 --           Abort_Task_Interrupt
  55 --           Interrupt_ID
  56
  57 with System.Parameters;
  58 --  used for Size_Type
  59
  60 with System.Tasking;
  61 --  used for Ada_Task_Control_Block
  62 --           Task_ID
  63
  64 with System.Program_Info;
  65 --  used for Default_Task_Stack
  66 --           Default_Time_Slice
  67 --           Stack_Guard_Pages
  68 --           Pthread_Sched_Signal
  69 --           Pthread_Arena_Size
  70
  71 with System.Soft_Links;
  72 --  used for Defer/Undefer_Abort
  73
  74 --  Note that we do not use System.Tasking.Initialization directly since
  75 --  this is a higher level package that we shouldn't depend on. For example
  76 --  when using the restricted run time, it is replaced by
  77 --  System.Tasking.Restricted.Initialization
  78
  79 with System.OS_Primitives;
  80 --  used for Delay_Modes
  81
  82 with System.Storage_Elements;
  83 --  used for To_Address
  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    Environment_Task_ID : Task_ID;
 112    --  A variable to hold Task_ID for the environment task.
 113
 114    Locking_Policy : Character;
 115    pragma Import (C, Locking_Policy, "__gl_locking_policy");
 116
 117    Clock_Address : constant System.Address :=
 118      System.Storage_Elements.To_Address (16#200F90#);
 119
 120    RT_Clock_Id : clockid_t;
 121    for RT_Clock_Id'Address use Clock_Address;
 122
 123    -----------------------
 124    -- Local Subprograms --
 125    -----------------------
 126
 127    procedure Initialize_Athread_Library;
 128
 129    function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
 130
 131    function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
 132
 133    -------------------
 134    --  Stack_Guard  --
 135    -------------------
 136
 137    --  The underlying thread system sets a guard page at the
 138    --  bottom of a thread stack, so nothing is needed.
 139    --  ??? Check the comment above
 140
 141    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
 142       pragma Unreferenced (T);
 143       pragma Unreferenced (On);
 144
 145    begin
 146       null;
 147    end Stack_Guard;
 148
 149    --------------------
 150    -- Get_Thread_Id  --
 151    --------------------
 152
 153    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
 154    begin
 155       return T.Common.LL.Thread;
 156    end Get_Thread_Id;
 157
 158    ----------
 159    -- Self --
 160    ----------
 161
 162    function Self return Task_ID is
 163    begin
 164       return To_Task_ID (pthread_get_current_ada_tcb);
 165    end Self;
 166
 167    ---------------------
 168    -- Initialize_Lock --
 169    ---------------------
 170
 171    --  Note: mutexes and cond_variables needed per-task basis are
 172    --        initialized in Initialize_TCB and the Storage_Error is
 173    --        handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 174    --        used in RTS is initialized before any status change of RTS.
 175    --        Therefore rasing Storage_Error in the following routines
 176    --        should be able to be handled safely.
 177
 178    procedure Initialize_Lock
 179      (Prio : System.Any_Priority;
 180       L    : access Lock)
 181    is
 182       Attributes : aliased pthread_mutexattr_t;
 183       Result     : Interfaces.C.int;
 184
 185    begin
 186       Result := pthread_mutexattr_init (Attributes'Access);
 187
 188       if Result = FUNC_ERR then
 189          raise Storage_Error;
 190       end if;
 191
 192       if Locking_Policy = 'C' then
 193
 194          Result := pthread_mutexattr_setqueueorder
 195            (Attributes'Access, MUTEX_PRIORITY_CEILING);
 196
 197          pragma Assert (Result /= FUNC_ERR);
 198
 199          Result := pthread_mutexattr_setceilingprio
 200             (Attributes'Access, Interfaces.C.int (Prio));
 201
 202          pragma Assert (Result /= FUNC_ERR);
 203       end if;
 204
 205       Result := pthread_mutex_init (L, Attributes'Access);
 206
 207       if Result = FUNC_ERR then
 208          Result := pthread_mutexattr_destroy (Attributes'Access);
 209          raise Storage_Error;
 210       end if;
 211
 212       Result := pthread_mutexattr_destroy (Attributes'Access);
 213    end Initialize_Lock;
 214
 215    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 216       pragma Unreferenced (Level);
 217
 218       Attributes : aliased pthread_mutexattr_t;
 219       Result : Interfaces.C.int;
 220
 221    begin
 222       Result := pthread_mutexattr_init (Attributes'Access);
 223
 224       if Result = FUNC_ERR then
 225          raise Storage_Error;
 226       end if;
 227
 228       if Locking_Policy = 'C' then
 229          Result := pthread_mutexattr_setqueueorder
 230            (Attributes'Access, MUTEX_PRIORITY_CEILING);
 231          pragma Assert (Result /= FUNC_ERR);
 232
 233          Result := pthread_mutexattr_setceilingprio
 234             (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
 235          pragma Assert (Result /= FUNC_ERR);
 236       end if;
 237
 238       Result := pthread_mutex_init (L, Attributes'Access);
 239
 240       if Result = FUNC_ERR then
 241          Result := pthread_mutexattr_destroy (Attributes'Access);
 242          raise Storage_Error;
 243       end if;
 244
 245       Result := pthread_mutexattr_destroy (Attributes'Access);
 246    end Initialize_Lock;
 247
 248    -------------------
 249    -- Finalize_Lock --
 250    -------------------
 251
 252    procedure Finalize_Lock (L : access Lock) is
 253       Result : Interfaces.C.int;
 254
 255    begin
 256       Result := pthread_mutex_destroy (L);
 257       pragma Assert (Result = 0);
 258    end Finalize_Lock;
 259
 260    procedure Finalize_Lock (L : access RTS_Lock) is
 261       Result : Interfaces.C.int;
 262
 263    begin
 264       Result := pthread_mutex_destroy (L);
 265       pragma Assert (Result = 0);
 266    end Finalize_Lock;
 267
 268    ----------------
 269    -- Write_Lock --
 270    ----------------
 271
 272    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 273       Result : Interfaces.C.int;
 274
 275    begin
 276       Result := pthread_mutex_lock (L);
 277
 278       Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL;
 279       pragma Assert (Result /= FUNC_ERR);
 280    end Write_Lock;
 281
 282    procedure Write_Lock
 283      (L : access RTS_Lock; Global_Lock : Boolean := False)
 284    is
 285       Result : Interfaces.C.int;
 286
 287    begin
 288       if not Single_Lock or else Global_Lock then
 289          Result := pthread_mutex_lock (L);
 290          pragma Assert (Result = 0);
 291       end if;
 292    end Write_Lock;
 293
 294    procedure Write_Lock (T : Task_ID) is
 295       Result : Interfaces.C.int;
 296
 297    begin
 298       if not Single_Lock then
 299          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 300          pragma Assert (Result = 0);
 301       end if;
 302    end Write_Lock;
 303
 304    ---------------
 305    -- Read_Lock --
 306    ---------------
 307
 308    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 309    begin
 310       Write_Lock (L, Ceiling_Violation);
 311    end Read_Lock;
 312
 313    ------------
 314    -- Unlock --
 315    ------------
 316
 317    procedure Unlock (L : access Lock) is
 318       Result : Interfaces.C.int;
 319
 320    begin
 321       Result := pthread_mutex_unlock (L);
 322       pragma Assert (Result = 0);
 323    end Unlock;
 324
 325    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 326       Result : Interfaces.C.int;
 327
 328    begin
 329       if not Single_Lock or else Global_Lock then
 330          Result := pthread_mutex_unlock (L);
 331          pragma Assert (Result = 0);
 332       end if;
 333    end Unlock;
 334
 335    procedure Unlock (T : Task_ID) is
 336       Result : Interfaces.C.int;
 337
 338    begin
 339       if not Single_Lock then
 340          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 341          pragma Assert (Result = 0);
 342       end if;
 343    end Unlock;
 344
 345    -----------
 346    -- Sleep --
 347    -----------
 348
 349    procedure Sleep
 350      (Self_ID  : ST.Task_ID;
 351       Reason   : System.Tasking.Task_States)
 352    is
 353       pragma Unreferenced (Reason);
 354
 355       Result : Interfaces.C.int;
 356
 357    begin
 358       if Single_Lock then
 359          Result := pthread_cond_wait
 360            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 361       else
 362          Result := pthread_cond_wait
 363            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 364       end if;
 365
 366       --  EINTR is not considered a failure.
 367
 368       pragma Assert (Result = 0 or else Result = EINTR);
 369    end Sleep;
 370
 371    -----------------
 372    -- Timed_Sleep --
 373    -----------------
 374
 375    procedure Timed_Sleep
 376      (Self_ID  : Task_ID;
 377       Time     : Duration;
 378       Mode     : ST.Delay_Modes;
 379       Reason   : System.Tasking.Task_States;
 380       Timedout : out Boolean;
 381       Yielded  : out Boolean)
 382    is
 383       pragma Unreferenced (Reason);
 384
 385       Check_Time : constant Duration := Monotonic_Clock;
 386       Abs_Time   : Duration;
 387       Request    : aliased struct_timeval;
 388       Result     : Interfaces.C.int;
 389
 390    begin
 391       Timedout := True;
 392       Yielded := False;
 393
 394       if Mode = Relative then
 395          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 396       else
 397          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 398       end if;
 399
 400       if Abs_Time > Check_Time then
 401          Request := To_Timeval (Abs_Time);
 402
 403          loop
 404             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 405               or else Self_ID.Pending_Priority_Change;
 406
 407             if Single_Lock then
 408                Result := pthread_cond_timedwait
 409                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
 410                   Request'Access);
 411
 412             else
 413                Result := pthread_cond_timedwait
 414                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
 415                   Request'Access);
 416             end if;
 417
 418             exit when Abs_Time <= Monotonic_Clock;
 419
 420             if Result = 0 or Result = EINTR then
 421                --  somebody may have called Wakeup for us
 422                Timedout := False;
 423                exit;
 424             end if;
 425
 426             pragma Assert (Result = ETIMEDOUT
 427               or else (Result = -1 and then errno = EAGAIN));
 428          end loop;
 429       end if;
 430    end Timed_Sleep;
 431
 432    -----------------
 433    -- Timed_Delay --
 434    -----------------
 435
 436    procedure Timed_Delay
 437      (Self_ID  : Task_ID;
 438       Time     : Duration;
 439       Mode     : ST.Delay_Modes)
 440    is
 441       Check_Time : constant Duration := Monotonic_Clock;
 442       Abs_Time   : Duration;
 443       Request    : aliased struct_timeval;
 444       Result     : Interfaces.C.int;
 445
 446    begin
 447       --  Only the little window between deferring abort and
 448       --  locking Self_ID is the reason we need to
 449       --  check for pending abort and priority change below!
 450
 451       SSL.Abort_Defer.all;
 452
 453       if Single_Lock then
 454          Lock_RTS;
 455       end if;
 456
 457       Write_Lock (Self_ID);
 458
 459       if Mode = Relative then
 460          Abs_Time := Time + Check_Time;
 461       else
 462          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 463       end if;
 464
 465       if Abs_Time > Check_Time then
 466          Request := To_Timeval (Abs_Time);
 467          Self_ID.Common.State := Delay_Sleep;
 468
 469          loop
 470             if Self_ID.Pending_Priority_Change then
 471                Self_ID.Pending_Priority_Change := False;
 472                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 473                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 474             end if;
 475
 476             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 477
 478             if Single_Lock then
 479                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 480                  Single_RTS_Lock'Access, Request'Access);
 481             else
 482                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 483                  Self_ID.Common.LL.L'Access, Request'Access);
 484             end if;
 485
 486             exit when Abs_Time <= Monotonic_Clock;
 487
 488             pragma Assert (Result = 0 or else
 489               Result = ETIMEDOUT or else
 490               (Result = -1 and then errno = EAGAIN) or else
 491               Result = EINTR);
 492          end loop;
 493
 494          Self_ID.Common.State := Runnable;
 495       end if;
 496
 497       Unlock (Self_ID);
 498
 499       if Single_Lock then
 500          Unlock_RTS;
 501       end if;
 502
 503       pthread_yield;
 504       SSL.Abort_Undefer.all;
 505    end Timed_Delay;
 506
 507    ---------------------
 508    -- Monotonic_Clock --
 509    ---------------------
 510
 511    function Monotonic_Clock return Duration is
 512       type timeval is record
 513          tv_sec  : Integer;
 514          tv_usec : Integer;
 515       end record;
 516       pragma Convention (C, timeval);
 517
 518       tv : aliased timeval;
 519
 520       procedure gettimeofday (tp : access timeval);
 521       pragma Import (C, gettimeofday, "gettimeofday", "gettimeofday");
 522
 523    begin
 524       gettimeofday (tv'Access);
 525       return Duration (tv.tv_sec) + Duration (tv.tv_usec) / 1_000_000.0;
 526    end Monotonic_Clock;
 527
 528    -------------------
 529    -- RT_Resolution --
 530    -------------------
 531
 532    function RT_Resolution return Duration is
 533    begin
 534       return 10#1.0#E-6;
 535    end RT_Resolution;
 536
 537    ------------
 538    -- Wakeup --
 539    ------------
 540
 541    procedure Wakeup
 542      (T : ST.Task_ID;
 543       Reason : System.Tasking.Task_States)
 544    is
 545       pragma Unreferenced (Reason);
 546
 547       Result : Interfaces.C.int;
 548    begin
 549       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 550       pragma Assert (Result = 0);
 551    end Wakeup;
 552
 553    -----------
 554    -- Yield --
 555    -----------
 556
 557    procedure Yield (Do_Yield : Boolean := True) is
 558    begin
 559       if Do_Yield then
 560          pthread_yield;
 561       end if;
 562    end Yield;
 563
 564    ------------------
 565    -- Set_Priority --
 566    ------------------
 567
 568    procedure Set_Priority
 569      (T                   : Task_ID;
 570       Prio                : System.Any_Priority;
 571       Loss_Of_Inheritance : Boolean := False)
 572    is
 573       pragma Unreferenced (Loss_Of_Inheritance);
 574
 575       Result : Interfaces.C.int;
 576
 577    begin
 578       T.Common.Current_Priority := Prio;
 579       Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
 580       pragma Assert (Result /= FUNC_ERR);
 581
 582    end Set_Priority;
 583
 584    ------------------
 585    -- Get_Priority --
 586    ------------------
 587
 588    function Get_Priority (T : Task_ID) return System.Any_Priority is
 589    begin
 590       return T.Common.Current_Priority;
 591    end Get_Priority;
 592
 593    ----------------
 594    -- Enter_Task --
 595    ----------------
 596
 597    procedure Enter_Task (Self_ID : Task_ID) is
 598       Result : Interfaces.C.int;
 599
 600    begin
 601       Self_ID.Common.LL.Thread := pthread_self;
 602       Self_ID.Common.LL.LWP := sproc_self;
 603
 604       Result :=
 605         pthread_set_ada_tcb (Self_ID.Common.LL.Thread, To_Address (Self_ID));
 606
 607       pragma Assert (Result = 0);
 608
 609       Lock_RTS;
 610
 611       for J in Known_Tasks'Range loop
 612          if Known_Tasks (J) = null then
 613             Known_Tasks (J) := Self_ID;
 614             Self_ID.Known_Tasks_Index := J;
 615             exit;
 616          end if;
 617       end loop;
 618
 619       Unlock_RTS;
 620    end Enter_Task;
 621
 622    --------------
 623    -- New_ATCB --
 624    --------------
 625
 626    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 627    begin
 628       return new Ada_Task_Control_Block (Entry_Num);
 629    end New_ATCB;
 630
 631    -------------------
 632    -- Is_Valid_Task --
 633    -------------------
 634
 635    function Is_Valid_Task return Boolean is
 636    begin
 637       return False;
 638    end Is_Valid_Task;
 639
 640    -----------------------------
 641    -- Register_Foreign_Thread --
 642    -----------------------------
 643
 644    function Register_Foreign_Thread return Task_ID is
 645    begin
 646       return null;
 647    end Register_Foreign_Thread;
 648
 649    ----------------------
 650    --  Initialize_TCB  --
 651    ----------------------
 652
 653    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 654       Result    : Interfaces.C.int;
 655       Cond_Attr : aliased pthread_condattr_t;
 656
 657    begin
 658       if not Single_Lock then
 659          Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
 660       end if;
 661
 662       Result := pthread_condattr_init (Cond_Attr'Access);
 663       pragma Assert (Result = 0 or else Result = ENOMEM);
 664
 665       if Result = 0 then
 666          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 667            Cond_Attr'Access);
 668          pragma Assert (Result = 0 or else Result = ENOMEM);
 669       end if;
 670
 671       if Result = 0 then
 672          Succeeded := True;
 673       else
 674          if not Single_Lock then
 675             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 676             pragma Assert (Result = 0);
 677          end if;
 678
 679          Succeeded := False;
 680       end if;
 681
 682       Result := pthread_condattr_destroy (Cond_Attr'Access);
 683       pragma Assert (Result = 0);
 684    end Initialize_TCB;
 685
 686    -----------------
 687    -- Create_Task --
 688    -----------------
 689
 690    procedure Create_Task
 691      (T          : Task_ID;
 692       Wrapper    : System.Address;
 693       Stack_Size : System.Parameters.Size_Type;
 694       Priority   : System.Any_Priority;
 695       Succeeded  : out Boolean)
 696    is
 697       Attributes          : aliased pthread_attr_t;
 698       Adjusted_Stack_Size : Interfaces.C.size_t;
 699       Result              : Interfaces.C.int;
 700
 701       function Thread_Body_Access is new
 702         Unchecked_Conversion (System.Address, start_addr);
 703
 704       function To_Resource_T is new Unchecked_Conversion
 705         (System.Task_Info.Resource_Vector_T, System.OS_Interface.resource_t);
 706
 707       use System.Task_Info;
 708
 709    begin
 710       if Stack_Size = Unspecified_Size then
 711          Adjusted_Stack_Size :=
 712            Interfaces.C.size_t (System.Program_Info.Default_Task_Stack);
 713
 714       elsif Stack_Size < Minimum_Stack_Size then
 715          Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
 716
 717       else
 718          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 719       end if;
 720
 721       Result := pthread_attr_init (Attributes'Access);
 722       pragma Assert (Result = 0 or else Result = ENOMEM);
 723
 724       if Result /= 0 then
 725          Succeeded := False;
 726          return;
 727       end if;
 728
 729       Result := pthread_attr_setdetachstate (Attributes'Access, 1);
 730       pragma Assert (Result = 0);
 731
 732       Result := pthread_attr_setstacksize
 733         (Attributes'Access, Adjusted_Stack_Size);
 734       pragma Assert (Result = 0);
 735
 736       if T.Common.Task_Info /= null then
 737          Result := pthread_attr_setresources
 738            (Attributes'Access,
 739             To_Resource_T (T.Common.Task_Info.Thread_Resources));
 740          pragma Assert (Result /= FUNC_ERR);
 741
 742          if T.Common.Task_Info.Thread_Timeslice /= 0.0 then
 743             declare
 744                use System.OS_Interface;
 745
 746                Tv : aliased struct_timeval := To_Timeval
 747                  (T.Common.Task_Info.Thread_Timeslice);
 748             begin
 749                Result := pthread_attr_set_tslice
 750                  (Attributes'Access, Tv'Access);
 751             end;
 752          end if;
 753
 754          if T.Common.Task_Info.Bound_To_Sproc then
 755             Result := pthread_attr_set_boundtosproc
 756               (Attributes'Access, PTHREAD_BOUND);
 757             Result := pthread_attr_set_bsproc
 758               (Attributes'Access, T.Common.Task_Info.Sproc);
 759          end if;
 760
 761       end if;
 762
 763       --  Since the initial signal mask of a thread is inherited from the
 764       --  creator, and the Environment task has all its signals masked, we
 765       --  do not need to manipulate caller's signal mask at this point.
 766       --  All tasks in RTS will have All_Tasks_Mask initially.
 767
 768       Result := pthread_create
 769         (T.Common.LL.Thread'Access,
 770          Attributes'Access,
 771          Thread_Body_Access (Wrapper),
 772          To_Address (T));
 773       pragma Assert (Result = 0 or else Result = EAGAIN);
 774
 775       Succeeded := Result = 0;
 776
 777       Set_Priority (T, Priority);
 778
 779       Result := pthread_attr_destroy (Attributes'Access);
 780       pragma Assert (Result /= FUNC_ERR);
 781    end Create_Task;
 782
 783    ------------------
 784    -- Finalize_TCB --
 785    ------------------
 786
 787    procedure Finalize_TCB (T : Task_ID) is
 788       procedure Free is new
 789         Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
 790
 791       Result : Interfaces.C.int;
 792       Tmp    : Task_ID := T;
 793
 794    begin
 795       if not Single_Lock then
 796          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 797          pragma Assert (Result = 0);
 798       end if;
 799
 800       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 801       pragma Assert (Result = 0);
 802
 803       if T.Known_Tasks_Index /= -1 then
 804          Known_Tasks (T.Known_Tasks_Index) := null;
 805       end if;
 806
 807       Free (Tmp);
 808    end Finalize_TCB;
 809
 810    ---------------
 811    -- Exit_Task --
 812    ---------------
 813
 814    procedure Exit_Task is
 815       Result : Interfaces.C.int;
 816
 817    begin
 818       Result := pthread_set_ada_tcb (pthread_self, System.Null_Address);
 819
 820       pragma Assert (Result = 0);
 821    end Exit_Task;
 822
 823    ----------------
 824    -- Abort_Task --
 825    ----------------
 826
 827    procedure Abort_Task (T : Task_ID) is
 828       Result : Interfaces.C.int;
 829
 830    begin
 831       Result :=
 832         pthread_kill (T.Common.LL.Thread,
 833                       Interfaces.C.int
 834                         (System.Interrupt_Management.Abort_Task_Interrupt));
 835       pragma Assert (Result = 0);
 836    end Abort_Task;
 837
 838    ----------------
 839    -- Check_Exit --
 840    ----------------
 841
 842    --  Dummy version
 843
 844    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 845       pragma Unreferenced (Self_ID);
 846
 847    begin
 848       return True;
 849    end Check_Exit;
 850
 851    --------------------
 852    -- Check_No_Locks --
 853    --------------------
 854
 855    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 856       pragma Unreferenced (Self_ID);
 857
 858    begin
 859       return True;
 860    end Check_No_Locks;
 861
 862    ----------------------
 863    -- Environment_Task --
 864    ----------------------
 865
 866    function Environment_Task return Task_ID is
 867    begin
 868       return Environment_Task_ID;
 869    end Environment_Task;
 870
 871    --------------
 872    -- Lock_RTS --
 873    --------------
 874
 875    procedure Lock_RTS is
 876    begin
 877       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 878    end Lock_RTS;
 879
 880    ----------------
 881    -- Unlock_RTS --
 882    ----------------
 883
 884    procedure Unlock_RTS is
 885    begin
 886       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 887    end Unlock_RTS;
 888
 889    ------------------
 890    -- Suspend_Task --
 891    ------------------
 892
 893    function Suspend_Task
 894      (T           : ST.Task_ID;
 895       Thread_Self : Thread_Id) return Boolean
 896    is
 897    begin
 898       if T.Common.LL.Thread /= Thread_Self then
 899          return pthread_suspend (T.Common.LL.Thread) = 0;
 900       else
 901          return True;
 902       end if;
 903    end Suspend_Task;
 904
 905    -----------------
 906    -- Resume_Task --
 907    -----------------
 908
 909    function Resume_Task
 910      (T           : ST.Task_ID;
 911       Thread_Self : Thread_Id) return Boolean
 912    is
 913    begin
 914       if T.Common.LL.Thread /= Thread_Self then
 915          return pthread_resume (T.Common.LL.Thread) = 0;
 916       else
 917          return True;
 918       end if;
 919    end Resume_Task;
 920
 921    ----------------
 922    -- Initialize --
 923    ----------------
 924
 925    procedure Initialize (Environment_Task : Task_ID) is
 926    begin
 927       Environment_Task_ID := Environment_Task;
 928
 929       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
 930       --  Initialize the lock used to synchronize chain of all ATCBs.
 931
 932       Enter_Task (Environment_Task);
 933
 934       Set_Priority (Environment_Task,
 935         Environment_Task.Common.Current_Priority);
 936    end Initialize;
 937
 938    --------------------------------
 939    -- Initialize_Athread_Library --
 940    --------------------------------
 941
 942    procedure Initialize_Athread_Library is
 943       Result : Interfaces.C.int;
 944       Init   : aliased pthread_init_struct;
 945
 946       package PINF renames System.Program_Info;
 947       package C    renames Interfaces.C;
 948
 949    begin
 950       Init.conf_initsize       := C.int (PINF.Pthread_Arena_Size);
 951       Init.max_sproc_count     := C.int (PINF.Max_Sproc_Count);
 952       Init.sproc_stack_size    := C.size_t (PINF.Sproc_Stack_Size);
 953       Init.os_default_priority := C.int (PINF.Os_Default_Priority);
 954       Init.os_sched_signal     := C.int (PINF.Pthread_Sched_Signal);
 955       Init.guard_pages         := C.int (PINF.Stack_Guard_Pages);
 956       Init.init_sproc_count    := C.int (PINF.Initial_Sproc_Count);
 957
 958       Result := pthread_exec_begin (Init'Access);
 959       pragma Assert (Result /= FUNC_ERR);
 960
 961       if Result = FUNC_ERR then
 962          raise Storage_Error;               --  Insufficient resources.
 963       end if;
 964
 965    end Initialize_Athread_Library;
 966
 967 begin
 968    Initialize_Athread_Library;
 969 end System.Task_Primitives.Operations;