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