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