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