gcc/ada/s-taprop-irix-athread.adb

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