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