gcc/ada/5ftaprop.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 --                             $Revision: 1.26 $
  10 --                                                                          --
  11 --            Copyright (C) 1991-2001, Florida State University             --
  12 --                                                                          --
  13 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNARL was developed by the GNARL team at Florida State University. It is --
  32 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  33 -- State University (http://www.gnat.com).                                  --
  34 --                                                                          --
  35 ------------------------------------------------------------------------------
  36
  37 --  This is a IRIX (pthread library) version of this package.
  38
  39 --  This package contains all the GNULL primitives that interface directly
  40 --  with the underlying OS.
  41
  42 pragma Polling (Off);
  43 --  Turn off polling, we do not want ATC polling to take place during
  44 --  tasking operations. It causes infinite loops and other problems.
  45
  46 with Interfaces.C;
  47 --  used for int
  48 --           size_t
  49
  50 with System.Task_Info;
  51
  52 with System.Tasking.Debug;
  53 --  used for Known_Tasks
  54
  55 with System.IO;
  56 --  used for Put_Line
  57
  58 with System.Interrupt_Management;
  59 --  used for Keep_Unmasked
  60 --           Abort_Task_Interrupt
  61 --           Interrupt_ID
  62
  63 with System.Interrupt_Management.Operations;
  64 --  used for Set_Interrupt_Mask
  65 --           All_Tasks_Mask
  66 pragma Elaborate_All (System.Interrupt_Management.Operations);
  67
  68 with System.Parameters;
  69 --  used for Size_Type
  70
  71 with System.Tasking;
  72 --  used for Ada_Task_Control_Block
  73 --           Task_ID
  74
  75 with System.Soft_Links;
  76 --  used for Defer/Undefer_Abort
  77
  78 --  Note that we do not use System.Tasking.Initialization directly since
  79 --  this is a higher level package that we shouldn't depend on. For example
  80 --  when using the restricted run time, it is replaced by
  81 --  System.Tasking.Restricted.Initialization
  82
  83 with System.Program_Info;
  84 --  used for Default_Task_Stack
  85 --           Default_Time_Slice
  86 --           Stack_Guard_Pages
  87 --           Pthread_Sched_Signal
  88 --           Pthread_Arena_Size
  89
  90 with System.OS_Interface;
  91 --  used for various type, constant, and operations
  92
  93 with System.OS_Primitives;
  94 --  used for Delay_Modes
  95
  96 with Unchecked_Conversion;
  97 with Unchecked_Deallocation;
  98
  99 package body System.Task_Primitives.Operations is
 100
 101    use System.Tasking;
 102    use System.Tasking.Debug;
 103    use Interfaces.C;
 104    use System.OS_Interface;
 105    use System.OS_Primitives;
 106    use System.Parameters;
 107
 108    package SSL renames System.Soft_Links;
 109
 110    ------------------
 111    --  Local Data  --
 112    ------------------
 113
 114    --  The followings are logically constants, but need to be initialized
 115    --  at run time.
 116
 117    ATCB_Key : aliased pthread_key_t;
 118    --  Key used to find the Ada Task_ID associated with a thread
 119
 120    All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
 121    --  See comments on locking rules in System.Locking_Rules (spec).
 122
 123    Environment_Task_ID : Task_ID;
 124    --  A variable to hold Task_ID for the environment task.
 125
 126    Locking_Policy : Character;
 127    pragma Import (C, Locking_Policy, "__gl_locking_policy");
 128
 129    Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME;
 130
 131    Unblocked_Signal_Mask : aliased sigset_t;
 132
 133    -----------------------
 134    -- Local Subprograms --
 135    -----------------------
 136
 137    function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
 138
 139    function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
 140
 141    procedure Abort_Handler (Sig : Signal);
 142
 143    -------------------
 144    -- Abort_Handler --
 145    -------------------
 146
 147    procedure Abort_Handler (Sig : Signal) is
 148       T       : Task_ID := Self;
 149       Result  : Interfaces.C.int;
 150       Old_Set : aliased sigset_t;
 151
 152    begin
 153       if T.Deferral_Level = 0
 154         and then T.Pending_ATC_Level < T.ATC_Nesting_Level
 155       then
 156          --  Make sure signals used for RTS internal purpose are unmasked
 157
 158          Result := pthread_sigmask
 159            (SIG_UNBLOCK,
 160             Unblocked_Signal_Mask'Unchecked_Access,
 161             Old_Set'Unchecked_Access);
 162          pragma Assert (Result = 0);
 163
 164          raise Standard'Abort_Signal;
 165       end if;
 166    end Abort_Handler;
 167
 168    -----------------
 169    -- Stack_Guard --
 170    -----------------
 171
 172    --  The underlying thread system sets a guard page at the
 173    --  bottom of a thread stack, so nothing is needed.
 174
 175    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
 176    begin
 177       null;
 178    end Stack_Guard;
 179
 180    -------------------
 181    -- Get_Thread_Id --
 182    -------------------
 183
 184    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
 185    begin
 186       return T.Common.LL.Thread;
 187    end Get_Thread_Id;
 188
 189    ----------
 190    -- Self --
 191    ----------
 192
 193    function Self return Task_ID is
 194       Result : System.Address;
 195
 196    begin
 197       Result := pthread_getspecific (ATCB_Key);
 198       pragma Assert (Result /= System.Null_Address);
 199
 200       return To_Task_ID (Result);
 201    end Self;
 202
 203    ---------------------
 204    -- Initialize_Lock --
 205    ---------------------
 206
 207    --  Note: mutexes and cond_variables needed per-task basis are
 208    --        initialized in Intialize_TCB and the Storage_Error is
 209    --        handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
 210    --        used in RTS is initialized before any status change of RTS.
 211    --        Therefore rasing Storage_Error in the following routines
 212    --        should be able to be handled safely.
 213
 214    procedure Initialize_Lock
 215      (Prio : System.Any_Priority;
 216       L    : access Lock)
 217    is
 218       Attributes : aliased pthread_mutexattr_t;
 219       Result     : Interfaces.C.int;
 220
 221    begin
 222       Result := pthread_mutexattr_init (Attributes'Access);
 223       pragma Assert (Result = 0 or else Result = ENOMEM);
 224
 225       if Result = ENOMEM then
 226          raise Storage_Error;
 227       end if;
 228
 229       if Locking_Policy = 'C' then
 230          Result := pthread_mutexattr_setprotocol
 231            (Attributes'Access, PTHREAD_PRIO_PROTECT);
 232          pragma Assert (Result = 0);
 233
 234          Result := pthread_mutexattr_setprioceiling
 235             (Attributes'Access, Interfaces.C.int (Prio));
 236          pragma Assert (Result = 0);
 237       end if;
 238
 239       Result := pthread_mutex_init (L, Attributes'Access);
 240       pragma Assert (Result = 0 or else Result = ENOMEM);
 241
 242       if Result = ENOMEM then
 243          Result := pthread_mutexattr_destroy (Attributes'Access);
 244          raise Storage_Error;
 245       end if;
 246
 247       Result := pthread_mutexattr_destroy (Attributes'Access);
 248       pragma Assert (Result = 0);
 249    end Initialize_Lock;
 250
 251    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 252       Attributes : aliased pthread_mutexattr_t;
 253       Result : Interfaces.C.int;
 254
 255    begin
 256       Result := pthread_mutexattr_init (Attributes'Access);
 257       pragma Assert (Result = 0 or else Result = ENOMEM);
 258
 259       if Result = ENOMEM then
 260          raise Storage_Error;
 261       end if;
 262
 263       if Locking_Policy = 'C' then
 264          Result := pthread_mutexattr_setprotocol
 265            (Attributes'Access, PTHREAD_PRIO_PROTECT);
 266          pragma Assert (Result = 0);
 267
 268          Result := pthread_mutexattr_setprioceiling
 269             (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
 270          pragma Assert (Result = 0);
 271       end if;
 272
 273       Result := pthread_mutex_init (L, Attributes'Access);
 274
 275       pragma Assert (Result = 0 or else Result = ENOMEM);
 276
 277       if Result = ENOMEM then
 278          Result := pthread_mutexattr_destroy (Attributes'Access);
 279          raise Storage_Error;
 280       end if;
 281
 282       Result := pthread_mutexattr_destroy (Attributes'Access);
 283    end Initialize_Lock;
 284
 285    -------------------
 286    -- Finalize_Lock --
 287    -------------------
 288
 289    procedure Finalize_Lock (L : access Lock) is
 290       Result : Interfaces.C.int;
 291
 292    begin
 293       Result := pthread_mutex_destroy (L);
 294       pragma Assert (Result = 0);
 295    end Finalize_Lock;
 296
 297    procedure Finalize_Lock (L : access RTS_Lock) is
 298       Result : Interfaces.C.int;
 299
 300    begin
 301       Result := pthread_mutex_destroy (L);
 302       pragma Assert (Result = 0);
 303    end Finalize_Lock;
 304
 305    ----------------
 306    -- Write_Lock --
 307    ----------------
 308
 309    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 310       Result : Interfaces.C.int;
 311
 312    begin
 313       Result := pthread_mutex_lock (L);
 314       Ceiling_Violation := Result = EINVAL;
 315
 316       --  assumes the cause of EINVAL is a priority ceiling violation
 317
 318       pragma Assert (Result = 0 or else Result = EINVAL);
 319    end Write_Lock;
 320
 321    procedure Write_Lock (L : access RTS_Lock) is
 322       Result : Interfaces.C.int;
 323
 324    begin
 325       Result := pthread_mutex_lock (L);
 326       pragma Assert (Result = 0);
 327    end Write_Lock;
 328
 329    procedure Write_Lock (T : Task_ID) is
 330       Result : Interfaces.C.int;
 331
 332    begin
 333       Result := pthread_mutex_lock (T.Common.LL.L'Access);
 334       pragma Assert (Result = 0);
 335    end Write_Lock;
 336
 337    ---------------
 338    -- Read_Lock --
 339    ---------------
 340
 341    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 342    begin
 343       Write_Lock (L, Ceiling_Violation);
 344    end Read_Lock;
 345
 346    ------------
 347    -- Unlock --
 348    ------------
 349
 350    procedure Unlock (L : access Lock) is
 351       Result : Interfaces.C.int;
 352
 353    begin
 354       Result := pthread_mutex_unlock (L);
 355       pragma Assert (Result = 0);
 356    end Unlock;
 357
 358    procedure Unlock (L : access RTS_Lock) is
 359       Result : Interfaces.C.int;
 360
 361    begin
 362       Result := pthread_mutex_unlock (L);
 363       pragma Assert (Result = 0);
 364    end Unlock;
 365
 366    procedure Unlock (T : Task_ID) is
 367       Result : Interfaces.C.int;
 368
 369    begin
 370       Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 371       pragma Assert (Result = 0);
 372    end Unlock;
 373
 374    -----------
 375    -- Sleep --
 376    -----------
 377
 378    procedure Sleep
 379      (Self_ID : ST.Task_ID;
 380       Reason  : System.Tasking.Task_States)
 381    is
 382       Result : Interfaces.C.int;
 383    begin
 384       pragma Assert (Self_ID = Self);
 385       Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
 386         Self_ID.Common.LL.L'Access);
 387
 388       --  EINTR is not considered a failure.
 389
 390       pragma Assert (Result = 0 or else Result = EINTR);
 391    end Sleep;
 392
 393    -----------------
 394    -- Timed_Sleep --
 395    -----------------
 396
 397    procedure Timed_Sleep
 398      (Self_ID  : Task_ID;
 399       Time     : Duration;
 400       Mode     : ST.Delay_Modes;
 401       Reason   : Task_States;
 402       Timedout : out Boolean;
 403       Yielded  : out Boolean)
 404    is
 405       Check_Time : constant Duration := Monotonic_Clock;
 406       Abs_Time   : Duration;
 407       Request    : aliased timespec;
 408       Result     : Interfaces.C.int;
 409
 410    begin
 411       Timedout := True;
 412       Yielded  := False;
 413
 414       if Mode = Relative then
 415          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 416       else
 417          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 418       end if;
 419
 420       if Abs_Time > Check_Time then
 421          Request := To_Timespec (Abs_Time);
 422
 423          loop
 424             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 425               or else Self_ID.Pending_Priority_Change;
 426
 427             Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 428               Self_ID.Common.LL.L'Access, Request'Access);
 429
 430             exit when Abs_Time <= Monotonic_Clock;
 431
 432             if Result = 0 or else errno = EINTR then
 433                Timedout := False;
 434                exit;
 435             end if;
 436          end loop;
 437       end if;
 438    end Timed_Sleep;
 439
 440    -----------------
 441    -- Timed_Delay --
 442    -----------------
 443
 444    --  This is for use in implementing delay statements, so
 445    --  we assume the caller is abort-deferred but is holding
 446    --  no locks.
 447
 448    procedure Timed_Delay
 449      (Self_ID : Task_ID;
 450       Time    : Duration;
 451       Mode    : ST.Delay_Modes)
 452    is
 453       Check_Time : constant Duration := Monotonic_Clock;
 454       Abs_Time   : Duration;
 455       Request    : aliased timespec;
 456       Result     : Interfaces.C.int;
 457
 458    begin
 459       --  Only the little window between deferring abort and
 460       --  locking Self_ID is the reason we need to
 461       --  check for pending abort and priority change below! :(
 462
 463       SSL.Abort_Defer.all;
 464       Write_Lock (Self_ID);
 465
 466       if Mode = Relative then
 467          Abs_Time := Time + Check_Time;
 468       else
 469          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 470       end if;
 471
 472       if Abs_Time > Check_Time then
 473          Request := To_Timespec (Abs_Time);
 474          Self_ID.Common.State := Delay_Sleep;
 475
 476          loop
 477             if Self_ID.Pending_Priority_Change then
 478                Self_ID.Pending_Priority_Change := False;
 479                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 480                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 481             end if;
 482
 483             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 484
 485             Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 486               Self_ID.Common.LL.L'Access, Request'Access);
 487             exit when Abs_Time <= Monotonic_Clock;
 488
 489             pragma Assert (Result = 0
 490               or else Result = ETIMEDOUT
 491               or else Result = EINTR);
 492          end loop;
 493
 494          Self_ID.Common.State := Runnable;
 495       end if;
 496
 497       Unlock (Self_ID);
 498       Yield;
 499       SSL.Abort_Undefer.all;
 500    end Timed_Delay;
 501
 502    ---------------------
 503    -- Monotonic_Clock --
 504    ---------------------
 505
 506    function Monotonic_Clock return Duration is
 507       TS     : aliased timespec;
 508       Result : Interfaces.C.int;
 509
 510    begin
 511       Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access);
 512       pragma Assert (Result = 0);
 513       return To_Duration (TS);
 514    end Monotonic_Clock;
 515
 516    -------------------
 517    -- RT_Resolution --
 518    -------------------
 519
 520    function RT_Resolution return Duration is
 521    begin
 522       --  The clock_getres (Real_Time_Clock_Id) function appears to return
 523       --  the interrupt resolution of the realtime clock and not the actual
 524       --  resolution of reading the clock. Even though this last value is
 525       --  only guaranteed to be 100 Hz, at least the Origin 200 appears to
 526       --  have a microsecond resolution or better.
 527       --  ??? We should figure out a method to return the right value on
 528       --  all SGI hardware.
 529
 530       return 0.000_001; --  Assume microsecond resolution of clock
 531    end RT_Resolution;
 532
 533    ------------
 534    -- Wakeup --
 535    ------------
 536
 537    procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is
 538       Result : Interfaces.C.int;
 539    begin
 540       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 541       pragma Assert (Result = 0);
 542    end Wakeup;
 543
 544    -----------
 545    -- Yield --
 546    -----------
 547
 548    procedure Yield (Do_Yield : Boolean := True) is
 549       Result : Interfaces.C.int;
 550    begin
 551       if Do_Yield then
 552          Result := sched_yield;
 553       end if;
 554    end Yield;
 555
 556    ------------------
 557    -- Set_Priority --
 558    ------------------
 559
 560    procedure Set_Priority
 561      (T                   : Task_ID;
 562       Prio                : System.Any_Priority;
 563       Loss_Of_Inheritance : Boolean := False)
 564    is
 565       Result       : Interfaces.C.int;
 566       Param        : aliased struct_sched_param;
 567       Sched_Policy : Interfaces.C.int;
 568
 569       use type System.Task_Info.Task_Info_Type;
 570
 571       function To_Int is new Unchecked_Conversion
 572         (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
 573
 574    begin
 575       T.Common.Current_Priority := Prio;
 576       Param.sched_priority := Interfaces.C.int (Prio);
 577
 578       if T.Common.Task_Info /= null then
 579          Sched_Policy := To_Int (T.Common.Task_Info.Policy);
 580       else
 581          Sched_Policy := SCHED_FIFO;
 582       end if;
 583
 584       Result := pthread_setschedparam (T.Common.LL.Thread, Sched_Policy,
 585         Param'Access);
 586       pragma Assert (Result = 0);
 587    end Set_Priority;
 588
 589    ------------------
 590    -- Get_Priority --
 591    ------------------
 592
 593    function Get_Priority (T : Task_ID) return System.Any_Priority is
 594    begin
 595       return T.Common.Current_Priority;
 596    end Get_Priority;
 597
 598    ----------------
 599    -- Enter_Task --
 600    ----------------
 601
 602    procedure Enter_Task (Self_ID : Task_ID) is
 603       Result : Interfaces.C.int;
 604
 605       function To_Int is new Unchecked_Conversion
 606         (System.Task_Info.CPU_Number, Interfaces.C.int);
 607
 608       use System.Task_Info;
 609
 610    begin
 611       Self_ID.Common.LL.Thread := pthread_self;
 612       Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
 613       pragma Assert (Result = 0);
 614
 615       if Self_ID.Common.Task_Info /= null
 616         and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
 617         and then Self_ID.Common.Task_Info.Runon_CPU /= ANY_CPU
 618       then
 619          Result := pthread_setrunon_np
 620            (To_Int (Self_ID.Common.Task_Info.Runon_CPU));
 621          pragma Assert (Result = 0);
 622       end if;
 623
 624       Lock_All_Tasks_List;
 625
 626       for J in Known_Tasks'Range loop
 627          if Known_Tasks (J) = null then
 628             Known_Tasks (J) := Self_ID;
 629             Self_ID.Known_Tasks_Index := J;
 630             exit;
 631          end if;
 632       end loop;
 633
 634       Unlock_All_Tasks_List;
 635    end Enter_Task;
 636
 637    --------------
 638    -- New_ATCB --
 639    --------------
 640
 641    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 642    begin
 643       return new Ada_Task_Control_Block (Entry_Num);
 644    end New_ATCB;
 645
 646    --------------------
 647    -- Initialize_TCB --
 648    --------------------
 649
 650    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 651       Result    : Interfaces.C.int;
 652       Cond_Attr : aliased pthread_condattr_t;
 653
 654    begin
 655       Initialize_Lock (Self_ID.Common.LL.L'Access, All_Tasks_Level);
 656
 657       Result := pthread_condattr_init (Cond_Attr'Access);
 658       pragma Assert (Result = 0 or else Result = ENOMEM);
 659
 660       if Result /= 0 then
 661          Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 662          pragma Assert (Result = 0);
 663
 664          Succeeded := False;
 665          return;
 666       end if;
 667
 668       Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 669         Cond_Attr'Access);
 670       pragma Assert (Result = 0 or else Result = ENOMEM);
 671
 672       if Result = 0 then
 673          Succeeded := True;
 674       else
 675          Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 676          pragma Assert (Result = 0);
 677          Succeeded := False;
 678       end if;
 679
 680       Result := pthread_condattr_destroy (Cond_Attr'Access);
 681       pragma Assert (Result = 0);
 682    end Initialize_TCB;
 683
 684    -----------------
 685    -- Create_Task --
 686    -----------------
 687
 688    procedure Create_Task
 689      (T          : Task_ID;
 690       Wrapper    : System.Address;
 691       Stack_Size : System.Parameters.Size_Type;
 692       Priority   : System.Any_Priority;
 693       Succeeded  : out Boolean)
 694    is
 695       use System.Task_Info;
 696
 697       Attributes          : aliased pthread_attr_t;
 698       Sched_Param         : aliased struct_sched_param;
 699       Adjusted_Stack_Size : Interfaces.C.size_t;
 700       Result              : Interfaces.C.int;
 701
 702       function Thread_Body_Access is new
 703         Unchecked_Conversion (System.Address, Thread_Body);
 704
 705       function To_Int is new Unchecked_Conversion
 706         (System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int);
 707       function To_Int is new Unchecked_Conversion
 708         (System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int);
 709       function To_Int is new Unchecked_Conversion
 710         (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
 711
 712    begin
 713       if Stack_Size = System.Parameters.Unspecified_Size then
 714          Adjusted_Stack_Size :=
 715            Interfaces.C.size_t (System.Program_Info.Default_Task_Stack);
 716
 717       elsif Stack_Size < Size_Type (Minimum_Stack_Size) then
 718          Adjusted_Stack_Size :=
 719            Interfaces.C.size_t (Minimum_Stack_Size);
 720
 721       else
 722          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 723       end if;
 724
 725       Result := pthread_attr_init (Attributes'Access);
 726       pragma Assert (Result = 0 or else Result = ENOMEM);
 727
 728       if Result /= 0 then
 729          Succeeded := False;
 730          return;
 731       end if;
 732
 733       Result := pthread_attr_setdetachstate
 734         (Attributes'Access, PTHREAD_CREATE_DETACHED);
 735       pragma Assert (Result = 0);
 736
 737       Result := pthread_attr_setstacksize
 738         (Attributes'Access, Interfaces.C.size_t (Adjusted_Stack_Size));
 739       pragma Assert (Result = 0);
 740
 741       if T.Common.Task_Info /= null then
 742          Result := pthread_attr_setscope
 743            (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
 744          pragma Assert (Result = 0);
 745
 746          Result := pthread_attr_setinheritsched
 747            (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance));
 748          pragma Assert (Result = 0);
 749
 750          Result := pthread_attr_setschedpolicy
 751            (Attributes'Access, To_Int (T.Common.Task_Info.Policy));
 752          pragma Assert (Result = 0);
 753
 754          Sched_Param.sched_priority :=
 755            Interfaces.C.int (T.Common.Task_Info.Priority);
 756
 757          Result := pthread_attr_setschedparam
 758            (Attributes'Access, Sched_Param'Access);
 759          pragma Assert (Result = 0);
 760       end if;
 761
 762       --  Since the initial signal mask of a thread is inherited from the
 763       --  creator, and the Environment task has all its signals masked, we
 764       --  do not need to manipulate caller's signal mask at this point.
 765       --  All tasks in RTS will have All_Tasks_Mask initially.
 766
 767       Result := pthread_create
 768         (T.Common.LL.Thread'Access,
 769          Attributes'Access,
 770          Thread_Body_Access (Wrapper),
 771          To_Address (T));
 772
 773       if Result /= 0
 774         and then T.Common.Task_Info /= null
 775         and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
 776       then
 777          --  The pthread_create call may have failed because we
 778          --  asked for a system scope pthread and none were
 779          --  available (probably because the program was not executed
 780          --  by the superuser). Let's try for a process scope pthread
 781          --  instead of raising Tasking_Error.
 782
 783          System.IO.Put_Line
 784            ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task");
 785          System.IO.Put ("""");
 786          System.IO.Put (T.Common.Task_Image.all);
 787          System.IO.Put_Line (""" could not be honored. ");
 788          System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS");
 789
 790          T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS;
 791          Result := pthread_attr_setscope
 792            (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
 793          pragma Assert (Result = 0);
 794
 795          Result := pthread_create
 796            (T.Common.LL.Thread'Access,
 797             Attributes'Access,
 798             Thread_Body_Access (Wrapper),
 799             To_Address (T));
 800       end if;
 801
 802       pragma Assert (Result = 0 or else Result = EAGAIN);
 803
 804       Succeeded := Result = 0;
 805
 806       Set_Priority (T, Priority);
 807
 808       Result := pthread_attr_destroy (Attributes'Access);
 809       pragma Assert (Result = 0);
 810    end Create_Task;
 811
 812    ------------------
 813    -- Finalize_TCB --
 814    ------------------
 815
 816    procedure Finalize_TCB (T : Task_ID) is
 817       Result : Interfaces.C.int;
 818       Tmp    : Task_ID := T;
 819
 820       procedure Free is new
 821         Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
 822
 823    begin
 824       Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 825       pragma Assert (Result = 0);
 826
 827       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 828       pragma Assert (Result = 0);
 829
 830       if T.Known_Tasks_Index /= -1 then
 831          Known_Tasks (T.Known_Tasks_Index) := null;
 832       end if;
 833
 834       Free (Tmp);
 835    end Finalize_TCB;
 836
 837    ---------------
 838    -- Exit_Task --
 839    ---------------
 840
 841    procedure Exit_Task is
 842    begin
 843       pthread_exit (System.Null_Address);
 844    end Exit_Task;
 845
 846    ----------------
 847    -- Abort_Task --
 848    ----------------
 849
 850    procedure Abort_Task (T : Task_ID) is
 851       Result : Interfaces.C.int;
 852    begin
 853       Result := pthread_kill (T.Common.LL.Thread,
 854         Signal (System.Interrupt_Management.Abort_Task_Interrupt));
 855       pragma Assert (Result = 0);
 856    end Abort_Task;
 857
 858    ----------------
 859    -- Check_Exit --
 860    ----------------
 861
 862    --  Dummy versions. The only currently working versions is for solaris
 863    --  (native).
 864
 865    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 866    begin
 867       return True;
 868    end Check_Exit;
 869
 870    --------------------
 871    -- Check_No_Locks --
 872    --------------------
 873
 874    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 875    begin
 876       return True;
 877    end Check_No_Locks;
 878
 879    ----------------------
 880    -- Environment_Task --
 881    ----------------------
 882
 883    function Environment_Task return Task_ID is
 884    begin
 885       return Environment_Task_ID;
 886    end Environment_Task;
 887
 888    -------------------------
 889    -- Lock_All_Tasks_List --
 890    -------------------------
 891
 892    procedure Lock_All_Tasks_List is
 893    begin
 894       Write_Lock (All_Tasks_L'Access);
 895    end Lock_All_Tasks_List;
 896
 897    ---------------------------
 898    -- Unlock_All_Tasks_List --
 899    ---------------------------
 900
 901    procedure Unlock_All_Tasks_List is
 902    begin
 903       Unlock (All_Tasks_L'Access);
 904    end Unlock_All_Tasks_List;
 905
 906    ------------------
 907    -- Suspend_Task --
 908    ------------------
 909
 910    function Suspend_Task
 911      (T           : ST.Task_ID;
 912       Thread_Self : Thread_Id) return Boolean is
 913    begin
 914       return False;
 915    end Suspend_Task;
 916
 917    -----------------
 918    -- Resume_Task --
 919    -----------------
 920
 921    function Resume_Task
 922      (T           : ST.Task_ID;
 923       Thread_Self : Thread_Id) return Boolean is
 924    begin
 925       return False;
 926    end Resume_Task;
 927
 928    ----------------
 929    -- Initialize --
 930    ----------------
 931
 932    procedure Initialize (Environment_Task : Task_ID) is
 933       act     : aliased struct_sigaction;
 934       old_act : aliased struct_sigaction;
 935       Tmp_Set : aliased sigset_t;
 936       Result  : Interfaces.C.int;
 937
 938    begin
 939       Environment_Task_ID := Environment_Task;
 940
 941       --  Initialize the lock used to synchronize chain of all ATCBs.
 942       Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
 943
 944       Enter_Task (Environment_Task);
 945
 946       --  Install the abort-signal handler
 947
 948       act.sa_flags := 0;
 949       act.sa_handler := Abort_Handler'Address;
 950
 951       Result := sigemptyset (Tmp_Set'Access);
 952       pragma Assert (Result = 0);
 953       act.sa_mask := Tmp_Set;
 954
 955       Result :=
 956         sigaction (
 957           Signal (System.Interrupt_Management.Abort_Task_Interrupt),
 958           act'Unchecked_Access,
 959           old_act'Unchecked_Access);
 960       pragma Assert (Result = 0);
 961    end Initialize;
 962
 963 begin
 964    declare
 965       Result : Interfaces.C.int;
 966    begin
 967       --  Mask Environment task for all signals. The original mask of the
 968       --  Environment task will be recovered by Interrupt_Server task
 969       --  during the elaboration of s-interr.adb.
 970
 971       System.Interrupt_Management.Operations.Set_Interrupt_Mask
 972         (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
 973
 974       --  Prepare the set of signals that should unblocked in all tasks
 975
 976       Result := sigemptyset (Unblocked_Signal_Mask'Access);
 977       pragma Assert (Result = 0);
 978
 979       for J in Interrupt_Management.Interrupt_ID loop
 980          if System.Interrupt_Management.Keep_Unmasked (J) then
 981             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
 982             pragma Assert (Result = 0);
 983          end if;
 984       end loop;
 985
 986       Result := pthread_key_create (ATCB_Key'Access, null);
 987       pragma Assert (Result = 0);
 988
 989       --  Pick the highest resolution Clock for Clock_Realtime
 990       --  ??? This code currently doesn't work (see c94007[ab] for example)
 991       --
 992       --  if syssgi (SGI_CYCLECNTR_SIZE) = 64 then
 993       --     Real_Time_Clock_Id := CLOCK_SGI_CYCLE;
 994       --  else
 995       --     Real_Time_Clock_Id := CLOCK_REALTIME;
 996       --  end if;
 997    end;
 998 end System.Task_Primitives.Operations;