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-2001, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is 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    begin
 216       Result := pthread_mutexattr_init (Attributes'Access);
 217
 218       if Result = FUNC_ERR then
 219          raise Storage_Error;
 220       end if;
 221
 222       if Locking_Policy = 'C' then
 223          Result := pthread_mutexattr_setqueueorder
 224            (Attributes'Access, MUTEX_PRIORITY_CEILING);
 225          pragma Assert (Result /= FUNC_ERR);
 226
 227          Result := pthread_mutexattr_setceilingprio
 228             (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
 229          pragma Assert (Result /= FUNC_ERR);
 230       end if;
 231
 232       Result := pthread_mutex_init (L, Attributes'Access);
 233
 234       if Result = FUNC_ERR then
 235          Result := pthread_mutexattr_destroy (Attributes'Access);
 236          raise Storage_Error;
 237       end if;
 238
 239       Result := pthread_mutexattr_destroy (Attributes'Access);
 240    end Initialize_Lock;
 241
 242    -------------------
 243    -- Finalize_Lock --
 244    -------------------
 245
 246    procedure Finalize_Lock (L : access Lock) is
 247       Result : Interfaces.C.int;
 248
 249    begin
 250       Result := pthread_mutex_destroy (L);
 251       pragma Assert (Result = 0);
 252    end Finalize_Lock;
 253
 254    procedure Finalize_Lock (L : access RTS_Lock) is
 255       Result : Interfaces.C.int;
 256
 257    begin
 258       Result := pthread_mutex_destroy (L);
 259       pragma Assert (Result = 0);
 260    end Finalize_Lock;
 261
 262    ----------------
 263    -- Write_Lock --
 264    ----------------
 265
 266    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 267       Result : Interfaces.C.int;
 268    begin
 269       Result := pthread_mutex_lock (L);
 270
 271       Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL;
 272       pragma Assert (Result /= FUNC_ERR);
 273    end Write_Lock;
 274
 275    procedure Write_Lock
 276      (L : access RTS_Lock; Global_Lock : Boolean := False)
 277    is
 278       Result : Interfaces.C.int;
 279    begin
 280       if not Single_Lock or else Global_Lock then
 281          Result := pthread_mutex_lock (L);
 282          pragma Assert (Result = 0);
 283       end if;
 284    end Write_Lock;
 285
 286    procedure Write_Lock (T : Task_ID) is
 287       Result : Interfaces.C.int;
 288    begin
 289       if not Single_Lock then
 290          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 291          pragma Assert (Result = 0);
 292       end if;
 293    end Write_Lock;
 294
 295    ---------------
 296    -- Read_Lock --
 297    ---------------
 298
 299    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 300    begin
 301       Write_Lock (L, Ceiling_Violation);
 302    end Read_Lock;
 303
 304    ------------
 305    -- Unlock --
 306    ------------
 307
 308    procedure Unlock (L : access Lock) is
 309       Result : Interfaces.C.int;
 310    begin
 311       Result := pthread_mutex_unlock (L);
 312       pragma Assert (Result = 0);
 313    end Unlock;
 314
 315    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 316       Result : Interfaces.C.int;
 317    begin
 318       if not Single_Lock or else Global_Lock then
 319          Result := pthread_mutex_unlock (L);
 320          pragma Assert (Result = 0);
 321       end if;
 322    end Unlock;
 323
 324    procedure Unlock (T : Task_ID) is
 325       Result : Interfaces.C.int;
 326    begin
 327       if not Single_Lock then
 328          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 329          pragma Assert (Result = 0);
 330       end if;
 331    end Unlock;
 332
 333    -----------
 334    -- Sleep --
 335    -----------
 336
 337    procedure Sleep
 338      (Self_ID  : ST.Task_ID;
 339       Reason   : System.Tasking.Task_States)
 340    is
 341       Result : Interfaces.C.int;
 342    begin
 343       if Single_Lock then
 344          Result := pthread_cond_wait
 345            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 346       else
 347          Result := pthread_cond_wait
 348            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 349       end if;
 350
 351       --  EINTR is not considered a failure.
 352       pragma Assert (Result = 0 or else Result = EINTR);
 353    end Sleep;
 354
 355    -----------------
 356    -- Timed_Sleep --
 357    -----------------
 358
 359    procedure Timed_Sleep
 360      (Self_ID  : Task_ID;
 361       Time     : Duration;
 362       Mode     : ST.Delay_Modes;
 363       Reason   : System.Tasking.Task_States;
 364       Timedout : out Boolean;
 365       Yielded  : out Boolean)
 366    is
 367       Check_Time : constant Duration := Monotonic_Clock;
 368       Abs_Time   : Duration;
 369       Request    : aliased struct_timeval;
 370       Result     : Interfaces.C.int;
 371    begin
 372       Timedout := True;
 373       Yielded := False;
 374
 375       if Mode = Relative then
 376          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 377       else
 378          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 379       end if;
 380
 381       if Abs_Time > Check_Time then
 382          Request := To_Timeval (Abs_Time);
 383
 384          loop
 385             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 386               or else Self_ID.Pending_Priority_Change;
 387
 388             if Single_Lock then
 389                Result := pthread_cond_timedwait
 390                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
 391                   Request'Access);
 392
 393             else
 394                Result := pthread_cond_timedwait
 395                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
 396                   Request'Access);
 397             end if;
 398
 399             exit when Abs_Time <= Monotonic_Clock;
 400
 401             if Result = 0 or Result = EINTR then
 402                --  somebody may have called Wakeup for us
 403                Timedout := False;
 404                exit;
 405             end if;
 406
 407             pragma Assert (Result = ETIMEDOUT
 408               or else (Result = -1 and then errno = EAGAIN));
 409          end loop;
 410       end if;
 411    end Timed_Sleep;
 412
 413    -----------------
 414    -- Timed_Delay --
 415    -----------------
 416
 417    procedure Timed_Delay
 418      (Self_ID  : Task_ID;
 419       Time     : Duration;
 420       Mode     : ST.Delay_Modes)
 421    is
 422       Check_Time : constant Duration := Monotonic_Clock;
 423       Abs_Time   : Duration;
 424       Request    : aliased struct_timeval;
 425       Result     : Interfaces.C.int;
 426
 427    begin
 428       --  Only the little window between deferring abort and
 429       --  locking Self_ID is the reason we need to
 430       --  check for pending abort and priority change below! :(
 431
 432       SSL.Abort_Defer.all;
 433
 434       if Single_Lock then
 435          Lock_RTS;
 436       end if;
 437
 438       Write_Lock (Self_ID);
 439
 440       if Mode = Relative then
 441          Abs_Time := Time + Check_Time;
 442       else
 443          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 444       end if;
 445
 446       if Abs_Time > Check_Time then
 447          Request := To_Timeval (Abs_Time);
 448          Self_ID.Common.State := Delay_Sleep;
 449
 450          loop
 451             if Self_ID.Pending_Priority_Change then
 452                Self_ID.Pending_Priority_Change := False;
 453                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 454                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 455             end if;
 456
 457             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 458
 459             if Single_Lock then
 460                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 461                  Single_RTS_Lock'Access, Request'Access);
 462             else
 463                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 464                  Self_ID.Common.LL.L'Access, Request'Access);
 465             end if;
 466
 467             exit when Abs_Time <= Monotonic_Clock;
 468
 469             pragma Assert (Result = 0 or else
 470               Result = ETIMEDOUT or else
 471               (Result = -1 and then errno = EAGAIN) or else
 472               Result = EINTR);
 473          end loop;
 474
 475          Self_ID.Common.State := Runnable;
 476       end if;
 477
 478       Unlock (Self_ID);
 479
 480       if Single_Lock then
 481          Unlock_RTS;
 482       end if;
 483
 484       pthread_yield;
 485       SSL.Abort_Undefer.all;
 486    end Timed_Delay;
 487
 488    ---------------------
 489    -- Monotonic_Clock --
 490    ---------------------
 491
 492    function Monotonic_Clock return Duration is
 493       type timeval is record
 494          tv_sec  : Integer;
 495          tv_usec : Integer;
 496       end record;
 497       pragma Convention (C, timeval);
 498
 499       tv : aliased timeval;
 500
 501       procedure gettimeofday (tp : access timeval);
 502       pragma Import (C, gettimeofday, "gettimeofday", "gettimeofday");
 503
 504    begin
 505       gettimeofday (tv'Access);
 506       return Duration (tv.tv_sec) + Duration (tv.tv_usec) / 1_000_000.0;
 507    end Monotonic_Clock;
 508
 509    -------------------
 510    -- RT_Resolution --
 511    -------------------
 512
 513    function RT_Resolution return Duration is
 514    begin
 515       return 10#1.0#E-6;
 516    end RT_Resolution;
 517
 518    ------------
 519    -- Wakeup --
 520    ------------
 521
 522    procedure Wakeup
 523      (T : ST.Task_ID;
 524       Reason : System.Tasking.Task_States)
 525    is
 526       Result : Interfaces.C.int;
 527    begin
 528       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 529       pragma Assert (Result = 0);
 530    end Wakeup;
 531
 532    -----------
 533    -- Yield --
 534    -----------
 535
 536    procedure Yield (Do_Yield : Boolean := True) is
 537    begin
 538       if Do_Yield then
 539          pthread_yield;
 540       end if;
 541    end Yield;
 542
 543    ------------------
 544    -- Set_Priority --
 545    ------------------
 546
 547    procedure Set_Priority
 548      (T : Task_ID;
 549       Prio : System.Any_Priority;
 550       Loss_Of_Inheritance : Boolean := False)
 551    is
 552       Result : Interfaces.C.int;
 553    begin
 554       T.Common.Current_Priority := Prio;
 555       Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
 556       pragma Assert (Result /= FUNC_ERR);
 557
 558    end Set_Priority;
 559
 560    ------------------
 561    -- Get_Priority --
 562    ------------------
 563
 564    function Get_Priority (T : Task_ID) return System.Any_Priority is
 565    begin
 566       return T.Common.Current_Priority;
 567    end Get_Priority;
 568
 569    ----------------
 570    -- Enter_Task --
 571    ----------------
 572
 573    procedure Enter_Task (Self_ID : Task_ID) is
 574       Result : Interfaces.C.int;
 575    begin
 576       Self_ID.Common.LL.Thread := pthread_self;
 577       Self_ID.Common.LL.LWP := sproc_self;
 578
 579       Result :=
 580         pthread_set_ada_tcb (Self_ID.Common.LL.Thread, To_Address (Self_ID));
 581
 582       pragma Assert (Result = 0);
 583
 584       Lock_RTS;
 585
 586       for J in Known_Tasks'Range loop
 587          if Known_Tasks (J) = null then
 588             Known_Tasks (J) := Self_ID;
 589             Self_ID.Known_Tasks_Index := J;
 590             exit;
 591          end if;
 592       end loop;
 593
 594       Unlock_RTS;
 595    end Enter_Task;
 596
 597    --------------
 598    -- New_ATCB --
 599    --------------
 600
 601    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 602    begin
 603       return new Ada_Task_Control_Block (Entry_Num);
 604    end New_ATCB;
 605
 606    ----------------------
 607    --  Initialize_TCB  --
 608    ----------------------
 609
 610    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 611       Result    : Interfaces.C.int;
 612       Cond_Attr : aliased pthread_condattr_t;
 613
 614    begin
 615       if not Single_Lock then
 616          Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
 617       end if;
 618
 619       Result := pthread_condattr_init (Cond_Attr'Access);
 620       pragma Assert (Result = 0 or else Result = ENOMEM);
 621
 622       if Result = 0 then
 623          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 624            Cond_Attr'Access);
 625          pragma Assert (Result = 0 or else Result = ENOMEM);
 626       end if;
 627
 628       if Result = 0 then
 629          Succeeded := True;
 630       else
 631          if not Single_Lock then
 632             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 633             pragma Assert (Result = 0);
 634          end if;
 635
 636          Succeeded := False;
 637       end if;
 638
 639       Result := pthread_condattr_destroy (Cond_Attr'Access);
 640       pragma Assert (Result = 0);
 641    end Initialize_TCB;
 642
 643    -----------------
 644    -- Create_Task --
 645    -----------------
 646
 647    procedure Create_Task
 648      (T          : Task_ID;
 649       Wrapper    : System.Address;
 650       Stack_Size : System.Parameters.Size_Type;
 651       Priority   : System.Any_Priority;
 652       Succeeded  : out Boolean)
 653    is
 654       Attributes          : aliased pthread_attr_t;
 655       Adjusted_Stack_Size : Interfaces.C.size_t;
 656       Result              : Interfaces.C.int;
 657
 658       function Thread_Body_Access is new
 659         Unchecked_Conversion (System.Address, start_addr);
 660
 661       function To_Resource_T is new Unchecked_Conversion
 662         (System.Task_Info.Resource_Vector_T, System.OS_Interface.resource_t);
 663
 664       use System.Task_Info;
 665
 666    begin
 667       if Stack_Size = Unspecified_Size then
 668          Adjusted_Stack_Size :=
 669            Interfaces.C.size_t (System.Program_Info.Default_Task_Stack);
 670
 671       elsif Stack_Size < Minimum_Stack_Size then
 672          Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
 673
 674       else
 675          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 676       end if;
 677
 678       Result := pthread_attr_init (Attributes'Access);
 679       pragma Assert (Result = 0 or else Result = ENOMEM);
 680
 681       if Result /= 0 then
 682          Succeeded := False;
 683          return;
 684       end if;
 685
 686       Result := pthread_attr_setdetachstate (Attributes'Access, 1);
 687       pragma Assert (Result = 0);
 688
 689       Result := pthread_attr_setstacksize
 690         (Attributes'Access, Adjusted_Stack_Size);
 691       pragma Assert (Result = 0);
 692
 693       if T.Common.Task_Info /= null then
 694          Result := pthread_attr_setresources
 695            (Attributes'Access,
 696             To_Resource_T (T.Common.Task_Info.Thread_Resources));
 697          pragma Assert (Result /= FUNC_ERR);
 698
 699          if T.Common.Task_Info.Thread_Timeslice /= 0.0 then
 700             declare
 701                use System.OS_Interface;
 702
 703                Tv : aliased struct_timeval := To_Timeval
 704                  (T.Common.Task_Info.Thread_Timeslice);
 705             begin
 706                Result := pthread_attr_set_tslice
 707                  (Attributes'Access, Tv'Access);
 708             end;
 709          end if;
 710
 711          if T.Common.Task_Info.Bound_To_Sproc then
 712             Result := pthread_attr_set_boundtosproc
 713               (Attributes'Access, PTHREAD_BOUND);
 714             Result := pthread_attr_set_bsproc
 715               (Attributes'Access, T.Common.Task_Info.Sproc);
 716          end if;
 717
 718       end if;
 719
 720       --  Since the initial signal mask of a thread is inherited from the
 721       --  creator, and the Environment task has all its signals masked, we
 722       --  do not need to manipulate caller's signal mask at this point.
 723       --  All tasks in RTS will have All_Tasks_Mask initially.
 724
 725       Result := pthread_create
 726         (T.Common.LL.Thread'Access,
 727          Attributes'Access,
 728          Thread_Body_Access (Wrapper),
 729          To_Address (T));
 730       pragma Assert (Result = 0 or else Result = EAGAIN);
 731
 732       Succeeded := Result = 0;
 733
 734       Set_Priority (T, Priority);
 735
 736       Result := pthread_attr_destroy (Attributes'Access);
 737       pragma Assert (Result /= FUNC_ERR);
 738    end Create_Task;
 739
 740    ------------------
 741    -- Finalize_TCB --
 742    ------------------
 743
 744    procedure Finalize_TCB (T : Task_ID) is
 745       procedure Free is new
 746         Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
 747
 748       Result : Interfaces.C.int;
 749       Tmp    : Task_ID := T;
 750
 751    begin
 752       if not Single_Lock then
 753          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 754          pragma Assert (Result = 0);
 755       end if;
 756
 757       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 758       pragma Assert (Result = 0);
 759
 760       if T.Known_Tasks_Index /= -1 then
 761          Known_Tasks (T.Known_Tasks_Index) := null;
 762       end if;
 763
 764       Free (Tmp);
 765    end Finalize_TCB;
 766
 767    ---------------
 768    -- Exit_Task --
 769    ---------------
 770
 771    procedure Exit_Task is
 772    begin
 773       pthread_exit (System.Null_Address);
 774    end Exit_Task;
 775
 776    ----------------
 777    -- Abort_Task --
 778    ----------------
 779
 780    procedure Abort_Task (T : Task_ID) is
 781       Result : Interfaces.C.int;
 782    begin
 783       Result := pthread_kill (T.Common.LL.Thread,
 784         Interfaces.C.int (System.Interrupt_Management.Abort_Task_Interrupt));
 785       pragma Assert (Result = 0);
 786    end Abort_Task;
 787
 788    ----------------
 789    -- Check_Exit --
 790    ----------------
 791
 792    --  Dummy versions.  The only currently working versions is for solaris
 793    --  (native).
 794
 795    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 796    begin
 797       return True;
 798    end Check_Exit;
 799
 800    --------------------
 801    -- Check_No_Locks --
 802    --------------------
 803
 804    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 805    begin
 806       return True;
 807    end Check_No_Locks;
 808
 809    ----------------------
 810    -- Environment_Task --
 811    ----------------------
 812
 813    function Environment_Task return Task_ID is
 814    begin
 815       return Environment_Task_ID;
 816    end Environment_Task;
 817
 818    --------------
 819    -- Lock_RTS --
 820    --------------
 821
 822    procedure Lock_RTS is
 823    begin
 824       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 825    end Lock_RTS;
 826
 827    ----------------
 828    -- Unlock_RTS --
 829    ----------------
 830
 831    procedure Unlock_RTS is
 832    begin
 833       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 834    end Unlock_RTS;
 835
 836    ------------------
 837    -- Suspend_Task --
 838    ------------------
 839
 840    function Suspend_Task
 841      (T           : ST.Task_ID;
 842       Thread_Self : Thread_Id) return Boolean is
 843    begin
 844       if T.Common.LL.Thread /= Thread_Self then
 845          return pthread_suspend (T.Common.LL.Thread) = 0;
 846       else
 847          return True;
 848       end if;
 849    end Suspend_Task;
 850
 851    -----------------
 852    -- Resume_Task --
 853    -----------------
 854
 855    function Resume_Task
 856      (T           : ST.Task_ID;
 857       Thread_Self : Thread_Id) return Boolean is
 858    begin
 859       if T.Common.LL.Thread /= Thread_Self then
 860          return pthread_resume (T.Common.LL.Thread) = 0;
 861       else
 862          return True;
 863       end if;
 864    end Resume_Task;
 865
 866    ----------------
 867    -- Initialize --
 868    ----------------
 869
 870    procedure Initialize (Environment_Task : Task_ID) is
 871    begin
 872       Environment_Task_ID := Environment_Task;
 873
 874       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
 875       --  Initialize the lock used to synchronize chain of all ATCBs.
 876
 877       Enter_Task (Environment_Task);
 878
 879       Set_Priority (Environment_Task,
 880         Environment_Task.Common.Current_Priority);
 881    end Initialize;
 882
 883    procedure Initialize_Athread_Library is
 884       Result : Interfaces.C.int;
 885       Init   : aliased pthread_init_struct;
 886
 887       package PINF renames System.Program_Info;
 888       package C    renames Interfaces.C;
 889
 890    begin
 891       Init.conf_initsize       := C.int (PINF.Pthread_Arena_Size);
 892       Init.max_sproc_count     := C.int (PINF.Max_Sproc_Count);
 893       Init.sproc_stack_size    := C.size_t (PINF.Sproc_Stack_Size);
 894       Init.os_default_priority := C.int (PINF.Os_Default_Priority);
 895       Init.os_sched_signal     := C.int (PINF.Pthread_Sched_Signal);
 896       Init.guard_pages         := C.int (PINF.Stack_Guard_Pages);
 897       Init.init_sproc_count    := C.int (PINF.Initial_Sproc_Count);
 898
 899       Result := pthread_exec_begin (Init'Access);
 900       pragma Assert (Result /= FUNC_ERR);
 901
 902       if Result = FUNC_ERR then
 903          raise Storage_Error;               --  Insufficient resources.
 904       end if;
 905
 906    end Initialize_Athread_Library;
 907
 908 begin
 909    Initialize_Athread_Library;
 910 end System.Task_Primitives.Operations;