gcc/ada/s-taprop-irix.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-2008, 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 a IRIX (pthread library) version of this package
  35
  36 --  This package contains all the GNULL primitives that interface directly with
  37 --  the underlying OS.
  38
  39 pragma Polling (Off);
  40 --  Turn off polling, we do not want ATC polling to take place during tasking
  41 --  operations. It causes infinite loops and other problems.
  42
  43 with Ada.Unchecked_Conversion;
  44 with Ada.Unchecked_Deallocation;
  45
  46 with Interfaces.C;
  47
  48 with System.Task_Info;
  49 with System.Tasking.Debug;
  50 with System.Interrupt_Management;
  51 with System.OS_Primitives;
  52 with System.IO;
  53
  54 with System.Soft_Links;
  55 --  We use System.Soft_Links instead of System.Tasking.Initialization
  56 --  because the later is a higher level package that we shouldn't depend on.
  57 --  For example when using the restricted run time, it is replaced by
  58 --  System.Tasking.Restricted.Stages.
  59
  60 package body System.Task_Primitives.Operations is
  61
  62    package SSL renames System.Soft_Links;
  63
  64    use System.Tasking;
  65    use System.Tasking.Debug;
  66    use Interfaces.C;
  67    use System.OS_Interface;
  68    use System.OS_Primitives;
  69    use System.Parameters;
  70
  71    ----------------
  72    -- Local Data --
  73    ----------------
  74
  75    --  The followings are logically constants, but need to be initialized
  76    --  at run time.
  77
  78    Single_RTS_Lock : aliased RTS_Lock;
  79    --  This is a lock to allow only one thread of control in the RTS at
  80    --  a time; it is used to execute in mutual exclusion from all other tasks.
  81    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
  82
  83    ATCB_Key : aliased pthread_key_t;
  84    --  Key used to find the Ada Task_Id associated with a thread
  85
  86    Environment_Task_Id : Task_Id;
  87    --  A variable to hold Task_Id for the environment task
  88
  89    Locking_Policy : Character;
  90    pragma Import (C, Locking_Policy, "__gl_locking_policy");
  91
  92    Time_Slice_Val : Integer;
  93    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
  94
  95    Dispatching_Policy : Character;
  96    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
  97
  98    Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME;
  99
 100    Unblocked_Signal_Mask : aliased sigset_t;
 101
 102    Foreign_Task_Elaborated : aliased Boolean := True;
 103    --  Used to identified fake tasks (i.e., non-Ada Threads)
 104
 105    --------------------
 106    -- Local Packages --
 107    --------------------
 108
 109    package Specific is
 110
 111       procedure Initialize (Environment_Task : Task_Id);
 112       pragma Inline (Initialize);
 113       --  Initialize various data needed by this package
 114
 115       function Is_Valid_Task return Boolean;
 116       pragma Inline (Is_Valid_Task);
 117       --  Does executing thread have a TCB?
 118
 119       procedure Set (Self_Id : Task_Id);
 120       pragma Inline (Set);
 121       --  Set the self id for the current task
 122
 123       function Self return Task_Id;
 124       pragma Inline (Self);
 125       --  Return a pointer to the Ada Task Control Block of the calling task
 126
 127    end Specific;
 128
 129    package body Specific is separate;
 130    --  The body of this package is target specific
 131
 132    ---------------------------------
 133    -- Support for foreign threads --
 134    ---------------------------------
 135
 136    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
 137    --  Allocate and Initialize a new ATCB for the current Thread
 138
 139    function Register_Foreign_Thread
 140      (Thread : Thread_Id) return Task_Id is separate;
 141
 142    -----------------------
 143    -- Local Subprograms --
 144    -----------------------
 145
 146    function To_Address is
 147      new Ada.Unchecked_Conversion (Task_Id, System.Address);
 148
 149    procedure Abort_Handler (Sig : Signal);
 150    --  Signal handler used to implement asynchronous abort
 151
 152    -------------------
 153    -- Abort_Handler --
 154    -------------------
 155
 156    procedure Abort_Handler (Sig : Signal) is
 157       pragma Unreferenced (Sig);
 158
 159       T       : constant Task_Id := Self;
 160       Result  : Interfaces.C.int;
 161       Old_Set : aliased sigset_t;
 162
 163    begin
 164       --  It is not safe to raise an exception when using ZCX and the GCC
 165       --  exception handling mechanism.
 166
 167       if ZCX_By_Default and then GCC_ZCX_Support then
 168          return;
 169       end if;
 170
 171       if T.Deferral_Level = 0
 172         and then T.Pending_ATC_Level < T.ATC_Nesting_Level
 173       then
 174          --  Make sure signals used for RTS internal purpose are unmasked
 175
 176          Result := pthread_sigmask
 177            (SIG_UNBLOCK,
 178             Unblocked_Signal_Mask'Access,
 179             Old_Set'Access);
 180          pragma Assert (Result = 0);
 181
 182          raise Standard'Abort_Signal;
 183       end if;
 184    end Abort_Handler;
 185
 186    -----------------
 187    -- Stack_Guard --
 188    -----------------
 189
 190    --  The underlying thread system sets a guard page at the
 191    --  bottom of a thread stack, so nothing is needed.
 192
 193    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 194       pragma Unreferenced (On);
 195       pragma Unreferenced (T);
 196    begin
 197       null;
 198    end Stack_Guard;
 199
 200    -------------------
 201    -- Get_Thread_Id --
 202    -------------------
 203
 204    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 205    begin
 206       return T.Common.LL.Thread;
 207    end Get_Thread_Id;
 208
 209    ----------
 210    -- Self --
 211    ----------
 212
 213    function Self return Task_Id renames Specific.Self;
 214
 215    ---------------------
 216    -- Initialize_Lock --
 217    ---------------------
 218
 219    --  Note: mutexes and cond_variables needed per-task basis are initialized
 220    --  in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
 221    --  as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
 222    --  status change of RTS. Therefore rasing Storage_Error in the following
 223    --  routines should be able to be handled safely.
 224
 225    procedure Initialize_Lock
 226      (Prio : System.Any_Priority;
 227       L    : not null access Lock)
 228    is
 229       Attributes : aliased pthread_mutexattr_t;
 230       Result     : Interfaces.C.int;
 231
 232    begin
 233       Result := pthread_mutexattr_init (Attributes'Access);
 234       pragma Assert (Result = 0 or else Result = ENOMEM);
 235
 236       if Result = ENOMEM then
 237          raise Storage_Error;
 238       end if;
 239
 240       if Locking_Policy = 'C' then
 241          Result :=
 242            pthread_mutexattr_setprotocol
 243              (Attributes'Access, PTHREAD_PRIO_PROTECT);
 244          pragma Assert (Result = 0);
 245
 246          Result :=
 247            pthread_mutexattr_setprioceiling
 248              (Attributes'Access, Interfaces.C.int (Prio));
 249          pragma Assert (Result = 0);
 250       end if;
 251
 252       Result := pthread_mutex_init (L, Attributes'Access);
 253       pragma Assert (Result = 0 or else Result = ENOMEM);
 254
 255       if Result = ENOMEM then
 256          Result := pthread_mutexattr_destroy (Attributes'Access);
 257          raise Storage_Error;
 258       end if;
 259
 260       Result := pthread_mutexattr_destroy (Attributes'Access);
 261       pragma Assert (Result = 0);
 262    end Initialize_Lock;
 263
 264    procedure Initialize_Lock
 265      (L     : not null access RTS_Lock;
 266       Level : Lock_Level)
 267    is
 268       pragma Unreferenced (Level);
 269
 270       Attributes : aliased pthread_mutexattr_t;
 271       Result : Interfaces.C.int;
 272
 273    begin
 274       Result := pthread_mutexattr_init (Attributes'Access);
 275       pragma Assert (Result = 0 or else Result = ENOMEM);
 276
 277       if Result = ENOMEM then
 278          raise Storage_Error;
 279       end if;
 280
 281       if Locking_Policy = 'C' then
 282          Result := pthread_mutexattr_setprotocol
 283            (Attributes'Access, PTHREAD_PRIO_PROTECT);
 284          pragma Assert (Result = 0);
 285
 286          Result := pthread_mutexattr_setprioceiling
 287             (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
 288          pragma Assert (Result = 0);
 289       end if;
 290
 291       Result := pthread_mutex_init (L, Attributes'Access);
 292
 293       pragma Assert (Result = 0 or else Result = ENOMEM);
 294
 295       if Result = ENOMEM then
 296          Result := pthread_mutexattr_destroy (Attributes'Access);
 297          raise Storage_Error;
 298       end if;
 299
 300       Result := pthread_mutexattr_destroy (Attributes'Access);
 301       pragma Assert (Result = 0);
 302    end Initialize_Lock;
 303
 304    -------------------
 305    -- Finalize_Lock --
 306    -------------------
 307
 308    procedure Finalize_Lock (L : not null access Lock) is
 309       Result : Interfaces.C.int;
 310    begin
 311       Result := pthread_mutex_destroy (L);
 312       pragma Assert (Result = 0);
 313    end Finalize_Lock;
 314
 315    procedure Finalize_Lock (L : not null access RTS_Lock) is
 316       Result : Interfaces.C.int;
 317    begin
 318       Result := pthread_mutex_destroy (L);
 319       pragma Assert (Result = 0);
 320    end Finalize_Lock;
 321
 322    ----------------
 323    -- Write_Lock --
 324    ----------------
 325
 326    procedure Write_Lock
 327      (L : not null access Lock; Ceiling_Violation : out Boolean)
 328    is
 329       Result : Interfaces.C.int;
 330
 331    begin
 332       Result := pthread_mutex_lock (L);
 333       Ceiling_Violation := Result = EINVAL;
 334
 335       --  Assumes the cause of EINVAL is a priority ceiling violation
 336
 337       pragma Assert (Result = 0 or else Result = EINVAL);
 338    end Write_Lock;
 339
 340    procedure Write_Lock
 341      (L           : not null access RTS_Lock;
 342       Global_Lock : Boolean := False)
 343    is
 344       Result : Interfaces.C.int;
 345    begin
 346       if not Single_Lock or else Global_Lock then
 347          Result := pthread_mutex_lock (L);
 348          pragma Assert (Result = 0);
 349       end if;
 350    end Write_Lock;
 351
 352    procedure Write_Lock (T : Task_Id) is
 353       Result : Interfaces.C.int;
 354    begin
 355       if not Single_Lock then
 356          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 357          pragma Assert (Result = 0);
 358       end if;
 359    end Write_Lock;
 360
 361    ---------------
 362    -- Read_Lock --
 363    ---------------
 364
 365    procedure Read_Lock
 366      (L : not null access Lock; Ceiling_Violation : out Boolean) is
 367    begin
 368       Write_Lock (L, Ceiling_Violation);
 369    end Read_Lock;
 370
 371    ------------
 372    -- Unlock --
 373    ------------
 374
 375    procedure Unlock (L : not null access Lock) is
 376       Result : Interfaces.C.int;
 377    begin
 378       Result := pthread_mutex_unlock (L);
 379       pragma Assert (Result = 0);
 380    end Unlock;
 381
 382    procedure Unlock
 383      (L           : not null access RTS_Lock;
 384       Global_Lock : Boolean := False)
 385    is
 386       Result : Interfaces.C.int;
 387    begin
 388       if not Single_Lock or else Global_Lock then
 389          Result := pthread_mutex_unlock (L);
 390          pragma Assert (Result = 0);
 391       end if;
 392    end Unlock;
 393
 394    procedure Unlock (T : Task_Id) is
 395       Result : Interfaces.C.int;
 396    begin
 397       if not Single_Lock then
 398          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 399          pragma Assert (Result = 0);
 400       end if;
 401    end Unlock;
 402
 403    -----------------
 404    -- Set_Ceiling --
 405    -----------------
 406
 407    --  Dynamic priority ceilings are not supported by the underlying system
 408
 409    procedure Set_Ceiling
 410      (L    : not null access Lock;
 411       Prio : System.Any_Priority)
 412    is
 413       pragma Unreferenced (L, Prio);
 414    begin
 415       null;
 416    end Set_Ceiling;
 417
 418    -----------
 419    -- Sleep --
 420    -----------
 421
 422    procedure Sleep
 423      (Self_ID : ST.Task_Id;
 424       Reason  : System.Tasking.Task_States)
 425    is
 426       pragma Unreferenced (Reason);
 427       Result : Interfaces.C.int;
 428
 429    begin
 430       if Single_Lock then
 431          Result :=
 432            pthread_cond_wait
 433              (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 434       else
 435          Result :=
 436            pthread_cond_wait
 437              (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 438       end if;
 439
 440       --  EINTR is not considered a failure
 441
 442       pragma Assert (Result = 0 or else Result = EINTR);
 443    end Sleep;
 444
 445    -----------------
 446    -- Timed_Sleep --
 447    -----------------
 448
 449    procedure Timed_Sleep
 450      (Self_ID  : Task_Id;
 451       Time     : Duration;
 452       Mode     : ST.Delay_Modes;
 453       Reason   : Task_States;
 454       Timedout : out Boolean;
 455       Yielded  : out Boolean)
 456    is
 457       pragma Unreferenced (Reason);
 458
 459       Base_Time  : constant Duration := Monotonic_Clock;
 460       Check_Time : Duration := Base_Time;
 461       Abs_Time   : Duration;
 462       Request    : aliased timespec;
 463       Result     : Interfaces.C.int;
 464
 465    begin
 466       Timedout := True;
 467       Yielded  := False;
 468
 469       if Mode = Relative then
 470          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 471       else
 472          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 473       end if;
 474
 475       if Abs_Time > Check_Time then
 476          Request := To_Timespec (Abs_Time);
 477
 478          loop
 479             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 480
 481             if Single_Lock then
 482                Result :=
 483                  pthread_cond_timedwait
 484                    (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
 485                     Request'Access);
 486
 487             else
 488                Result :=
 489                  pthread_cond_timedwait
 490                    (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
 491                     Request'Access);
 492             end if;
 493
 494             Check_Time := Monotonic_Clock;
 495             exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
 496
 497             if Result = 0 or else errno = EINTR then
 498                Timedout := False;
 499                exit;
 500             end if;
 501          end loop;
 502       end if;
 503    end Timed_Sleep;
 504
 505    -----------------
 506    -- Timed_Delay --
 507    -----------------
 508
 509    --  This is for use in implementing delay statements, so we assume
 510    --  the caller is abort-deferred but is holding no locks.
 511
 512    procedure Timed_Delay
 513      (Self_ID : Task_Id;
 514       Time    : Duration;
 515       Mode    : ST.Delay_Modes)
 516    is
 517       Base_Time  : constant Duration := Monotonic_Clock;
 518       Check_Time : Duration := Base_Time;
 519       Abs_Time   : Duration;
 520       Request    : aliased timespec;
 521       Result     : Interfaces.C.int;
 522
 523    begin
 524       if Single_Lock then
 525          Lock_RTS;
 526       end if;
 527
 528       Write_Lock (Self_ID);
 529
 530       if Mode = Relative then
 531          Abs_Time := Time + Check_Time;
 532       else
 533          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 534       end if;
 535
 536       if Abs_Time > Check_Time then
 537          Request := To_Timespec (Abs_Time);
 538          Self_ID.Common.State := Delay_Sleep;
 539
 540          loop
 541             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 542
 543             if Single_Lock then
 544                Result := pthread_cond_timedwait
 545                            (Self_ID.Common.LL.CV'Access,
 546                             Single_RTS_Lock'Access,
 547                             Request'Access);
 548             else
 549                Result := pthread_cond_timedwait
 550                            (Self_ID.Common.LL.CV'Access,
 551                             Self_ID.Common.LL.L'Access,
 552                             Request'Access);
 553             end if;
 554
 555             Check_Time := Monotonic_Clock;
 556             exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
 557
 558             pragma Assert (Result = 0
 559               or else Result = ETIMEDOUT
 560               or else Result = EINTR);
 561          end loop;
 562
 563          Self_ID.Common.State := Runnable;
 564       end if;
 565
 566       Unlock (Self_ID);
 567
 568       if Single_Lock then
 569          Unlock_RTS;
 570       end if;
 571
 572       Yield;
 573    end Timed_Delay;
 574
 575    ---------------------
 576    -- Monotonic_Clock --
 577    ---------------------
 578
 579    function Monotonic_Clock return Duration is
 580       TS     : aliased timespec;
 581       Result : Interfaces.C.int;
 582    begin
 583       Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access);
 584       pragma Assert (Result = 0);
 585       return To_Duration (TS);
 586    end Monotonic_Clock;
 587
 588    -------------------
 589    -- RT_Resolution --
 590    -------------------
 591
 592    function RT_Resolution return Duration is
 593    begin
 594       --  The clock_getres (Real_Time_Clock_Id) function appears to return
 595       --  the interrupt resolution of the realtime clock and not the actual
 596       --  resolution of reading the clock. Even though this last value is
 597       --  only guaranteed to be 100 Hz, at least the Origin 200 appears to
 598       --  have a microsecond resolution or better.
 599
 600       --  ??? We should figure out a method to return the right value on
 601       --  all SGI hardware.
 602
 603       return 0.000_001;
 604    end RT_Resolution;
 605
 606    ------------
 607    -- Wakeup --
 608    ------------
 609
 610    procedure Wakeup (T : ST.Task_Id; Reason : System.Tasking.Task_States) is
 611       pragma Unreferenced (Reason);
 612       Result : Interfaces.C.int;
 613    begin
 614       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 615       pragma Assert (Result = 0);
 616    end Wakeup;
 617
 618    -----------
 619    -- Yield --
 620    -----------
 621
 622    procedure Yield (Do_Yield : Boolean := True) is
 623       Result : Interfaces.C.int;
 624       pragma Unreferenced (Result);
 625    begin
 626       if Do_Yield then
 627          Result := sched_yield;
 628       end if;
 629    end Yield;
 630
 631    ------------------
 632    -- Set_Priority --
 633    ------------------
 634
 635    procedure Set_Priority
 636      (T                   : Task_Id;
 637       Prio                : System.Any_Priority;
 638       Loss_Of_Inheritance : Boolean := False)
 639    is
 640       pragma Unreferenced (Loss_Of_Inheritance);
 641
 642       Result       : Interfaces.C.int;
 643       Param        : aliased struct_sched_param;
 644       Sched_Policy : Interfaces.C.int;
 645
 646       use type System.Task_Info.Task_Info_Type;
 647
 648       function To_Int is new Ada.Unchecked_Conversion
 649         (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
 650
 651       function Get_Policy (Prio : System.Any_Priority) return Character;
 652       pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
 653       --  Get priority specific dispatching policy
 654
 655       Priority_Specific_Policy : constant Character := Get_Policy (Prio);
 656       --  Upper case first character of the policy name corresponding to the
 657       --  task as set by a Priority_Specific_Dispatching pragma.
 658
 659    begin
 660       T.Common.Current_Priority := Prio;
 661       Param.sched_priority := Interfaces.C.int (Prio);
 662
 663       if T.Common.Task_Info /= null then
 664          Sched_Policy := To_Int (T.Common.Task_Info.Policy);
 665
 666       elsif Dispatching_Policy = 'R'
 667         or else Priority_Specific_Policy = 'R'
 668         or else Time_Slice_Val > 0
 669       then
 670          Sched_Policy := SCHED_RR;
 671
 672       else
 673          Sched_Policy := SCHED_FIFO;
 674       end if;
 675
 676       Result := pthread_setschedparam (T.Common.LL.Thread, Sched_Policy,
 677         Param'Access);
 678       pragma Assert (Result = 0);
 679    end Set_Priority;
 680
 681    ------------------
 682    -- Get_Priority --
 683    ------------------
 684
 685    function Get_Priority (T : Task_Id) return System.Any_Priority is
 686    begin
 687       return T.Common.Current_Priority;
 688    end Get_Priority;
 689
 690    ----------------
 691    -- Enter_Task --
 692    ----------------
 693
 694    procedure Enter_Task (Self_ID : Task_Id) is
 695       Result : Interfaces.C.int;
 696
 697       function To_Int is new Ada.Unchecked_Conversion
 698         (System.Task_Info.CPU_Number, Interfaces.C.int);
 699
 700       use System.Task_Info;
 701
 702    begin
 703       Self_ID.Common.LL.Thread := pthread_self;
 704       Specific.Set (Self_ID);
 705
 706       if Self_ID.Common.Task_Info /= null
 707         and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
 708         and then Self_ID.Common.Task_Info.Runon_CPU /= ANY_CPU
 709       then
 710          Result := pthread_setrunon_np
 711            (To_Int (Self_ID.Common.Task_Info.Runon_CPU));
 712          pragma Assert (Result = 0);
 713       end if;
 714
 715       Lock_RTS;
 716
 717       for J in Known_Tasks'Range loop
 718          if Known_Tasks (J) = null then
 719             Known_Tasks (J) := Self_ID;
 720             Self_ID.Known_Tasks_Index := J;
 721             exit;
 722          end if;
 723       end loop;
 724
 725       Unlock_RTS;
 726    end Enter_Task;
 727
 728    --------------
 729    -- New_ATCB --
 730    --------------
 731
 732    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 733    begin
 734       return new Ada_Task_Control_Block (Entry_Num);
 735    end New_ATCB;
 736
 737    -------------------
 738    -- Is_Valid_Task --
 739    -------------------
 740
 741    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 742
 743    -----------------------------
 744    -- Register_Foreign_Thread --
 745    -----------------------------
 746
 747    function Register_Foreign_Thread return Task_Id is
 748    begin
 749       if Is_Valid_Task then
 750          return Self;
 751       else
 752          return Register_Foreign_Thread (pthread_self);
 753       end if;
 754    end Register_Foreign_Thread;
 755
 756    --------------------
 757    -- Initialize_TCB --
 758    --------------------
 759
 760    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 761       Result    : Interfaces.C.int;
 762       Cond_Attr : aliased pthread_condattr_t;
 763
 764    begin
 765       if not Single_Lock then
 766          Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
 767       end if;
 768
 769       Result := pthread_condattr_init (Cond_Attr'Access);
 770       pragma Assert (Result = 0 or else Result = ENOMEM);
 771
 772       if Result = 0 then
 773          Result :=
 774            pthread_cond_init (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
 775          pragma Assert (Result = 0 or else Result = ENOMEM);
 776       end if;
 777
 778       if Result = 0 then
 779          Succeeded := True;
 780       else
 781          if not Single_Lock then
 782             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 783             pragma Assert (Result = 0);
 784          end if;
 785
 786          Succeeded := False;
 787       end if;
 788
 789       Result := pthread_condattr_destroy (Cond_Attr'Access);
 790       pragma Assert (Result = 0);
 791    end Initialize_TCB;
 792
 793    -----------------
 794    -- Create_Task --
 795    -----------------
 796
 797    procedure Create_Task
 798      (T          : Task_Id;
 799       Wrapper    : System.Address;
 800       Stack_Size : System.Parameters.Size_Type;
 801       Priority   : System.Any_Priority;
 802       Succeeded  : out Boolean)
 803    is
 804       use System.Task_Info;
 805
 806       Attributes  : aliased pthread_attr_t;
 807       Sched_Param : aliased struct_sched_param;
 808       Result      : Interfaces.C.int;
 809
 810       function Thread_Body_Access is new
 811         Ada.Unchecked_Conversion (System.Address, Thread_Body);
 812       function To_Int is new Ada.Unchecked_Conversion
 813         (System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int);
 814       function To_Int is new Ada.Unchecked_Conversion
 815         (System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int);
 816       function To_Int is new Ada.Unchecked_Conversion
 817         (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int);
 818
 819    begin
 820       Result := pthread_attr_init (Attributes'Access);
 821       pragma Assert (Result = 0 or else Result = ENOMEM);
 822
 823       if Result /= 0 then
 824          Succeeded := False;
 825          return;
 826       end if;
 827
 828       Result :=
 829         pthread_attr_setdetachstate
 830           (Attributes'Access, PTHREAD_CREATE_DETACHED);
 831       pragma Assert (Result = 0);
 832
 833       Result :=
 834         pthread_attr_setstacksize
 835           (Attributes'Access, Interfaces.C.size_t (Stack_Size));
 836       pragma Assert (Result = 0);
 837
 838       if T.Common.Task_Info /= null then
 839          Result :=
 840            pthread_attr_setscope
 841              (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
 842          pragma Assert (Result = 0);
 843
 844          Result :=
 845            pthread_attr_setinheritsched
 846              (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance));
 847          pragma Assert (Result = 0);
 848
 849          Result :=
 850            pthread_attr_setschedpolicy
 851              (Attributes'Access, To_Int (T.Common.Task_Info.Policy));
 852          pragma Assert (Result = 0);
 853
 854          Sched_Param.sched_priority :=
 855            Interfaces.C.int (T.Common.Task_Info.Priority);
 856
 857          Result :=
 858            pthread_attr_setschedparam
 859              (Attributes'Access, Sched_Param'Access);
 860          pragma Assert (Result = 0);
 861       end if;
 862
 863       --  Since the initial signal mask of a thread is inherited from the
 864       --  creator, and the Environment task has all its signals masked, we
 865       --  do not need to manipulate caller's signal mask at this point.
 866       --  All tasks in RTS will have All_Tasks_Mask initially.
 867
 868       Result :=
 869         pthread_create
 870           (T.Common.LL.Thread'Access,
 871            Attributes'Access,
 872            Thread_Body_Access (Wrapper),
 873            To_Address (T));
 874
 875       if Result /= 0
 876         and then T.Common.Task_Info /= null
 877         and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
 878       then
 879          --  The pthread_create call may have failed because we asked for a
 880          --  system scope pthread and none were available (probably because
 881          --  the program was not executed by the superuser). Let's try for
 882          --  a process scope pthread instead of raising Tasking_Error.
 883
 884          System.IO.Put_Line
 885            ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task");
 886          System.IO.Put ("""");
 887          System.IO.Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len));
 888          System.IO.Put_Line (""" could not be honored. ");
 889          System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS");
 890
 891          T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS;
 892          Result :=
 893            pthread_attr_setscope
 894              (Attributes'Access, To_Int (T.Common.Task_Info.Scope));
 895          pragma Assert (Result = 0);
 896
 897          Result :=
 898            pthread_create
 899              (T.Common.LL.Thread'Access,
 900               Attributes'Access,
 901               Thread_Body_Access (Wrapper),
 902               To_Address (T));
 903       end if;
 904
 905       pragma Assert (Result = 0 or else Result = EAGAIN);
 906
 907       Succeeded := Result = 0;
 908
 909       if Succeeded then
 910
 911          --  The following needs significant commenting ???
 912
 913          if T.Common.Task_Info /= null then
 914             T.Common.Base_Priority := T.Common.Task_Info.Priority;
 915             Set_Priority (T, T.Common.Task_Info.Priority);
 916          else
 917             Set_Priority (T, Priority);
 918          end if;
 919       end if;
 920
 921       Result := pthread_attr_destroy (Attributes'Access);
 922       pragma Assert (Result = 0);
 923    end Create_Task;
 924
 925    ------------------
 926    -- Finalize_TCB --
 927    ------------------
 928
 929    procedure Finalize_TCB (T : Task_Id) is
 930       Result  : Interfaces.C.int;
 931       Tmp     : Task_Id := T;
 932       Is_Self : constant Boolean := T = Self;
 933
 934       procedure Free is new
 935         Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 936
 937    begin
 938       if not Single_Lock then
 939          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 940          pragma Assert (Result = 0);
 941       end if;
 942
 943       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 944       pragma Assert (Result = 0);
 945
 946       if T.Known_Tasks_Index /= -1 then
 947          Known_Tasks (T.Known_Tasks_Index) := null;
 948       end if;
 949
 950       Free (Tmp);
 951
 952       if Is_Self then
 953          Specific.Set (null);
 954       end if;
 955    end Finalize_TCB;
 956
 957    ---------------
 958    -- Exit_Task --
 959    ---------------
 960
 961    procedure Exit_Task is
 962    begin
 963       Specific.Set (null);
 964    end Exit_Task;
 965
 966    ----------------
 967    -- Abort_Task --
 968    ----------------
 969
 970    procedure Abort_Task (T : Task_Id) is
 971       Result : Interfaces.C.int;
 972    begin
 973       Result :=
 974         pthread_kill
 975           (T.Common.LL.Thread,
 976            Signal (System.Interrupt_Management.Abort_Task_Interrupt));
 977       pragma Assert (Result = 0);
 978    end Abort_Task;
 979
 980    ----------------
 981    -- Initialize --
 982    ----------------
 983
 984    procedure Initialize (S : in out Suspension_Object) is
 985       Mutex_Attr : aliased pthread_mutexattr_t;
 986       Cond_Attr  : aliased pthread_condattr_t;
 987       Result     : Interfaces.C.int;
 988
 989    begin
 990       --  Initialize internal state (always to False (RM D.10(6))
 991
 992       S.State := False;
 993       S.Waiting := False;
 994
 995       --  Initialize internal mutex
 996
 997       Result := pthread_mutexattr_init (Mutex_Attr'Access);
 998       pragma Assert (Result = 0 or else Result = ENOMEM);
 999
1000       if Result = ENOMEM then
1001          raise Storage_Error;
1002       end if;
1003
1004       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
1005       pragma Assert (Result = 0 or else Result = ENOMEM);
1006
1007       if Result = ENOMEM then
1008          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1009          pragma Assert (Result = 0);
1010
1011          raise Storage_Error;
1012       end if;
1013
1014       Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1015       pragma Assert (Result = 0);
1016
1017       --  Initialize internal condition variable
1018
1019       Result := pthread_condattr_init (Cond_Attr'Access);
1020       pragma Assert (Result = 0 or else Result = ENOMEM);
1021
1022       if Result /= 0 then
1023          Result := pthread_mutex_destroy (S.L'Access);
1024          pragma Assert (Result = 0);
1025
1026          if Result = ENOMEM then
1027             raise Storage_Error;
1028          end if;
1029       end if;
1030
1031       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1032       pragma Assert (Result = 0 or else Result = ENOMEM);
1033
1034       if Result /= 0 then
1035          Result := pthread_mutex_destroy (S.L'Access);
1036          pragma Assert (Result = 0);
1037
1038          if Result = ENOMEM then
1039             Result := pthread_condattr_destroy (Cond_Attr'Access);
1040             pragma Assert (Result = 0);
1041             raise Storage_Error;
1042          end if;
1043       end if;
1044
1045       Result := pthread_condattr_destroy (Cond_Attr'Access);
1046       pragma Assert (Result = 0);
1047    end Initialize;
1048
1049    --------------
1050    -- Finalize --
1051    --------------
1052
1053    procedure Finalize (S : in out Suspension_Object) is
1054       Result : Interfaces.C.int;
1055
1056    begin
1057       --  Destroy internal mutex
1058
1059       Result := pthread_mutex_destroy (S.L'Access);
1060       pragma Assert (Result = 0);
1061
1062       --  Destroy internal condition variable
1063
1064       Result := pthread_cond_destroy (S.CV'Access);
1065       pragma Assert (Result = 0);
1066    end Finalize;
1067
1068    -------------------
1069    -- Current_State --
1070    -------------------
1071
1072    function Current_State (S : Suspension_Object) return Boolean is
1073    begin
1074       --  We do not want to use lock on this read operation. State is marked
1075       --  as Atomic so that we ensure that the value retrieved is correct.
1076
1077       return S.State;
1078    end Current_State;
1079
1080    ---------------
1081    -- Set_False --
1082    ---------------
1083
1084    procedure Set_False (S : in out Suspension_Object) is
1085       Result : Interfaces.C.int;
1086
1087    begin
1088       SSL.Abort_Defer.all;
1089
1090       Result := pthread_mutex_lock (S.L'Access);
1091       pragma Assert (Result = 0);
1092
1093       S.State := False;
1094
1095       Result := pthread_mutex_unlock (S.L'Access);
1096       pragma Assert (Result = 0);
1097
1098       SSL.Abort_Undefer.all;
1099    end Set_False;
1100
1101    --------------
1102    -- Set_True --
1103    --------------
1104
1105    procedure Set_True (S : in out Suspension_Object) is
1106       Result : Interfaces.C.int;
1107
1108    begin
1109       SSL.Abort_Defer.all;
1110
1111       Result := pthread_mutex_lock (S.L'Access);
1112       pragma Assert (Result = 0);
1113
1114       --  If there is already a task waiting on this suspension object then
1115       --  we resume it, leaving the state of the suspension object to False,
1116       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1117       --  the state to True.
1118
1119       if S.Waiting then
1120          S.Waiting := False;
1121          S.State := False;
1122
1123          Result := pthread_cond_signal (S.CV'Access);
1124          pragma Assert (Result = 0);
1125
1126       else
1127          S.State := True;
1128       end if;
1129
1130       Result := pthread_mutex_unlock (S.L'Access);
1131       pragma Assert (Result = 0);
1132
1133       SSL.Abort_Undefer.all;
1134    end Set_True;
1135
1136    ------------------------
1137    -- Suspend_Until_True --
1138    ------------------------
1139
1140    procedure Suspend_Until_True (S : in out Suspension_Object) is
1141       Result : Interfaces.C.int;
1142
1143    begin
1144       SSL.Abort_Defer.all;
1145
1146       Result := pthread_mutex_lock (S.L'Access);
1147       pragma Assert (Result = 0);
1148
1149       if S.Waiting then
1150
1151          --  Program_Error must be raised upon calling Suspend_Until_True
1152          --  if another task is already waiting on that suspension object
1153          --  (RM D.10(10)).
1154
1155          Result := pthread_mutex_unlock (S.L'Access);
1156          pragma Assert (Result = 0);
1157
1158          SSL.Abort_Undefer.all;
1159
1160          raise Program_Error;
1161       else
1162          --  Suspend the task if the state is False. Otherwise, the task
1163          --  continues its execution, and the state of the suspension object
1164          --  is set to False (ARM D.10 par. 9).
1165
1166          if S.State then
1167             S.State := False;
1168          else
1169             S.Waiting := True;
1170             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1171          end if;
1172
1173          Result := pthread_mutex_unlock (S.L'Access);
1174          pragma Assert (Result = 0);
1175
1176          SSL.Abort_Undefer.all;
1177       end if;
1178    end Suspend_Until_True;
1179
1180    ----------------
1181    -- Check_Exit --
1182    ----------------
1183
1184    --  Dummy version
1185
1186    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1187       pragma Unreferenced (Self_ID);
1188    begin
1189       return True;
1190    end Check_Exit;
1191
1192    --------------------
1193    -- Check_No_Locks --
1194    --------------------
1195
1196    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1197       pragma Unreferenced (Self_ID);
1198    begin
1199       return True;
1200    end Check_No_Locks;
1201
1202    ----------------------
1203    -- Environment_Task --
1204    ----------------------
1205
1206    function Environment_Task return Task_Id is
1207    begin
1208       return Environment_Task_Id;
1209    end Environment_Task;
1210
1211    --------------
1212    -- Lock_RTS --
1213    --------------
1214
1215    procedure Lock_RTS is
1216    begin
1217       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1218    end Lock_RTS;
1219
1220    ----------------
1221    -- Unlock_RTS --
1222    ----------------
1223
1224    procedure Unlock_RTS is
1225    begin
1226       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1227    end Unlock_RTS;
1228
1229    ------------------
1230    -- Suspend_Task --
1231    ------------------
1232
1233    function Suspend_Task
1234      (T           : ST.Task_Id;
1235       Thread_Self : Thread_Id) return Boolean
1236    is
1237       pragma Unreferenced (T);
1238       pragma Unreferenced (Thread_Self);
1239    begin
1240       return False;
1241    end Suspend_Task;
1242
1243    -----------------
1244    -- Resume_Task --
1245    -----------------
1246
1247    function Resume_Task
1248      (T           : ST.Task_Id;
1249       Thread_Self : Thread_Id) return Boolean
1250    is
1251       pragma Unreferenced (T);
1252       pragma Unreferenced (Thread_Self);
1253    begin
1254       return False;
1255    end Resume_Task;
1256
1257    --------------------
1258    -- Stop_All_Tasks --
1259    --------------------
1260
1261    procedure Stop_All_Tasks is
1262    begin
1263       null;
1264    end Stop_All_Tasks;
1265
1266    ---------------
1267    -- Stop_Task --
1268    ---------------
1269
1270    function Stop_Task (T : ST.Task_Id) return Boolean is
1271       pragma Unreferenced (T);
1272    begin
1273       return False;
1274    end Stop_Task;
1275
1276    -------------------
1277    -- Continue_Task --
1278    -------------------
1279
1280    function Continue_Task (T : ST.Task_Id) return Boolean is
1281       pragma Unreferenced (T);
1282    begin
1283       return False;
1284    end Continue_Task;
1285
1286    ----------------
1287    -- Initialize --
1288    ----------------
1289
1290    procedure Initialize (Environment_Task : Task_Id) is
1291       act     : aliased struct_sigaction;
1292       old_act : aliased struct_sigaction;
1293       Tmp_Set : aliased sigset_t;
1294       Result  : Interfaces.C.int;
1295
1296       function State
1297         (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1298       pragma Import (C, State, "__gnat_get_interrupt_state");
1299       --  Get interrupt state. Defined in a-init.c. The input argument is
1300       --  the interrupt number, and the result is one of the following:
1301
1302       Default : constant Character := 's';
1303       --    'n'   this interrupt not set by any Interrupt_State pragma
1304       --    'u'   Interrupt_State pragma set state to User
1305       --    'r'   Interrupt_State pragma set state to Runtime
1306       --    's'   Interrupt_State pragma set state to System (use "default"
1307       --           system handler)
1308
1309    begin
1310       Environment_Task_Id := Environment_Task;
1311
1312       Interrupt_Management.Initialize;
1313
1314       --  Initialize the lock used to synchronize chain of all ATCBs
1315
1316       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1317
1318       Specific.Initialize (Environment_Task);
1319
1320       Enter_Task (Environment_Task);
1321
1322       --  Prepare the set of signals that should unblocked in all tasks
1323
1324       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1325       pragma Assert (Result = 0);
1326
1327       for J in Interrupt_Management.Interrupt_ID loop
1328          if System.Interrupt_Management.Keep_Unmasked (J) then
1329             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1330             pragma Assert (Result = 0);
1331          end if;
1332       end loop;
1333
1334       --  Install the abort-signal handler
1335
1336       if State
1337           (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
1338       then
1339          act.sa_flags := 0;
1340          act.sa_handler := Abort_Handler'Address;
1341
1342          Result := sigemptyset (Tmp_Set'Access);
1343          pragma Assert (Result = 0);
1344          act.sa_mask := Tmp_Set;
1345
1346          Result :=
1347            sigaction
1348              (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1349               act'Unchecked_Access,
1350               old_act'Unchecked_Access);
1351          pragma Assert (Result = 0);
1352       end if;
1353    end Initialize;
1354
1355 end System.Task_Primitives.Operations;