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

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                  GNAT 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-2005, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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.Interrupt_Management;
  51 --  used for Keep_Unmasked
  52 --           Abort_Task_Interrupt
  53 --           Interrupt_ID
  54
  55 with System.OS_Primitives;
  56 --  used for Delay_Modes
  57
  58 with System.Task_Info;
  59
  60 with System.Parameters;
  61 --  used for Size_Type
  62
  63 with System.Program_Info;
  64 --  used for Default_Task_Stack
  65 --           Default_Time_Slice
  66 --           Stack_Guard_Pages
  67 --           Pthread_Sched_Signal
  68 --           Pthread_Arena_Size
  69
  70 with System.Storage_Elements;
  71 --  used for To_Address
  72
  73 with Unchecked_Conversion;
  74 with Unchecked_Deallocation;
  75
  76 package body System.Task_Primitives.Operations is
  77
  78    use System.Tasking.Debug;
  79    use System.Tasking;
  80    use Interfaces.C;
  81    use System.OS_Interface;
  82    use System.Parameters;
  83    use System.OS_Primitives;
  84
  85    -----------------
  86    -- Local Data  --
  87    -----------------
  88
  89    --  The followings are logically constants, but need to be initialized
  90    --  at run time.
  91
  92    Single_RTS_Lock : aliased RTS_Lock;
  93    --  This is a lock to allow only one thread of control in the RTS at
  94    --  a time; it is used to execute in mutual exclusion from all other tasks.
  95    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
  96
  97    Environment_Task_Id : Task_Id;
  98    --  A variable to hold Task_Id for the environment task.
  99
 100    Locking_Policy : Character;
 101    pragma Import (C, Locking_Policy, "__gl_locking_policy");
 102
 103    Clock_Address : constant System.Address :=
 104      System.Storage_Elements.To_Address (16#200F90#);
 105
 106    RT_Clock_Id : clockid_t;
 107    for RT_Clock_Id'Address use Clock_Address;
 108
 109    -----------------------
 110    -- Local Subprograms --
 111    -----------------------
 112
 113    procedure Initialize_Athread_Library;
 114
 115    function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id);
 116    function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
 117
 118    -----------------
 119    -- Stack_Guard --
 120    -----------------
 121
 122    --  The underlying thread system sets a guard page at the
 123    --  bottom of a thread stack, so nothing is needed.
 124    --  ??? Check the comment above
 125
 126    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 127       pragma Unreferenced (T);
 128       pragma Unreferenced (On);
 129    begin
 130       null;
 131    end Stack_Guard;
 132
 133    --------------------
 134    -- Get_Thread_Id  --
 135    --------------------
 136
 137    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 138    begin
 139       return T.Common.LL.Thread;
 140    end Get_Thread_Id;
 141
 142    ----------
 143    -- Self --
 144    ----------
 145
 146    function Self return Task_Id is
 147    begin
 148       return To_Task_Id (pthread_get_current_ada_tcb);
 149    end Self;
 150
 151    ---------------------
 152    -- Initialize_Lock --
 153    ---------------------
 154
 155    --  Note: mutexes and cond_variables needed per-task basis are
 156    --        initialized in Initialize_TCB and the Storage_Error is
 157    --        handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 158    --        used in RTS is initialized before any status change of RTS.
 159    --        Therefore rasing Storage_Error in the following routines
 160    --        should be able to be handled safely.
 161
 162    procedure Initialize_Lock
 163      (Prio : System.Any_Priority;
 164       L    : access Lock)
 165    is
 166       Attributes : aliased pthread_mutexattr_t;
 167       Result     : Interfaces.C.int;
 168
 169    begin
 170       Result := pthread_mutexattr_init (Attributes'Access);
 171
 172       if Result = FUNC_ERR then
 173          raise Storage_Error;
 174       end if;
 175
 176       if Locking_Policy = 'C' then
 177
 178          Result := pthread_mutexattr_setqueueorder
 179            (Attributes'Access, MUTEX_PRIORITY_CEILING);
 180
 181          pragma Assert (Result /= FUNC_ERR);
 182
 183          Result := pthread_mutexattr_setceilingprio
 184             (Attributes'Access, Interfaces.C.int (Prio));
 185
 186          pragma Assert (Result /= FUNC_ERR);
 187       end if;
 188
 189       Result := pthread_mutex_init (L, Attributes'Access);
 190
 191       if Result = FUNC_ERR then
 192          Result := pthread_mutexattr_destroy (Attributes'Access);
 193          raise Storage_Error;
 194       end if;
 195
 196       Result := pthread_mutexattr_destroy (Attributes'Access);
 197    end Initialize_Lock;
 198
 199    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 200       pragma Unreferenced (Level);
 201
 202       Attributes : aliased pthread_mutexattr_t;
 203       Result : Interfaces.C.int;
 204
 205    begin
 206       Result := pthread_mutexattr_init (Attributes'Access);
 207
 208       if Result = FUNC_ERR then
 209          raise Storage_Error;
 210       end if;
 211
 212       if Locking_Policy = 'C' then
 213          Result := pthread_mutexattr_setqueueorder
 214            (Attributes'Access, MUTEX_PRIORITY_CEILING);
 215          pragma Assert (Result /= FUNC_ERR);
 216
 217          Result := pthread_mutexattr_setceilingprio
 218             (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
 219          pragma Assert (Result /= FUNC_ERR);
 220       end if;
 221
 222       Result := pthread_mutex_init (L, Attributes'Access);
 223
 224       if Result = FUNC_ERR then
 225          Result := pthread_mutexattr_destroy (Attributes'Access);
 226          raise Storage_Error;
 227       end if;
 228
 229       Result := pthread_mutexattr_destroy (Attributes'Access);
 230    end Initialize_Lock;
 231
 232    -------------------
 233    -- Finalize_Lock --
 234    -------------------
 235
 236    procedure Finalize_Lock (L : access Lock) is
 237       Result : Interfaces.C.int;
 238    begin
 239       Result := pthread_mutex_destroy (L);
 240       pragma Assert (Result = 0);
 241    end Finalize_Lock;
 242
 243    procedure Finalize_Lock (L : access RTS_Lock) is
 244       Result : Interfaces.C.int;
 245    begin
 246       Result := pthread_mutex_destroy (L);
 247       pragma Assert (Result = 0);
 248    end Finalize_Lock;
 249
 250    ----------------
 251    -- Write_Lock --
 252    ----------------
 253
 254    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 255       Result : Interfaces.C.int;
 256    begin
 257       Result := pthread_mutex_lock (L);
 258       Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL;
 259       pragma Assert (Result /= FUNC_ERR);
 260    end Write_Lock;
 261
 262    procedure Write_Lock
 263      (L : access RTS_Lock; Global_Lock : Boolean := False)
 264    is
 265       Result : Interfaces.C.int;
 266    begin
 267       if not Single_Lock or else Global_Lock then
 268          Result := pthread_mutex_lock (L);
 269          pragma Assert (Result = 0);
 270       end if;
 271    end Write_Lock;
 272
 273    procedure Write_Lock (T : Task_Id) is
 274       Result : Interfaces.C.int;
 275    begin
 276       if not Single_Lock then
 277          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 278          pragma Assert (Result = 0);
 279       end if;
 280    end Write_Lock;
 281
 282    ---------------
 283    -- Read_Lock --
 284    ---------------
 285
 286    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 287    begin
 288       Write_Lock (L, Ceiling_Violation);
 289    end Read_Lock;
 290
 291    ------------
 292    -- Unlock --
 293    ------------
 294
 295    procedure Unlock (L : access Lock) is
 296       Result : Interfaces.C.int;
 297    begin
 298       Result := pthread_mutex_unlock (L);
 299       pragma Assert (Result = 0);
 300    end Unlock;
 301
 302    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 303       Result : Interfaces.C.int;
 304    begin
 305       if not Single_Lock or else Global_Lock then
 306          Result := pthread_mutex_unlock (L);
 307          pragma Assert (Result = 0);
 308       end if;
 309    end Unlock;
 310
 311    procedure Unlock (T : Task_Id) is
 312       Result : Interfaces.C.int;
 313    begin
 314       if not Single_Lock then
 315          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 316          pragma Assert (Result = 0);
 317       end if;
 318    end Unlock;
 319
 320    -----------
 321    -- Sleep --
 322    -----------
 323
 324    procedure Sleep
 325      (Self_ID  : ST.Task_Id;
 326       Reason   : System.Tasking.Task_States)
 327    is
 328       pragma Unreferenced (Reason);
 329
 330       Result : Interfaces.C.int;
 331
 332    begin
 333       if Single_Lock then
 334          Result := pthread_cond_wait
 335            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 336       else
 337          Result := pthread_cond_wait
 338            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 339       end if;
 340
 341       --  EINTR is not considered a failure.
 342
 343       pragma Assert (Result = 0 or else Result = EINTR);
 344    end Sleep;
 345
 346    -----------------
 347    -- Timed_Sleep --
 348    -----------------
 349
 350    procedure Timed_Sleep
 351      (Self_ID  : Task_Id;
 352       Time     : Duration;
 353       Mode     : ST.Delay_Modes;
 354       Reason   : System.Tasking.Task_States;
 355       Timedout : out Boolean;
 356       Yielded  : out Boolean)
 357    is
 358       pragma Unreferenced (Reason);
 359
 360       Check_Time : constant Duration := Monotonic_Clock;
 361       Abs_Time   : Duration;
 362       Request    : aliased struct_timeval;
 363       Result     : Interfaces.C.int;
 364
 365    begin
 366       Timedout := True;
 367       Yielded := False;
 368
 369       if Mode = Relative then
 370          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 371       else
 372          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 373       end if;
 374
 375       if Abs_Time > Check_Time then
 376          Request := To_Timeval (Abs_Time);
 377
 378          loop
 379             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 380               or else Self_ID.Pending_Priority_Change;
 381
 382             if Single_Lock then
 383                Result := pthread_cond_timedwait
 384                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
 385                   Request'Access);
 386
 387             else
 388                Result := pthread_cond_timedwait
 389                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
 390                   Request'Access);
 391             end if;
 392
 393             exit when Abs_Time <= Monotonic_Clock;
 394
 395             if Result = 0 or Result = EINTR then
 396                --  somebody may have called Wakeup for us
 397                Timedout := False;
 398                exit;
 399             end if;
 400
 401             pragma Assert (Result = ETIMEDOUT
 402               or else (Result = -1 and then errno = EAGAIN));
 403          end loop;
 404       end if;
 405    end Timed_Sleep;
 406
 407    -----------------
 408    -- Timed_Delay --
 409    -----------------
 410
 411    procedure Timed_Delay
 412      (Self_ID  : Task_Id;
 413       Time     : Duration;
 414       Mode     : ST.Delay_Modes)
 415    is
 416       Check_Time : constant Duration := Monotonic_Clock;
 417       Abs_Time   : Duration;
 418       Request    : aliased struct_timeval;
 419       Result     : Interfaces.C.int;
 420
 421    begin
 422       if Single_Lock then
 423          Lock_RTS;
 424       end if;
 425
 426       Write_Lock (Self_ID);
 427
 428       if Mode = Relative then
 429          Abs_Time := Time + Check_Time;
 430       else
 431          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 432       end if;
 433
 434       if Abs_Time > Check_Time then
 435          Request := To_Timeval (Abs_Time);
 436          Self_ID.Common.State := Delay_Sleep;
 437
 438          loop
 439             if Self_ID.Pending_Priority_Change then
 440                Self_ID.Pending_Priority_Change := False;
 441                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 442                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 443             end if;
 444
 445             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 446
 447             if Single_Lock then
 448                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 449                  Single_RTS_Lock'Access, Request'Access);
 450             else
 451                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 452                  Self_ID.Common.LL.L'Access, Request'Access);
 453             end if;
 454
 455             exit when Abs_Time <= Monotonic_Clock;
 456
 457             pragma Assert (Result = 0 or else
 458               Result = ETIMEDOUT or else
 459               (Result = -1 and then errno = EAGAIN) or else
 460               Result = EINTR);
 461          end loop;
 462
 463          Self_ID.Common.State := Runnable;
 464       end if;
 465
 466       Unlock (Self_ID);
 467
 468       if Single_Lock then
 469          Unlock_RTS;
 470       end if;
 471
 472       pthread_yield;
 473    end Timed_Delay;
 474
 475    ---------------------
 476    -- Monotonic_Clock --
 477    ---------------------
 478
 479    function Monotonic_Clock return Duration is
 480       type timeval is record
 481          tv_sec  : Integer;
 482          tv_usec : Integer;
 483       end record;
 484       pragma Convention (C, timeval);
 485
 486       tv : aliased timeval;
 487
 488       procedure gettimeofday (tp : access timeval);
 489       pragma Import (C, gettimeofday, "gettimeofday", "gettimeofday");
 490
 491    begin
 492       gettimeofday (tv'Access);
 493       return Duration (tv.tv_sec) + Duration (tv.tv_usec) / 1_000_000.0;
 494    end Monotonic_Clock;
 495
 496    -------------------
 497    -- RT_Resolution --
 498    -------------------
 499
 500    function RT_Resolution return Duration is
 501    begin
 502       return 10#1.0#E-6;
 503    end RT_Resolution;
 504
 505    ------------
 506    -- Wakeup --
 507    ------------
 508
 509    procedure Wakeup
 510      (T : ST.Task_Id;
 511       Reason : System.Tasking.Task_States)
 512    is
 513       pragma Unreferenced (Reason);
 514       Result : Interfaces.C.int;
 515    begin
 516       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 517       pragma Assert (Result = 0);
 518    end Wakeup;
 519
 520    -----------
 521    -- Yield --
 522    -----------
 523
 524    procedure Yield (Do_Yield : Boolean := True) is
 525    begin
 526       if Do_Yield then
 527          pthread_yield;
 528       end if;
 529    end Yield;
 530
 531    ------------------
 532    -- Set_Priority --
 533    ------------------
 534
 535    procedure Set_Priority
 536      (T                   : Task_Id;
 537       Prio                : System.Any_Priority;
 538       Loss_Of_Inheritance : Boolean := False)
 539    is
 540       pragma Unreferenced (Loss_Of_Inheritance);
 541
 542       Result : Interfaces.C.int;
 543
 544    begin
 545       T.Common.Current_Priority := Prio;
 546       Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
 547       pragma Assert (Result /= FUNC_ERR);
 548    end Set_Priority;
 549
 550    ------------------
 551    -- Get_Priority --
 552    ------------------
 553
 554    function Get_Priority (T : Task_Id) return System.Any_Priority is
 555    begin
 556       return T.Common.Current_Priority;
 557    end Get_Priority;
 558
 559    ----------------
 560    -- Enter_Task --
 561    ----------------
 562
 563    procedure Enter_Task (Self_ID : Task_Id) is
 564       Result : Interfaces.C.int;
 565
 566    begin
 567       Self_ID.Common.LL.Thread := pthread_self;
 568       Self_ID.Common.LL.LWP := sproc_self;
 569
 570       Result :=
 571         pthread_set_ada_tcb (Self_ID.Common.LL.Thread, To_Address (Self_ID));
 572
 573       pragma Assert (Result = 0);
 574
 575       Lock_RTS;
 576
 577       for J in Known_Tasks'Range loop
 578          if Known_Tasks (J) = null then
 579             Known_Tasks (J) := Self_ID;
 580             Self_ID.Known_Tasks_Index := J;
 581             exit;
 582          end if;
 583       end loop;
 584
 585       Unlock_RTS;
 586    end Enter_Task;
 587
 588    --------------
 589    -- New_ATCB --
 590    --------------
 591
 592    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 593    begin
 594       return new Ada_Task_Control_Block (Entry_Num);
 595    end New_ATCB;
 596
 597    -------------------
 598    -- Is_Valid_Task --
 599    -------------------
 600
 601    function Is_Valid_Task return Boolean is
 602    begin
 603       return False;
 604    end Is_Valid_Task;
 605
 606    -----------------------------
 607    -- Register_Foreign_Thread --
 608    -----------------------------
 609
 610    function Register_Foreign_Thread return Task_Id is
 611    begin
 612       return null;
 613    end Register_Foreign_Thread;
 614
 615    --------------------
 616    -- Initialize_TCB --
 617    --------------------
 618
 619    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 620       Result    : Interfaces.C.int;
 621       Cond_Attr : aliased pthread_condattr_t;
 622
 623    begin
 624       if not Single_Lock then
 625          Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
 626       end if;
 627
 628       Result := pthread_condattr_init (Cond_Attr'Access);
 629       pragma Assert (Result = 0 or else Result = ENOMEM);
 630
 631       if Result = 0 then
 632          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 633            Cond_Attr'Access);
 634          pragma Assert (Result = 0 or else Result = ENOMEM);
 635       end if;
 636
 637       if Result = 0 then
 638          Succeeded := True;
 639       else
 640          if not Single_Lock then
 641             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 642             pragma Assert (Result = 0);
 643          end if;
 644
 645          Succeeded := False;
 646       end if;
 647
 648       Result := pthread_condattr_destroy (Cond_Attr'Access);
 649       pragma Assert (Result = 0);
 650    end Initialize_TCB;
 651
 652    -----------------
 653    -- Create_Task --
 654    -----------------
 655
 656    procedure Create_Task
 657      (T          : Task_Id;
 658       Wrapper    : System.Address;
 659       Stack_Size : System.Parameters.Size_Type;
 660       Priority   : System.Any_Priority;
 661       Succeeded  : out Boolean)
 662    is
 663       Attributes          : aliased pthread_attr_t;
 664       Adjusted_Stack_Size : Interfaces.C.size_t;
 665       Result              : Interfaces.C.int;
 666
 667       function Thread_Body_Access is new
 668         Unchecked_Conversion (System.Address, start_addr);
 669
 670       function To_Resource_T is new Unchecked_Conversion
 671         (System.Task_Info.Resource_Vector_T, System.OS_Interface.resource_t);
 672
 673       use System.Task_Info;
 674
 675    begin
 676       if Stack_Size = Unspecified_Size then
 677          Adjusted_Stack_Size :=
 678            Interfaces.C.size_t (System.Program_Info.Default_Task_Stack);
 679
 680       elsif Stack_Size < Minimum_Stack_Size then
 681          Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
 682
 683       else
 684          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 685       end if;
 686
 687       Result := pthread_attr_init (Attributes'Access);
 688       pragma Assert (Result = 0 or else Result = ENOMEM);
 689
 690       if Result /= 0 then
 691          Succeeded := False;
 692          return;
 693       end if;
 694
 695       Result := pthread_attr_setdetachstate (Attributes'Access, 1);
 696       pragma Assert (Result = 0);
 697
 698       Result := pthread_attr_setstacksize
 699         (Attributes'Access, Adjusted_Stack_Size);
 700       pragma Assert (Result = 0);
 701
 702       if T.Common.Task_Info /= null then
 703          Result := pthread_attr_setresources
 704            (Attributes'Access,
 705             To_Resource_T (T.Common.Task_Info.Thread_Resources));
 706          pragma Assert (Result /= FUNC_ERR);
 707
 708          if T.Common.Task_Info.Thread_Timeslice /= 0.0 then
 709             declare
 710                use System.OS_Interface;
 711
 712                Tv : aliased struct_timeval := To_Timeval
 713                  (T.Common.Task_Info.Thread_Timeslice);
 714             begin
 715                Result := pthread_attr_set_tslice
 716                  (Attributes'Access, Tv'Access);
 717             end;
 718          end if;
 719
 720          if T.Common.Task_Info.Bound_To_Sproc then
 721             Result := pthread_attr_set_boundtosproc
 722               (Attributes'Access, PTHREAD_BOUND);
 723             Result := pthread_attr_set_bsproc
 724               (Attributes'Access, T.Common.Task_Info.Sproc);
 725          end if;
 726
 727       end if;
 728
 729       --  Since the initial signal mask of a thread is inherited from the
 730       --  creator, and the Environment task has all its signals masked, we
 731       --  do not need to manipulate caller's signal mask at this point.
 732       --  All tasks in RTS will have All_Tasks_Mask initially.
 733
 734       Result := pthread_create
 735         (T.Common.LL.Thread'Access,
 736          Attributes'Access,
 737          Thread_Body_Access (Wrapper),
 738          To_Address (T));
 739       pragma Assert (Result = 0 or else Result = EAGAIN);
 740
 741       Succeeded := Result = 0;
 742
 743       Set_Priority (T, Priority);
 744
 745       Result := pthread_attr_destroy (Attributes'Access);
 746       pragma Assert (Result /= FUNC_ERR);
 747    end Create_Task;
 748
 749    ------------------
 750    -- Finalize_TCB --
 751    ------------------
 752
 753    procedure Finalize_TCB (T : Task_Id) is
 754       procedure Free is new
 755         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 756
 757       Result : Interfaces.C.int;
 758       Tmp    : Task_Id := T;
 759
 760    begin
 761       if not Single_Lock then
 762          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 763          pragma Assert (Result = 0);
 764       end if;
 765
 766       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 767       pragma Assert (Result = 0);
 768
 769       if T.Known_Tasks_Index /= -1 then
 770          Known_Tasks (T.Known_Tasks_Index) := null;
 771       end if;
 772
 773       Free (Tmp);
 774    end Finalize_TCB;
 775
 776    ---------------
 777    -- Exit_Task --
 778    ---------------
 779
 780    procedure Exit_Task is
 781       Result : Interfaces.C.int;
 782    begin
 783       Result := pthread_set_ada_tcb (pthread_self, System.Null_Address);
 784       pragma Assert (Result = 0);
 785    end Exit_Task;
 786
 787    ----------------
 788    -- Abort_Task --
 789    ----------------
 790
 791    procedure Abort_Task (T : Task_Id) is
 792       Result : Interfaces.C.int;
 793    begin
 794       Result :=
 795         pthread_kill (T.Common.LL.Thread,
 796                       Interfaces.C.int
 797                         (System.Interrupt_Management.Abort_Task_Interrupt));
 798       pragma Assert (Result = 0);
 799    end Abort_Task;
 800
 801    ----------------
 802    -- Initialize --
 803    ----------------
 804
 805    procedure Initialize (S : in out Suspension_Object) is
 806       Mutex_Attr : aliased pthread_mutexattr_t;
 807       Cond_Attr  : aliased pthread_condattr_t;
 808       Result     : Interfaces.C.int;
 809    begin
 810       --  Initialize internal state. It is always initialized to False (ARM
 811       --  D.10 par. 6).
 812
 813       S.State := False;
 814       S.Waiting := False;
 815
 816       --  Initialize internal mutex
 817
 818       Result := pthread_mutexattr_init (Mutex_Attr'Access);
 819       pragma Assert (Result = 0 or else Result = ENOMEM);
 820
 821       if Result = ENOMEM then
 822          raise Storage_Error;
 823       end if;
 824
 825       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
 826       pragma Assert (Result = 0 or else Result = ENOMEM);
 827
 828       if Result = ENOMEM then
 829          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 830          pragma Assert (Result = 0);
 831
 832          raise Storage_Error;
 833       end if;
 834
 835       Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 836       pragma Assert (Result = 0);
 837
 838       --  Initialize internal condition variable
 839
 840       Result := pthread_condattr_init (Cond_Attr'Access);
 841       pragma Assert (Result = 0 or else Result = ENOMEM);
 842
 843       if Result /= 0 then
 844          Result := pthread_mutex_destroy (S.L'Access);
 845          pragma Assert (Result = 0);
 846
 847          if Result = ENOMEM then
 848             raise Storage_Error;
 849          end if;
 850       end if;
 851
 852       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
 853       pragma Assert (Result = 0 or else Result = ENOMEM);
 854
 855       if Result /= 0 then
 856          Result := pthread_mutex_destroy (S.L'Access);
 857          pragma Assert (Result = 0);
 858
 859          if Result = ENOMEM then
 860             Result := pthread_condattr_destroy (Cond_Attr'Access);
 861             pragma Assert (Result = 0);
 862
 863             raise Storage_Error;
 864          end if;
 865       end if;
 866
 867       Result := pthread_condattr_destroy (Cond_Attr'Access);
 868       pragma Assert (Result = 0);
 869    end Initialize;
 870
 871    --------------
 872    -- Finalize --
 873    --------------
 874
 875    procedure Finalize (S : in out Suspension_Object) is
 876       Result  : Interfaces.C.int;
 877    begin
 878       --  Destroy internal mutex
 879
 880       Result := pthread_mutex_destroy (S.L'Access);
 881       pragma Assert (Result = 0);
 882
 883       --  Destroy internal condition variable
 884
 885       Result := pthread_cond_destroy (S.CV'Access);
 886       pragma Assert (Result = 0);
 887    end Finalize;
 888
 889    -------------------
 890    -- Current_State --
 891    -------------------
 892
 893    function Current_State (S : Suspension_Object) return Boolean is
 894    begin
 895       --  We do not want to use lock on this read operation. State is marked
 896       --  as Atomic so that we ensure that the value retrieved is correct.
 897
 898       return S.State;
 899    end Current_State;
 900
 901    ---------------
 902    -- Set_False --
 903    ---------------
 904
 905    procedure Set_False (S : in out Suspension_Object) is
 906       Result  : Interfaces.C.int;
 907    begin
 908       Result := pthread_mutex_lock (S.L'Access);
 909       pragma Assert (Result = 0);
 910
 911       S.State := False;
 912
 913       Result := pthread_mutex_unlock (S.L'Access);
 914       pragma Assert (Result = 0);
 915    end Set_False;
 916
 917    --------------
 918    -- Set_True --
 919    --------------
 920
 921    procedure Set_True (S : in out Suspension_Object) is
 922       Result : Interfaces.C.int;
 923    begin
 924       Result := pthread_mutex_lock (S.L'Access);
 925       pragma Assert (Result = 0);
 926
 927       --  If there is already a task waiting on this suspension object then
 928       --  we resume it, leaving the state of the suspension object to False,
 929       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
 930       --  the state to True.
 931
 932       if S.Waiting then
 933          S.Waiting := False;
 934          S.State := False;
 935
 936          Result := pthread_cond_signal (S.CV'Access);
 937          pragma Assert (Result = 0);
 938       else
 939          S.State := True;
 940       end if;
 941
 942       Result := pthread_mutex_unlock (S.L'Access);
 943       pragma Assert (Result = 0);
 944    end Set_True;
 945
 946    ------------------------
 947    -- Suspend_Until_True --
 948    ------------------------
 949
 950    procedure Suspend_Until_True (S : in out Suspension_Object) is
 951       Result : Interfaces.C.int;
 952    begin
 953       Result := pthread_mutex_lock (S.L'Access);
 954       pragma Assert (Result = 0);
 955
 956       if S.Waiting then
 957          --  Program_Error must be raised upon calling Suspend_Until_True
 958          --  if another task is already waiting on that suspension object
 959          --  (ARM D.10 par. 10).
 960
 961          Result := pthread_mutex_unlock (S.L'Access);
 962          pragma Assert (Result = 0);
 963
 964          raise Program_Error;
 965       else
 966          --  Suspend the task if the state is False. Otherwise, the task
 967          --  continues its execution, and the state of the suspension object
 968          --  is set to False (ARM D.10 par. 9).
 969
 970          if S.State then
 971             S.State := False;
 972          else
 973             S.Waiting := True;
 974             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
 975          end if;
 976       end if;
 977
 978       Result := pthread_mutex_unlock (S.L'Access);
 979       pragma Assert (Result = 0);
 980    end Suspend_Until_True;
 981
 982    ----------------
 983    -- Check_Exit --
 984    ----------------
 985
 986    --  Dummy version
 987
 988    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
 989       pragma Unreferenced (Self_ID);
 990    begin
 991       return True;
 992    end Check_Exit;
 993
 994    --------------------
 995    -- Check_No_Locks --
 996    --------------------
 997
 998    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
 999       pragma Unreferenced (Self_ID);
1000    begin
1001       return True;
1002    end Check_No_Locks;
1003
1004    ----------------------
1005    -- Environment_Task --
1006    ----------------------
1007
1008    function Environment_Task return Task_Id is
1009    begin
1010       return Environment_Task_Id;
1011    end Environment_Task;
1012
1013    --------------
1014    -- Lock_RTS --
1015    --------------
1016
1017    procedure Lock_RTS is
1018    begin
1019       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1020    end Lock_RTS;
1021
1022    ----------------
1023    -- Unlock_RTS --
1024    ----------------
1025
1026    procedure Unlock_RTS is
1027    begin
1028       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1029    end Unlock_RTS;
1030
1031    ------------------
1032    -- Suspend_Task --
1033    ------------------
1034
1035    function Suspend_Task
1036      (T           : ST.Task_Id;
1037       Thread_Self : Thread_Id) return Boolean
1038    is
1039    begin
1040       if T.Common.LL.Thread /= Thread_Self then
1041          return pthread_suspend (T.Common.LL.Thread) = 0;
1042       else
1043          return True;
1044       end if;
1045    end Suspend_Task;
1046
1047    -----------------
1048    -- Resume_Task --
1049    -----------------
1050
1051    function Resume_Task
1052      (T           : ST.Task_Id;
1053       Thread_Self : Thread_Id) return Boolean
1054    is
1055    begin
1056       if T.Common.LL.Thread /= Thread_Self then
1057          return pthread_resume (T.Common.LL.Thread) = 0;
1058       else
1059          return True;
1060       end if;
1061    end Resume_Task;
1062
1063    ----------------
1064    -- Initialize --
1065    ----------------
1066
1067    procedure Initialize (Environment_Task : Task_Id) is
1068    begin
1069       Initialize_Athread_Library;
1070       Environment_Task_Id := Environment_Task;
1071       Interrupt_Management.Initialize;
1072
1073       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1074       --  Initialize the lock used to synchronize chain of all ATCBs.
1075
1076       Enter_Task (Environment_Task);
1077
1078       Set_Priority (Environment_Task,
1079         Environment_Task.Common.Current_Priority);
1080    end Initialize;
1081
1082    --------------------------------
1083    -- Initialize_Athread_Library --
1084    --------------------------------
1085
1086    procedure Initialize_Athread_Library is
1087       Result : Interfaces.C.int;
1088       Init   : aliased pthread_init_struct;
1089
1090       package PINF renames System.Program_Info;
1091       package C    renames Interfaces.C;
1092
1093    begin
1094       Init.conf_initsize       := C.int (PINF.Pthread_Arena_Size);
1095       Init.max_sproc_count     := C.int (PINF.Max_Sproc_Count);
1096       Init.sproc_stack_size    := C.size_t (PINF.Sproc_Stack_Size);
1097       Init.os_default_priority := C.int (PINF.Os_Default_Priority);
1098       Init.os_sched_signal     := C.int (PINF.Pthread_Sched_Signal);
1099       Init.guard_pages         := C.int (PINF.Stack_Guard_Pages);
1100       Init.init_sproc_count    := C.int (PINF.Initial_Sproc_Count);
1101
1102       Result := pthread_exec_begin (Init'Access);
1103       pragma Assert (Result /= FUNC_ERR);
1104
1105       if Result = FUNC_ERR then
1106          raise Storage_Error;               --  Insufficient resources
1107       end if;
1108    end Initialize_Athread_Library;
1109
1110 end System.Task_Primitives.Operations;