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 --                                                                          --
  10 --         Copyright (C) 1992-2001, Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNARL was developed by the GNARL team at Florida State University. It is --
  31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This is an Irix (old athread library) version of this package
  36
  37 --  This package contains all the GNULL primitives that interface directly
  38 --  with the underlying OS.
  39
  40 pragma Polling (Off);
  41 --  Turn off polling, we do not want ATC polling to take place during
  42 --  tasking operations. It causes infinite loops and other problems.
  43
  44 with Interfaces.C;
  45 --  used for int
  46 --           size_t
  47
  48 with System.Tasking.Debug;
  49 --  used for Known_Tasks
  50
  51 with System.Task_Info;
  52
  53 with System.Interrupt_Management;
  54 --  used for Keep_Unmasked
  55 --           Abort_Task_Interrupt
  56 --           Interrupt_ID
  57
  58 with System.Parameters;
  59 --  used for Size_Type
  60
  61 with System.Tasking;
  62 --  used for Ada_Task_Control_Block
  63 --           Task_ID
  64
  65 with System.Program_Info;
  66 --  used for Default_Task_Stack
  67 --           Default_Time_Slice
  68 --           Stack_Guard_Pages
  69 --           Pthread_Sched_Signal
  70 --           Pthread_Arena_Size
  71
  72 with System.Soft_Links;
  73 --  used for Defer/Undefer_Abort
  74
  75 --  Note that we do not use System.Tasking.Initialization directly since
  76 --  this is a higher level package that we shouldn't depend on. For example
  77 --  when using the restricted run time, it is replaced by
  78 --  System.Tasking.Restricted.Initialization
  79
  80 with System.OS_Primitives;
  81 --  used for Delay_Modes
  82
  83 with System.Storage_Elements;
  84 --  used for To_Address
  85
  86 with Unchecked_Conversion;
  87 with Unchecked_Deallocation;
  88
  89 package body System.Task_Primitives.Operations is
  90
  91    use System.Tasking.Debug;
  92    use System.Tasking;
  93    use Interfaces.C;
  94    use System.OS_Interface;
  95    use System.Parameters;
  96    use System.OS_Primitives;
  97
  98    package SSL renames System.Soft_Links;
  99
 100    ------------------
 101    --  Local Data  --
 102    ------------------
 103
 104    --  The followings are logically constants, but need to be initialized
 105    --  at run time.
 106
 107    Single_RTS_Lock : aliased RTS_Lock;
 108    --  This is a lock to allow only one thread of control in the RTS at
 109    --  a time; it is used to execute in mutual exclusion from all other tasks.
 110    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
 111
 112    Environment_Task_ID : Task_ID;
 113    --  A variable to hold Task_ID for the environment task.
 114
 115    Locking_Policy : Character;
 116    pragma Import (C, Locking_Policy, "__gl_locking_policy");
 117
 118    Clock_Address : constant System.Address :=
 119      System.Storage_Elements.To_Address (16#200F90#);
 120
 121    RT_Clock_Id : clockid_t;
 122    for RT_Clock_Id'Address use Clock_Address;
 123
 124    -----------------------
 125    -- Local Subprograms --
 126    -----------------------
 127
 128    procedure Initialize_Athread_Library;
 129
 130    function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
 131
 132    function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
 133
 134    -------------------
 135    --  Stack_Guard  --
 136    -------------------
 137
 138    --  The underlying thread system sets a guard page at the
 139    --  bottom of a thread stack, so nothing is needed.
 140    --  ??? Check the comment above
 141
 142    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
 143    begin
 144       null;
 145    end Stack_Guard;
 146
 147    --------------------
 148    -- Get_Thread_Id  --
 149    --------------------
 150
 151    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
 152    begin
 153       return T.Common.LL.Thread;
 154    end Get_Thread_Id;
 155
 156    ----------
 157    -- Self --
 158    ----------
 159
 160    function Self return Task_ID is
 161    begin
 162       return To_Task_ID (pthread_get_current_ada_tcb);
 163    end Self;
 164
 165    ---------------------
 166    -- Initialize_Lock --
 167    ---------------------
 168
 169    --  Note: mutexes and cond_variables needed per-task basis are
 170    --        initialized in Initialize_TCB and the Storage_Error is
 171    --        handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 172    --        used in RTS is initialized before any status change of RTS.
 173    --        Therefore rasing Storage_Error in the following routines
 174    --        should be able to be handled safely.
 175
 176    procedure Initialize_Lock
 177      (Prio : System.Any_Priority;
 178       L    : access Lock)
 179    is
 180       Attributes : aliased pthread_mutexattr_t;
 181       Result     : Interfaces.C.int;
 182
 183    begin
 184       Result := pthread_mutexattr_init (Attributes'Access);
 185
 186       if Result = FUNC_ERR then
 187          raise Storage_Error;
 188       end if;
 189
 190       if Locking_Policy = 'C' then
 191
 192          Result := pthread_mutexattr_setqueueorder
 193            (Attributes'Access, MUTEX_PRIORITY_CEILING);
 194
 195          pragma Assert (Result /= FUNC_ERR);
 196
 197          Result := pthread_mutexattr_setceilingprio
 198             (Attributes'Access, Interfaces.C.int (Prio));
 199
 200          pragma Assert (Result /= FUNC_ERR);
 201       end if;
 202
 203       Result := pthread_mutex_init (L, Attributes'Access);
 204
 205       if Result = FUNC_ERR then
 206          Result := pthread_mutexattr_destroy (Attributes'Access);
 207          raise Storage_Error;
 208       end if;
 209
 210       Result := pthread_mutexattr_destroy (Attributes'Access);
 211    end Initialize_Lock;
 212
 213    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 214       Attributes : aliased pthread_mutexattr_t;
 215       Result : Interfaces.C.int;
 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    begin
 270       Result := pthread_mutex_lock (L);
 271
 272       Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL;
 273       pragma Assert (Result /= FUNC_ERR);
 274    end Write_Lock;
 275
 276    procedure Write_Lock
 277      (L : access RTS_Lock; Global_Lock : Boolean := False)
 278    is
 279       Result : Interfaces.C.int;
 280    begin
 281       if not Single_Lock or else Global_Lock then
 282          Result := pthread_mutex_lock (L);
 283          pragma Assert (Result = 0);
 284       end if;
 285    end Write_Lock;
 286
 287    procedure Write_Lock (T : Task_ID) is
 288       Result : Interfaces.C.int;
 289    begin
 290       if not Single_Lock then
 291          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 292          pragma Assert (Result = 0);
 293       end if;
 294    end Write_Lock;
 295
 296    ---------------
 297    -- Read_Lock --
 298    ---------------
 299
 300    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 301    begin
 302       Write_Lock (L, Ceiling_Violation);
 303    end Read_Lock;
 304
 305    ------------
 306    -- Unlock --
 307    ------------
 308
 309    procedure Unlock (L : access Lock) is
 310       Result : Interfaces.C.int;
 311    begin
 312       Result := pthread_mutex_unlock (L);
 313       pragma Assert (Result = 0);
 314    end Unlock;
 315
 316    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 317       Result : Interfaces.C.int;
 318    begin
 319       if not Single_Lock or else Global_Lock then
 320          Result := pthread_mutex_unlock (L);
 321          pragma Assert (Result = 0);
 322       end if;
 323    end Unlock;
 324
 325    procedure Unlock (T : Task_ID) is
 326       Result : Interfaces.C.int;
 327    begin
 328       if not Single_Lock then
 329          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 330          pragma Assert (Result = 0);
 331       end if;
 332    end Unlock;
 333
 334    -----------
 335    -- Sleep --
 336    -----------
 337
 338    procedure Sleep
 339      (Self_ID  : ST.Task_ID;
 340       Reason   : System.Tasking.Task_States)
 341    is
 342       Result : Interfaces.C.int;
 343    begin
 344       if Single_Lock then
 345          Result := pthread_cond_wait
 346            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 347       else
 348          Result := pthread_cond_wait
 349            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 350       end if;
 351
 352       --  EINTR is not considered a failure.
 353       pragma Assert (Result = 0 or else Result = EINTR);
 354    end Sleep;
 355
 356    -----------------
 357    -- Timed_Sleep --
 358    -----------------
 359
 360    procedure Timed_Sleep
 361      (Self_ID  : Task_ID;
 362       Time     : Duration;
 363       Mode     : ST.Delay_Modes;
 364       Reason   : System.Tasking.Task_States;
 365       Timedout : out Boolean;
 366       Yielded  : out Boolean)
 367    is
 368       Check_Time : constant Duration := Monotonic_Clock;
 369       Abs_Time   : Duration;
 370       Request    : aliased struct_timeval;
 371       Result     : Interfaces.C.int;
 372    begin
 373       Timedout := True;
 374       Yielded := False;
 375
 376       if Mode = Relative then
 377          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 378       else
 379          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 380       end if;
 381
 382       if Abs_Time > Check_Time then
 383          Request := To_Timeval (Abs_Time);
 384
 385          loop
 386             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 387               or else Self_ID.Pending_Priority_Change;
 388
 389             if Single_Lock then
 390                Result := pthread_cond_timedwait
 391                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
 392                   Request'Access);
 393
 394             else
 395                Result := pthread_cond_timedwait
 396                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
 397                   Request'Access);
 398             end if;
 399
 400             exit when Abs_Time <= Monotonic_Clock;
 401
 402             if Result = 0 or Result = EINTR then
 403                --  somebody may have called Wakeup for us
 404                Timedout := False;
 405                exit;
 406             end if;
 407
 408             pragma Assert (Result = ETIMEDOUT
 409               or else (Result = -1 and then errno = EAGAIN));
 410          end loop;
 411       end if;
 412    end Timed_Sleep;
 413
 414    -----------------
 415    -- Timed_Delay --
 416    -----------------
 417
 418    procedure Timed_Delay
 419      (Self_ID  : Task_ID;
 420       Time     : Duration;
 421       Mode     : ST.Delay_Modes)
 422    is
 423       Check_Time : constant Duration := Monotonic_Clock;
 424       Abs_Time   : Duration;
 425       Request    : aliased struct_timeval;
 426       Result     : Interfaces.C.int;
 427
 428    begin
 429       --  Only the little window between deferring abort and
 430       --  locking Self_ID is the reason we need to
 431       --  check for pending abort and priority change below! :(
 432
 433       SSL.Abort_Defer.all;
 434
 435       if Single_Lock then
 436          Lock_RTS;
 437       end if;
 438
 439       Write_Lock (Self_ID);
 440
 441       if Mode = Relative then
 442          Abs_Time := Time + Check_Time;
 443       else
 444          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 445       end if;
 446
 447       if Abs_Time > Check_Time then
 448          Request := To_Timeval (Abs_Time);
 449          Self_ID.Common.State := Delay_Sleep;
 450
 451          loop
 452             if Self_ID.Pending_Priority_Change then
 453                Self_ID.Pending_Priority_Change := False;
 454                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 455                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 456             end if;
 457
 458             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 459
 460             if Single_Lock then
 461                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 462                  Single_RTS_Lock'Access, Request'Access);
 463             else
 464                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 465                  Self_ID.Common.LL.L'Access, Request'Access);
 466             end if;
 467
 468             exit when Abs_Time <= Monotonic_Clock;
 469
 470             pragma Assert (Result = 0 or else
 471               Result = ETIMEDOUT or else
 472               (Result = -1 and then errno = EAGAIN) or else
 473               Result = EINTR);
 474          end loop;
 475
 476          Self_ID.Common.State := Runnable;
 477       end if;
 478
 479       Unlock (Self_ID);
 480
 481       if Single_Lock then
 482          Unlock_RTS;
 483       end if;
 484
 485       pthread_yield;
 486       SSL.Abort_Undefer.all;
 487    end Timed_Delay;
 488
 489    ---------------------
 490    -- Monotonic_Clock --
 491    ---------------------
 492
 493    function Monotonic_Clock return Duration is
 494       type timeval is record
 495          tv_sec  : Integer;
 496          tv_usec : Integer;
 497       end record;
 498       pragma Convention (C, timeval);
 499
 500       tv : aliased timeval;
 501
 502       procedure gettimeofday (tp : access timeval);
 503       pragma Import (C, gettimeofday, "gettimeofday", "gettimeofday");
 504
 505    begin
 506       gettimeofday (tv'Access);
 507       return Duration (tv.tv_sec) + Duration (tv.tv_usec) / 1_000_000.0;
 508    end Monotonic_Clock;
 509
 510    -------------------
 511    -- RT_Resolution --
 512    -------------------
 513
 514    function RT_Resolution return Duration is
 515    begin
 516       return 10#1.0#E-6;
 517    end RT_Resolution;
 518
 519    ------------
 520    -- Wakeup --
 521    ------------
 522
 523    procedure Wakeup
 524      (T : ST.Task_ID;
 525       Reason : System.Tasking.Task_States)
 526    is
 527       Result : Interfaces.C.int;
 528    begin
 529       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 530       pragma Assert (Result = 0);
 531    end Wakeup;
 532
 533    -----------
 534    -- Yield --
 535    -----------
 536
 537    procedure Yield (Do_Yield : Boolean := True) is
 538    begin
 539       if Do_Yield then
 540          pthread_yield;
 541       end if;
 542    end Yield;
 543
 544    ------------------
 545    -- Set_Priority --
 546    ------------------
 547
 548    procedure Set_Priority
 549      (T : Task_ID;
 550       Prio : System.Any_Priority;
 551       Loss_Of_Inheritance : Boolean := False)
 552    is
 553       Result : Interfaces.C.int;
 554    begin
 555       T.Common.Current_Priority := Prio;
 556       Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
 557       pragma Assert (Result /= FUNC_ERR);
 558
 559    end Set_Priority;
 560
 561    ------------------
 562    -- Get_Priority --
 563    ------------------
 564
 565    function Get_Priority (T : Task_ID) return System.Any_Priority is
 566    begin
 567       return T.Common.Current_Priority;
 568    end Get_Priority;
 569
 570    ----------------
 571    -- Enter_Task --
 572    ----------------
 573
 574    procedure Enter_Task (Self_ID : Task_ID) is
 575       Result : Interfaces.C.int;
 576    begin
 577       Self_ID.Common.LL.Thread := pthread_self;
 578       Self_ID.Common.LL.LWP := sproc_self;
 579
 580       Result :=
 581         pthread_set_ada_tcb (Self_ID.Common.LL.Thread, To_Address (Self_ID));
 582
 583       pragma Assert (Result = 0);
 584
 585       Lock_RTS;
 586
 587       for J in Known_Tasks'Range loop
 588          if Known_Tasks (J) = null then
 589             Known_Tasks (J) := Self_ID;
 590             Self_ID.Known_Tasks_Index := J;
 591             exit;
 592          end if;
 593       end loop;
 594
 595       Unlock_RTS;
 596    end Enter_Task;
 597
 598    --------------
 599    -- New_ATCB --
 600    --------------
 601
 602    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 603    begin
 604       return new Ada_Task_Control_Block (Entry_Num);
 605    end New_ATCB;
 606
 607    ----------------------
 608    --  Initialize_TCB  --
 609    ----------------------
 610
 611    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 612       Result    : Interfaces.C.int;
 613       Cond_Attr : aliased pthread_condattr_t;
 614
 615    begin
 616       if not Single_Lock then
 617          Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
 618       end if;
 619
 620       Result := pthread_condattr_init (Cond_Attr'Access);
 621       pragma Assert (Result = 0 or else Result = ENOMEM);
 622
 623       if Result = 0 then
 624          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 625            Cond_Attr'Access);
 626          pragma Assert (Result = 0 or else Result = ENOMEM);
 627       end if;
 628
 629       if Result = 0 then
 630          Succeeded := True;
 631       else
 632          if not Single_Lock then
 633             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 634             pragma Assert (Result = 0);
 635          end if;
 636
 637          Succeeded := False;
 638       end if;
 639
 640       Result := pthread_condattr_destroy (Cond_Attr'Access);
 641       pragma Assert (Result = 0);
 642    end Initialize_TCB;
 643
 644    -----------------
 645    -- Create_Task --
 646    -----------------
 647
 648    procedure Create_Task
 649      (T          : Task_ID;
 650       Wrapper    : System.Address;
 651       Stack_Size : System.Parameters.Size_Type;
 652       Priority   : System.Any_Priority;
 653       Succeeded  : out Boolean)
 654    is
 655       Attributes          : aliased pthread_attr_t;
 656       Adjusted_Stack_Size : Interfaces.C.size_t;
 657       Result              : Interfaces.C.int;
 658
 659       function Thread_Body_Access is new
 660         Unchecked_Conversion (System.Address, start_addr);
 661
 662       function To_Resource_T is new Unchecked_Conversion
 663         (System.Task_Info.Resource_Vector_T, System.OS_Interface.resource_t);
 664
 665       use System.Task_Info;
 666
 667    begin
 668       if Stack_Size = Unspecified_Size then
 669          Adjusted_Stack_Size :=
 670            Interfaces.C.size_t (System.Program_Info.Default_Task_Stack);
 671
 672       elsif Stack_Size < Minimum_Stack_Size then
 673          Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
 674
 675       else
 676          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 677       end if;
 678
 679       Result := pthread_attr_init (Attributes'Access);
 680       pragma Assert (Result = 0 or else Result = ENOMEM);
 681
 682       if Result /= 0 then
 683          Succeeded := False;
 684          return;
 685       end if;
 686
 687       Result := pthread_attr_setdetachstate (Attributes'Access, 1);
 688       pragma Assert (Result = 0);
 689
 690       Result := pthread_attr_setstacksize
 691         (Attributes'Access, Adjusted_Stack_Size);
 692       pragma Assert (Result = 0);
 693
 694       if T.Common.Task_Info /= null then
 695          Result := pthread_attr_setresources
 696            (Attributes'Access,
 697             To_Resource_T (T.Common.Task_Info.Thread_Resources));
 698          pragma Assert (Result /= FUNC_ERR);
 699
 700          if T.Common.Task_Info.Thread_Timeslice /= 0.0 then
 701             declare
 702                use System.OS_Interface;
 703
 704                Tv : aliased struct_timeval := To_Timeval
 705                  (T.Common.Task_Info.Thread_Timeslice);
 706             begin
 707                Result := pthread_attr_set_tslice
 708                  (Attributes'Access, Tv'Access);
 709             end;
 710          end if;
 711
 712          if T.Common.Task_Info.Bound_To_Sproc then
 713             Result := pthread_attr_set_boundtosproc
 714               (Attributes'Access, PTHREAD_BOUND);
 715             Result := pthread_attr_set_bsproc
 716               (Attributes'Access, T.Common.Task_Info.Sproc);
 717          end if;
 718
 719       end if;
 720
 721       --  Since the initial signal mask of a thread is inherited from the
 722       --  creator, and the Environment task has all its signals masked, we
 723       --  do not need to manipulate caller's signal mask at this point.
 724       --  All tasks in RTS will have All_Tasks_Mask initially.
 725
 726       Result := pthread_create
 727         (T.Common.LL.Thread'Access,
 728          Attributes'Access,
 729          Thread_Body_Access (Wrapper),
 730          To_Address (T));
 731       pragma Assert (Result = 0 or else Result = EAGAIN);
 732
 733       Succeeded := Result = 0;
 734
 735       Set_Priority (T, Priority);
 736
 737       Result := pthread_attr_destroy (Attributes'Access);
 738       pragma Assert (Result /= FUNC_ERR);
 739    end Create_Task;
 740
 741    ------------------
 742    -- Finalize_TCB --
 743    ------------------
 744
 745    procedure Finalize_TCB (T : Task_ID) is
 746       procedure Free is new
 747         Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
 748
 749       Result : Interfaces.C.int;
 750       Tmp    : Task_ID := T;
 751
 752    begin
 753       if not Single_Lock then
 754          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 755          pragma Assert (Result = 0);
 756       end if;
 757
 758       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 759       pragma Assert (Result = 0);
 760
 761       if T.Known_Tasks_Index /= -1 then
 762          Known_Tasks (T.Known_Tasks_Index) := null;
 763       end if;
 764
 765       Free (Tmp);
 766    end Finalize_TCB;
 767
 768    ---------------
 769    -- Exit_Task --
 770    ---------------
 771
 772    procedure Exit_Task is
 773    begin
 774       pthread_exit (System.Null_Address);
 775    end Exit_Task;
 776
 777    ----------------
 778    -- Abort_Task --
 779    ----------------
 780
 781    procedure Abort_Task (T : Task_ID) is
 782       Result : Interfaces.C.int;
 783    begin
 784       Result := pthread_kill (T.Common.LL.Thread,
 785         Interfaces.C.int (System.Interrupt_Management.Abort_Task_Interrupt));
 786       pragma Assert (Result = 0);
 787    end Abort_Task;
 788
 789    ----------------
 790    -- Check_Exit --
 791    ----------------
 792
 793    --  Dummy versions.  The only currently working versions is for solaris
 794    --  (native).
 795
 796    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 797    begin
 798       return True;
 799    end Check_Exit;
 800
 801    --------------------
 802    -- Check_No_Locks --
 803    --------------------
 804
 805    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 806    begin
 807       return True;
 808    end Check_No_Locks;
 809
 810    ----------------------
 811    -- Environment_Task --
 812    ----------------------
 813
 814    function Environment_Task return Task_ID is
 815    begin
 816       return Environment_Task_ID;
 817    end Environment_Task;
 818
 819    --------------
 820    -- Lock_RTS --
 821    --------------
 822
 823    procedure Lock_RTS is
 824    begin
 825       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 826    end Lock_RTS;
 827
 828    ----------------
 829    -- Unlock_RTS --
 830    ----------------
 831
 832    procedure Unlock_RTS is
 833    begin
 834       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 835    end Unlock_RTS;
 836
 837    ------------------
 838    -- Suspend_Task --
 839    ------------------
 840
 841    function Suspend_Task
 842      (T           : ST.Task_ID;
 843       Thread_Self : Thread_Id) return Boolean is
 844    begin
 845       if T.Common.LL.Thread /= Thread_Self then
 846          return pthread_suspend (T.Common.LL.Thread) = 0;
 847       else
 848          return True;
 849       end if;
 850    end Suspend_Task;
 851
 852    -----------------
 853    -- Resume_Task --
 854    -----------------
 855
 856    function Resume_Task
 857      (T           : ST.Task_ID;
 858       Thread_Self : Thread_Id) return Boolean is
 859    begin
 860       if T.Common.LL.Thread /= Thread_Self then
 861          return pthread_resume (T.Common.LL.Thread) = 0;
 862       else
 863          return True;
 864       end if;
 865    end Resume_Task;
 866
 867    ----------------
 868    -- Initialize --
 869    ----------------
 870
 871    procedure Initialize (Environment_Task : Task_ID) is
 872    begin
 873       Environment_Task_ID := Environment_Task;
 874
 875       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
 876       --  Initialize the lock used to synchronize chain of all ATCBs.
 877
 878       Enter_Task (Environment_Task);
 879
 880       Set_Priority (Environment_Task,
 881         Environment_Task.Common.Current_Priority);
 882    end Initialize;
 883
 884    procedure Initialize_Athread_Library is
 885       Result : Interfaces.C.int;
 886       Init   : aliased pthread_init_struct;
 887
 888       package PINF renames System.Program_Info;
 889       package C    renames Interfaces.C;
 890
 891    begin
 892       Init.conf_initsize       := C.int (PINF.Pthread_Arena_Size);
 893       Init.max_sproc_count     := C.int (PINF.Max_Sproc_Count);
 894       Init.sproc_stack_size    := C.size_t (PINF.Sproc_Stack_Size);
 895       Init.os_default_priority := C.int (PINF.Os_Default_Priority);
 896       Init.os_sched_signal     := C.int (PINF.Pthread_Sched_Signal);
 897       Init.guard_pages         := C.int (PINF.Stack_Guard_Pages);
 898       Init.init_sproc_count    := C.int (PINF.Initial_Sproc_Count);
 899
 900       Result := pthread_exec_begin (Init'Access);
 901       pragma Assert (Result /= FUNC_ERR);
 902
 903       if Result = FUNC_ERR then
 904          raise Storage_Error;               --  Insufficient resources.
 905       end if;
 906
 907    end Initialize_Athread_Library;
 908
 909 begin
 910    Initialize_Athread_Library;
 911 end System.Task_Primitives.Operations;