gcc/ada/s-taprop-hpux-dce.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-2011, 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 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  This is a HP-UX DCE threads (HPUX 10) version of this package
  33
  34 --  This package contains all the GNULL primitives that interface directly with
  35 --  the underlying OS.
  36
  37 pragma Polling (Off);
  38 --  Turn off polling, we do not want ATC polling to take place during tasking
  39 --  operations. It causes infinite loops and other problems.
  40
  41 with Ada.Unchecked_Conversion;
  42
  43 with Interfaces.C;
  44
  45 with System.Tasking.Debug;
  46 with System.Interrupt_Management;
  47 with System.OS_Primitives;
  48 with System.Task_Primitives.Interrupt_Operations;
  49
  50 pragma Warnings (Off);
  51 with System.Interrupt_Management.Operations;
  52 pragma Elaborate_All (System.Interrupt_Management.Operations);
  53 pragma Warnings (On);
  54
  55 with System.Soft_Links;
  56 --  We use System.Soft_Links instead of System.Tasking.Initialization
  57 --  because the later is a higher level package that we shouldn't depend on.
  58 --  For example when using the restricted run time, it is replaced by
  59 --  System.Tasking.Restricted.Stages.
  60
  61 package body System.Task_Primitives.Operations is
  62
  63    package SSL renames System.Soft_Links;
  64
  65    use System.Tasking.Debug;
  66    use System.Tasking;
  67    use Interfaces.C;
  68    use System.OS_Interface;
  69    use System.Parameters;
  70    use System.OS_Primitives;
  71
  72    package PIO renames System.Task_Primitives.Interrupt_Operations;
  73
  74    ----------------
  75    -- Local Data --
  76    ----------------
  77
  78    --  The followings are logically constants, but need to be initialized
  79    --  at run time.
  80
  81    Single_RTS_Lock : aliased RTS_Lock;
  82    --  This is a lock to allow only one thread of control in the RTS at
  83    --  a time; it is used to execute in mutual exclusion from all other tasks.
  84    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
  85
  86    Environment_Task_Id : Task_Id;
  87    --  A variable to hold Task_Id for the environment task
  88
  89    Unblocked_Signal_Mask : aliased sigset_t;
  90    --  The set of signals that should unblocked in all tasks
  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    --  Note: the reason that Locking_Policy is not needed is that this
  99    --  is not implemented for DCE threads. The HPUX 10 port is at this
 100    --  stage considered dead, and no further work is planned on it.
 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 the 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    -- ATCB allocation/deallocation --
 134    ----------------------------------
 135
 136    package body ATCB_Allocation is separate;
 137    --  The body of this package is shared across several targets
 138
 139    ---------------------------------
 140    -- Support for foreign threads --
 141    ---------------------------------
 142
 143    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
 144    --  Allocate and Initialize a new ATCB for the current Thread
 145
 146    function Register_Foreign_Thread
 147      (Thread : Thread_Id) return Task_Id is separate;
 148
 149    -----------------------
 150    -- Local Subprograms --
 151    -----------------------
 152
 153    procedure Abort_Handler (Sig : Signal);
 154
 155    function To_Address is
 156      new Ada.Unchecked_Conversion (Task_Id, System.Address);
 157
 158    -------------------
 159    -- Abort_Handler --
 160    -------------------
 161
 162    procedure Abort_Handler (Sig : Signal) is
 163       pragma Unreferenced (Sig);
 164
 165       Self_Id : constant Task_Id := Self;
 166       Result  : Interfaces.C.int;
 167       Old_Set : aliased sigset_t;
 168
 169    begin
 170       if Self_Id.Deferral_Level = 0
 171         and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
 172         and then not Self_Id.Aborting
 173       then
 174          Self_Id.Aborting := True;
 175
 176          --  Make sure signals used for RTS internal purpose are unmasked
 177
 178          Result :=
 179            pthread_sigmask
 180              (SIG_UNBLOCK,
 181               Unblocked_Signal_Mask'Access,
 182               Old_Set'Access);
 183          pragma Assert (Result = 0);
 184
 185          raise Standard'Abort_Signal;
 186       end if;
 187    end Abort_Handler;
 188
 189    -----------------
 190    -- Stack_Guard --
 191    -----------------
 192
 193    --  The underlying thread system sets a guard page at the bottom of a thread
 194    --  stack, so nothing is needed.
 195    --  ??? Check the comment above
 196
 197    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 198       pragma Unreferenced (T, On);
 199    begin
 200       null;
 201    end Stack_Guard;
 202
 203    -------------------
 204    -- Get_Thread_Id --
 205    -------------------
 206
 207    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 208    begin
 209       return T.Common.LL.Thread;
 210    end Get_Thread_Id;
 211
 212    ----------
 213    -- Self --
 214    ----------
 215
 216    function Self return Task_Id renames Specific.Self;
 217
 218    ---------------------
 219    -- Initialize_Lock --
 220    ---------------------
 221
 222    --  Note: mutexes and cond_variables needed per-task basis are initialized
 223    --  in Initialize_TCB and the Storage_Error is handled. Other mutexes (such
 224    --  as RTS_Lock, Memory_Lock...) used in RTS is initialized before any
 225    --  status change of RTS. Therefore raising Storage_Error in the following
 226    --  routines should be able to be handled safely.
 227
 228    procedure Initialize_Lock
 229      (Prio : System.Any_Priority;
 230       L    : not null access Lock)
 231    is
 232       Attributes : aliased pthread_mutexattr_t;
 233       Result     : Interfaces.C.int;
 234
 235    begin
 236       Result := pthread_mutexattr_init (Attributes'Access);
 237       pragma Assert (Result = 0 or else Result = ENOMEM);
 238
 239       if Result = ENOMEM then
 240          raise Storage_Error;
 241       end if;
 242
 243       L.Priority := Prio;
 244
 245       Result := pthread_mutex_init (L.L'Access, Attributes'Access);
 246       pragma Assert (Result = 0 or else Result = ENOMEM);
 247
 248       if Result = ENOMEM then
 249          raise Storage_Error;
 250       end if;
 251
 252       Result := pthread_mutexattr_destroy (Attributes'Access);
 253       pragma Assert (Result = 0);
 254    end Initialize_Lock;
 255
 256    procedure Initialize_Lock
 257      (L     : not null access RTS_Lock;
 258       Level : Lock_Level)
 259    is
 260       pragma Unreferenced (Level);
 261
 262       Attributes : aliased pthread_mutexattr_t;
 263       Result     : Interfaces.C.int;
 264
 265    begin
 266       Result := pthread_mutexattr_init (Attributes'Access);
 267       pragma Assert (Result = 0 or else Result = ENOMEM);
 268
 269       if Result = ENOMEM then
 270          raise Storage_Error;
 271       end if;
 272
 273       Result := pthread_mutex_init (L, Attributes'Access);
 274
 275       pragma Assert (Result = 0 or else Result = ENOMEM);
 276
 277       if Result = ENOMEM then
 278          raise Storage_Error;
 279       end if;
 280
 281       Result := pthread_mutexattr_destroy (Attributes'Access);
 282       pragma Assert (Result = 0);
 283    end Initialize_Lock;
 284
 285    -------------------
 286    -- Finalize_Lock --
 287    -------------------
 288
 289    procedure Finalize_Lock (L : not null access Lock) is
 290       Result : Interfaces.C.int;
 291    begin
 292       Result := pthread_mutex_destroy (L.L'Access);
 293       pragma Assert (Result = 0);
 294    end Finalize_Lock;
 295
 296    procedure Finalize_Lock (L : not null access RTS_Lock) is
 297       Result : Interfaces.C.int;
 298    begin
 299       Result := pthread_mutex_destroy (L);
 300       pragma Assert (Result = 0);
 301    end Finalize_Lock;
 302
 303    ----------------
 304    -- Write_Lock --
 305    ----------------
 306
 307    procedure Write_Lock
 308      (L                 : not null access Lock;
 309       Ceiling_Violation : out Boolean)
 310    is
 311       Result : Interfaces.C.int;
 312
 313    begin
 314       L.Owner_Priority := Get_Priority (Self);
 315
 316       if L.Priority < L.Owner_Priority then
 317          Ceiling_Violation := True;
 318          return;
 319       end if;
 320
 321       Result := pthread_mutex_lock (L.L'Access);
 322       pragma Assert (Result = 0);
 323       Ceiling_Violation := False;
 324    end Write_Lock;
 325
 326    procedure Write_Lock
 327      (L           : not null access RTS_Lock;
 328       Global_Lock : Boolean := False)
 329    is
 330       Result : Interfaces.C.int;
 331    begin
 332       if not Single_Lock or else Global_Lock then
 333          Result := pthread_mutex_lock (L);
 334          pragma Assert (Result = 0);
 335       end if;
 336    end Write_Lock;
 337
 338    procedure Write_Lock (T : Task_Id) is
 339       Result : Interfaces.C.int;
 340    begin
 341       if not Single_Lock then
 342          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 343          pragma Assert (Result = 0);
 344       end if;
 345    end Write_Lock;
 346
 347    ---------------
 348    -- Read_Lock --
 349    ---------------
 350
 351    procedure Read_Lock
 352      (L                 : not null access Lock;
 353       Ceiling_Violation : out Boolean)
 354    is
 355    begin
 356       Write_Lock (L, Ceiling_Violation);
 357    end Read_Lock;
 358
 359    ------------
 360    -- Unlock --
 361    ------------
 362
 363    procedure Unlock (L : not null access Lock) is
 364       Result : Interfaces.C.int;
 365    begin
 366       Result := pthread_mutex_unlock (L.L'Access);
 367       pragma Assert (Result = 0);
 368    end Unlock;
 369
 370    procedure Unlock
 371      (L           : not null access RTS_Lock;
 372       Global_Lock : Boolean := False)
 373    is
 374       Result : Interfaces.C.int;
 375    begin
 376       if not Single_Lock or else Global_Lock then
 377          Result := pthread_mutex_unlock (L);
 378          pragma Assert (Result = 0);
 379       end if;
 380    end Unlock;
 381
 382    procedure Unlock (T : Task_Id) is
 383       Result : Interfaces.C.int;
 384    begin
 385       if not Single_Lock then
 386          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 387          pragma Assert (Result = 0);
 388       end if;
 389    end Unlock;
 390
 391    -----------------
 392    -- Set_Ceiling --
 393    -----------------
 394
 395    --  Dynamic priority ceilings are not supported by the underlying system
 396
 397    procedure Set_Ceiling
 398      (L    : not null access Lock;
 399       Prio : System.Any_Priority)
 400    is
 401       pragma Unreferenced (L, Prio);
 402    begin
 403       null;
 404    end Set_Ceiling;
 405
 406    -----------
 407    -- Sleep --
 408    -----------
 409
 410    procedure Sleep
 411      (Self_ID : Task_Id;
 412       Reason  : System.Tasking.Task_States)
 413    is
 414       pragma Unreferenced (Reason);
 415
 416       Result : Interfaces.C.int;
 417
 418    begin
 419       Result :=
 420         pthread_cond_wait
 421           (cond  => Self_ID.Common.LL.CV'Access,
 422            mutex => (if Single_Lock
 423                      then Single_RTS_Lock'Access
 424                      else Self_ID.Common.LL.L'Access));
 425
 426       --  EINTR is not considered a failure
 427
 428       pragma Assert (Result = 0 or else Result = EINTR);
 429    end Sleep;
 430
 431    -----------------
 432    -- Timed_Sleep --
 433    -----------------
 434
 435    procedure Timed_Sleep
 436      (Self_ID  : Task_Id;
 437       Time     : Duration;
 438       Mode     : ST.Delay_Modes;
 439       Reason   : System.Tasking.Task_States;
 440       Timedout : out Boolean;
 441       Yielded  : out Boolean)
 442    is
 443       pragma Unreferenced (Reason);
 444
 445       Check_Time : constant Duration := Monotonic_Clock;
 446       Abs_Time   : Duration;
 447       Request    : aliased timespec;
 448       Result     : Interfaces.C.int;
 449
 450    begin
 451       Timedout := True;
 452       Yielded := False;
 453
 454       Abs_Time :=
 455         (if Mode = Relative
 456          then Duration'Min (Time, Max_Sensible_Delay) + Check_Time
 457          else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
 458
 459       if Abs_Time > Check_Time then
 460          Request := To_Timespec (Abs_Time);
 461
 462          loop
 463             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 464
 465             Result :=
 466               pthread_cond_timedwait
 467                 (cond    => Self_ID.Common.LL.CV'Access,
 468                  mutex   => (if Single_Lock
 469                              then Single_RTS_Lock'Access
 470                              else Self_ID.Common.LL.L'Access),
 471                  abstime => Request'Access);
 472
 473             exit when Abs_Time <= Monotonic_Clock;
 474
 475             if Result = 0 or Result = EINTR then
 476
 477                --  Somebody may have called Wakeup for us
 478
 479                Timedout := False;
 480                exit;
 481             end if;
 482
 483             pragma Assert (Result = ETIMEDOUT);
 484          end loop;
 485       end if;
 486    end Timed_Sleep;
 487
 488    -----------------
 489    -- Timed_Delay --
 490    -----------------
 491
 492    procedure Timed_Delay
 493      (Self_ID : Task_Id;
 494       Time    : Duration;
 495       Mode    : ST.Delay_Modes)
 496    is
 497       Check_Time : constant Duration := Monotonic_Clock;
 498       Abs_Time   : Duration;
 499       Request    : aliased timespec;
 500
 501       Result : Interfaces.C.int;
 502       pragma Warnings (Off, Result);
 503
 504    begin
 505       if Single_Lock then
 506          Lock_RTS;
 507       end if;
 508
 509       Write_Lock (Self_ID);
 510
 511       Abs_Time :=
 512         (if Mode = Relative
 513          then Time + Check_Time
 514          else Duration'Min (Check_Time + Max_Sensible_Delay, Time));
 515
 516       if Abs_Time > Check_Time then
 517          Request := To_Timespec (Abs_Time);
 518          Self_ID.Common.State := Delay_Sleep;
 519
 520          loop
 521             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 522
 523             Result :=
 524               pthread_cond_timedwait
 525                 (cond    => Self_ID.Common.LL.CV'Access,
 526                  mutex   => (if Single_Lock
 527                              then Single_RTS_Lock'Access
 528                              else Self_ID.Common.LL.L'Access),
 529                  abstime => Request'Access);
 530
 531             exit when Abs_Time <= Monotonic_Clock;
 532
 533             pragma Assert (Result = 0 or else
 534               Result = ETIMEDOUT or else
 535               Result = EINTR);
 536          end loop;
 537
 538          Self_ID.Common.State := Runnable;
 539       end if;
 540
 541       Unlock (Self_ID);
 542
 543       if Single_Lock then
 544          Unlock_RTS;
 545       end if;
 546
 547       Result := sched_yield;
 548    end Timed_Delay;
 549
 550    ---------------------
 551    -- Monotonic_Clock --
 552    ---------------------
 553
 554    function Monotonic_Clock return Duration is
 555       TS     : aliased timespec;
 556       Result : Interfaces.C.int;
 557    begin
 558       Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access);
 559       pragma Assert (Result = 0);
 560       return To_Duration (TS);
 561    end Monotonic_Clock;
 562
 563    -------------------
 564    -- RT_Resolution --
 565    -------------------
 566
 567    function RT_Resolution return Duration is
 568    begin
 569       return 10#1.0#E-6;
 570    end RT_Resolution;
 571
 572    ------------
 573    -- Wakeup --
 574    ------------
 575
 576    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 577       pragma Unreferenced (Reason);
 578       Result : Interfaces.C.int;
 579    begin
 580       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 581       pragma Assert (Result = 0);
 582    end Wakeup;
 583
 584    -----------
 585    -- Yield --
 586    -----------
 587
 588    procedure Yield (Do_Yield : Boolean := True) is
 589       Result : Interfaces.C.int;
 590       pragma Unreferenced (Result);
 591    begin
 592       if Do_Yield then
 593          Result := sched_yield;
 594       end if;
 595    end Yield;
 596
 597    ------------------
 598    -- Set_Priority --
 599    ------------------
 600
 601    type Prio_Array_Type is array (System.Any_Priority) of Integer;
 602    pragma Atomic_Components (Prio_Array_Type);
 603
 604    Prio_Array : Prio_Array_Type;
 605    --  Global array containing the id of the currently running task for
 606    --  each priority.
 607    --
 608    --  Note: assume we are on single processor with run-til-blocked scheduling
 609
 610    procedure Set_Priority
 611      (T                   : Task_Id;
 612       Prio                : System.Any_Priority;
 613       Loss_Of_Inheritance : Boolean := False)
 614    is
 615       Result     : Interfaces.C.int;
 616       Array_Item : Integer;
 617       Param      : aliased struct_sched_param;
 618
 619       function Get_Policy (Prio : System.Any_Priority) return Character;
 620       pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
 621       --  Get priority specific dispatching policy
 622
 623       Priority_Specific_Policy : constant Character := Get_Policy (Prio);
 624       --  Upper case first character of the policy name corresponding to the
 625       --  task as set by a Priority_Specific_Dispatching pragma.
 626
 627    begin
 628       Param.sched_priority  := Interfaces.C.int (Underlying_Priorities (Prio));
 629
 630       if Dispatching_Policy = 'R'
 631         or else Priority_Specific_Policy = 'R'
 632         or else Time_Slice_Val > 0
 633       then
 634          Result :=
 635            pthread_setschedparam
 636              (T.Common.LL.Thread, SCHED_RR, Param'Access);
 637
 638       elsif Dispatching_Policy = 'F'
 639         or else Priority_Specific_Policy = 'F'
 640         or else Time_Slice_Val = 0
 641       then
 642          Result :=
 643            pthread_setschedparam
 644              (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 645
 646       else
 647          Result :=
 648            pthread_setschedparam
 649              (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 650       end if;
 651
 652       pragma Assert (Result = 0);
 653
 654       if Dispatching_Policy = 'F' or else Priority_Specific_Policy = 'F' then
 655
 656          --  Annex D requirement [RM D.2.2 par. 9]:
 657          --    If the task drops its priority due to the loss of inherited
 658          --    priority, it is added at the head of the ready queue for its
 659          --    new active priority.
 660
 661          if Loss_Of_Inheritance
 662            and then Prio < T.Common.Current_Priority
 663          then
 664             Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
 665             Prio_Array (T.Common.Base_Priority) := Array_Item;
 666
 667             loop
 668                --  Let some processes a chance to arrive
 669
 670                Yield;
 671
 672                --  Then wait for our turn to proceed
 673
 674                exit when Array_Item = Prio_Array (T.Common.Base_Priority)
 675                  or else Prio_Array (T.Common.Base_Priority) = 1;
 676             end loop;
 677
 678             Prio_Array (T.Common.Base_Priority) :=
 679               Prio_Array (T.Common.Base_Priority) - 1;
 680          end if;
 681       end if;
 682
 683       T.Common.Current_Priority := Prio;
 684    end Set_Priority;
 685
 686    ------------------
 687    -- Get_Priority --
 688    ------------------
 689
 690    function Get_Priority (T : Task_Id) return System.Any_Priority is
 691    begin
 692       return T.Common.Current_Priority;
 693    end Get_Priority;
 694
 695    ----------------
 696    -- Enter_Task --
 697    ----------------
 698
 699    procedure Enter_Task (Self_ID : Task_Id) is
 700    begin
 701       Self_ID.Common.LL.Thread := pthread_self;
 702       Specific.Set (Self_ID);
 703    end Enter_Task;
 704
 705    -------------------
 706    -- Is_Valid_Task --
 707    -------------------
 708
 709    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 710
 711    -----------------------------
 712    -- Register_Foreign_Thread --
 713    -----------------------------
 714
 715    function Register_Foreign_Thread return Task_Id is
 716    begin
 717       if Is_Valid_Task then
 718          return Self;
 719       else
 720          return Register_Foreign_Thread (pthread_self);
 721       end if;
 722    end Register_Foreign_Thread;
 723
 724    --------------------
 725    -- Initialize_TCB --
 726    --------------------
 727
 728    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 729       Mutex_Attr : aliased pthread_mutexattr_t;
 730       Result     : Interfaces.C.int;
 731       Cond_Attr  : aliased pthread_condattr_t;
 732
 733    begin
 734       if not Single_Lock then
 735          Result := pthread_mutexattr_init (Mutex_Attr'Access);
 736          pragma Assert (Result = 0 or else Result = ENOMEM);
 737
 738          if Result = 0 then
 739             Result :=
 740               pthread_mutex_init
 741                 (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
 742             pragma Assert (Result = 0 or else Result = ENOMEM);
 743          end if;
 744
 745          if Result /= 0 then
 746             Succeeded := False;
 747             return;
 748          end if;
 749
 750          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 751          pragma Assert (Result = 0);
 752       end if;
 753
 754       Result := pthread_condattr_init (Cond_Attr'Access);
 755       pragma Assert (Result = 0 or else Result = ENOMEM);
 756
 757       if Result = 0 then
 758          Result :=
 759            pthread_cond_init
 760              (Self_ID.Common.LL.CV'Access,
 761               Cond_Attr'Access);
 762          pragma Assert (Result = 0 or else Result = ENOMEM);
 763       end if;
 764
 765       if Result = 0 then
 766          Succeeded := True;
 767       else
 768          if not Single_Lock then
 769             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 770             pragma Assert (Result = 0);
 771          end if;
 772
 773          Succeeded := False;
 774       end if;
 775
 776       Result := pthread_condattr_destroy (Cond_Attr'Access);
 777       pragma Assert (Result = 0);
 778    end Initialize_TCB;
 779
 780    -----------------
 781    -- Create_Task --
 782    -----------------
 783
 784    procedure Create_Task
 785      (T          : Task_Id;
 786       Wrapper    : System.Address;
 787       Stack_Size : System.Parameters.Size_Type;
 788       Priority   : System.Any_Priority;
 789       Succeeded  : out Boolean)
 790    is
 791       Attributes : aliased pthread_attr_t;
 792       Result     : Interfaces.C.int;
 793
 794       function Thread_Body_Access is new
 795         Ada.Unchecked_Conversion (System.Address, Thread_Body);
 796
 797    begin
 798       Result := pthread_attr_init (Attributes'Access);
 799       pragma Assert (Result = 0 or else Result = ENOMEM);
 800
 801       if Result /= 0 then
 802          Succeeded := False;
 803          return;
 804       end if;
 805
 806       Result := pthread_attr_setstacksize
 807         (Attributes'Access, Interfaces.C.size_t (Stack_Size));
 808       pragma Assert (Result = 0);
 809
 810       --  Since the initial signal mask of a thread is inherited from the
 811       --  creator, and the Environment task has all its signals masked, we
 812       --  do not need to manipulate caller's signal mask at this point.
 813       --  All tasks in RTS will have All_Tasks_Mask initially.
 814
 815       Result := pthread_create
 816         (T.Common.LL.Thread'Access,
 817          Attributes'Access,
 818          Thread_Body_Access (Wrapper),
 819          To_Address (T));
 820       pragma Assert (Result = 0 or else Result = EAGAIN);
 821
 822       Succeeded := Result = 0;
 823
 824       pthread_detach (T.Common.LL.Thread'Access);
 825       --  Detach the thread using pthread_detach, since DCE threads do not have
 826       --  pthread_attr_set_detachstate.
 827
 828       Result := pthread_attr_destroy (Attributes'Access);
 829       pragma Assert (Result = 0);
 830
 831       Set_Priority (T, Priority);
 832    end Create_Task;
 833
 834    ------------------
 835    -- Finalize_TCB --
 836    ------------------
 837
 838    procedure Finalize_TCB (T : Task_Id) is
 839       Result : Interfaces.C.int;
 840
 841    begin
 842       if not Single_Lock then
 843          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 844          pragma Assert (Result = 0);
 845       end if;
 846
 847       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 848       pragma Assert (Result = 0);
 849
 850       if T.Known_Tasks_Index /= -1 then
 851          Known_Tasks (T.Known_Tasks_Index) := null;
 852       end if;
 853
 854       ATCB_Allocation.Free_ATCB (T);
 855    end Finalize_TCB;
 856
 857    ---------------
 858    -- Exit_Task --
 859    ---------------
 860
 861    procedure Exit_Task is
 862    begin
 863       Specific.Set (null);
 864    end Exit_Task;
 865
 866    ----------------
 867    -- Abort_Task --
 868    ----------------
 869
 870    procedure Abort_Task (T : Task_Id) is
 871    begin
 872       --  Interrupt Server_Tasks may be waiting on an "event" flag (signal)
 873
 874       if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
 875          System.Interrupt_Management.Operations.Interrupt_Self_Process
 876            (PIO.Get_Interrupt_ID (T));
 877       end if;
 878    end Abort_Task;
 879
 880    ----------------
 881    -- Initialize --
 882    ----------------
 883
 884    procedure Initialize (S : in out Suspension_Object) is
 885       Mutex_Attr : aliased pthread_mutexattr_t;
 886       Cond_Attr  : aliased pthread_condattr_t;
 887       Result     : Interfaces.C.int;
 888    begin
 889       --  Initialize internal state (always to False (ARM D.10(6)))
 890
 891       S.State := False;
 892       S.Waiting := False;
 893
 894       --  Initialize internal mutex
 895
 896       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
 897       pragma Assert (Result = 0 or else Result = ENOMEM);
 898
 899       if Result = ENOMEM then
 900          raise Storage_Error;
 901       end if;
 902
 903       --  Initialize internal condition variable
 904
 905       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
 906       pragma Assert (Result = 0 or else Result = ENOMEM);
 907
 908       if Result /= 0 then
 909          Result := pthread_mutex_destroy (S.L'Access);
 910          pragma Assert (Result = 0);
 911
 912          if Result = ENOMEM then
 913             raise Storage_Error;
 914          end if;
 915       end if;
 916    end Initialize;
 917
 918    --------------
 919    -- Finalize --
 920    --------------
 921
 922    procedure Finalize (S : in out Suspension_Object) is
 923       Result  : Interfaces.C.int;
 924
 925    begin
 926       --  Destroy internal mutex
 927
 928       Result := pthread_mutex_destroy (S.L'Access);
 929       pragma Assert (Result = 0);
 930
 931       --  Destroy internal condition variable
 932
 933       Result := pthread_cond_destroy (S.CV'Access);
 934       pragma Assert (Result = 0);
 935    end Finalize;
 936
 937    -------------------
 938    -- Current_State --
 939    -------------------
 940
 941    function Current_State (S : Suspension_Object) return Boolean is
 942    begin
 943       --  We do not want to use lock on this read operation. State is marked
 944       --  as Atomic so that we ensure that the value retrieved is correct.
 945
 946       return S.State;
 947    end Current_State;
 948
 949    ---------------
 950    -- Set_False --
 951    ---------------
 952
 953    procedure Set_False (S : in out Suspension_Object) is
 954       Result  : Interfaces.C.int;
 955
 956    begin
 957       SSL.Abort_Defer.all;
 958
 959       Result := pthread_mutex_lock (S.L'Access);
 960       pragma Assert (Result = 0);
 961
 962       S.State := False;
 963
 964       Result := pthread_mutex_unlock (S.L'Access);
 965       pragma Assert (Result = 0);
 966
 967       SSL.Abort_Undefer.all;
 968    end Set_False;
 969
 970    --------------
 971    -- Set_True --
 972    --------------
 973
 974    procedure Set_True (S : in out Suspension_Object) is
 975       Result : Interfaces.C.int;
 976
 977    begin
 978       SSL.Abort_Defer.all;
 979
 980       Result := pthread_mutex_lock (S.L'Access);
 981       pragma Assert (Result = 0);
 982
 983       --  If there is already a task waiting on this suspension object then
 984       --  we resume it, leaving the state of the suspension object to False,
 985       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
 986       --  the state to True.
 987
 988       if S.Waiting then
 989          S.Waiting := False;
 990          S.State := False;
 991
 992          Result := pthread_cond_signal (S.CV'Access);
 993          pragma Assert (Result = 0);
 994
 995       else
 996          S.State := True;
 997       end if;
 998
 999       Result := pthread_mutex_unlock (S.L'Access);
1000       pragma Assert (Result = 0);
1001
1002       SSL.Abort_Undefer.all;
1003    end Set_True;
1004
1005    ------------------------
1006    -- Suspend_Until_True --
1007    ------------------------
1008
1009    procedure Suspend_Until_True (S : in out Suspension_Object) is
1010       Result : Interfaces.C.int;
1011
1012    begin
1013       SSL.Abort_Defer.all;
1014
1015       Result := pthread_mutex_lock (S.L'Access);
1016       pragma Assert (Result = 0);
1017
1018       if S.Waiting then
1019          --  Program_Error must be raised upon calling Suspend_Until_True
1020          --  if another task is already waiting on that suspension object
1021          --  (ARM D.10 par. 10).
1022
1023          Result := pthread_mutex_unlock (S.L'Access);
1024          pragma Assert (Result = 0);
1025
1026          SSL.Abort_Undefer.all;
1027
1028          raise Program_Error;
1029       else
1030          --  Suspend the task if the state is False. Otherwise, the task
1031          --  continues its execution, and the state of the suspension object
1032          --  is set to False (ARM D.10 par. 9).
1033
1034          if S.State then
1035             S.State := False;
1036          else
1037             S.Waiting := True;
1038
1039             loop
1040                --  Loop in case pthread_cond_wait returns earlier than expected
1041                --  (e.g. in case of EINTR caused by a signal).
1042
1043                Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1044                pragma Assert (Result = 0 or else Result = EINTR);
1045
1046                exit when not S.Waiting;
1047             end loop;
1048          end if;
1049
1050          Result := pthread_mutex_unlock (S.L'Access);
1051          pragma Assert (Result = 0);
1052
1053          SSL.Abort_Undefer.all;
1054       end if;
1055    end Suspend_Until_True;
1056
1057    ----------------
1058    -- Check_Exit --
1059    ----------------
1060
1061    --  Dummy version
1062
1063    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1064       pragma Unreferenced (Self_ID);
1065    begin
1066       return True;
1067    end Check_Exit;
1068
1069    --------------------
1070    -- Check_No_Locks --
1071    --------------------
1072
1073    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1074       pragma Unreferenced (Self_ID);
1075    begin
1076       return True;
1077    end Check_No_Locks;
1078
1079    ----------------------
1080    -- Environment_Task --
1081    ----------------------
1082
1083    function Environment_Task return Task_Id is
1084    begin
1085       return Environment_Task_Id;
1086    end Environment_Task;
1087
1088    --------------
1089    -- Lock_RTS --
1090    --------------
1091
1092    procedure Lock_RTS is
1093    begin
1094       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1095    end Lock_RTS;
1096
1097    ----------------
1098    -- Unlock_RTS --
1099    ----------------
1100
1101    procedure Unlock_RTS is
1102    begin
1103       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1104    end Unlock_RTS;
1105
1106    ------------------
1107    -- Suspend_Task --
1108    ------------------
1109
1110    function Suspend_Task
1111      (T           : ST.Task_Id;
1112       Thread_Self : Thread_Id) return Boolean
1113    is
1114       pragma Unreferenced (T);
1115       pragma Unreferenced (Thread_Self);
1116    begin
1117       return False;
1118    end Suspend_Task;
1119
1120    -----------------
1121    -- Resume_Task --
1122    -----------------
1123
1124    function Resume_Task
1125      (T           : ST.Task_Id;
1126       Thread_Self : Thread_Id) return Boolean
1127    is
1128       pragma Unreferenced (T);
1129       pragma Unreferenced (Thread_Self);
1130    begin
1131       return False;
1132    end Resume_Task;
1133
1134    --------------------
1135    -- Stop_All_Tasks --
1136    --------------------
1137
1138    procedure Stop_All_Tasks is
1139    begin
1140       null;
1141    end Stop_All_Tasks;
1142
1143    ---------------
1144    -- Stop_Task --
1145    ---------------
1146
1147    function Stop_Task (T : ST.Task_Id) return Boolean is
1148       pragma Unreferenced (T);
1149    begin
1150       return False;
1151    end Stop_Task;
1152
1153    -------------------
1154    -- Continue_Task --
1155    -------------------
1156
1157    function Continue_Task (T : ST.Task_Id) return Boolean is
1158       pragma Unreferenced (T);
1159    begin
1160       return False;
1161    end Continue_Task;
1162
1163    ----------------
1164    -- Initialize --
1165    ----------------
1166
1167    procedure Initialize (Environment_Task : Task_Id) is
1168       act     : aliased struct_sigaction;
1169       old_act : aliased struct_sigaction;
1170       Tmp_Set : aliased sigset_t;
1171       Result  : Interfaces.C.int;
1172
1173       function State
1174         (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1175       pragma Import (C, State, "__gnat_get_interrupt_state");
1176       --  Get interrupt state. Defined in a-init.c. The input argument is
1177       --  the interrupt number, and the result is one of the following:
1178
1179       Default : constant Character := 's';
1180       --    'n'   this interrupt not set by any Interrupt_State pragma
1181       --    'u'   Interrupt_State pragma set state to User
1182       --    'r'   Interrupt_State pragma set state to Runtime
1183       --    's'   Interrupt_State pragma set state to System (use "default"
1184       --           system handler)
1185
1186    begin
1187       Environment_Task_Id := Environment_Task;
1188
1189       Interrupt_Management.Initialize;
1190
1191       --  Initialize the lock used to synchronize chain of all ATCBs
1192
1193       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1194
1195       Specific.Initialize (Environment_Task);
1196
1197       --  Make environment task known here because it doesn't go through
1198       --  Activate_Tasks, which does it for all other tasks.
1199
1200       Known_Tasks (Known_Tasks'First) := Environment_Task;
1201       Environment_Task.Known_Tasks_Index := Known_Tasks'First;
1202
1203       Enter_Task (Environment_Task);
1204
1205       --  Install the abort-signal handler
1206
1207       if State (System.Interrupt_Management.Abort_Task_Interrupt)
1208                                                      /= Default
1209       then
1210          act.sa_flags := 0;
1211          act.sa_handler := Abort_Handler'Address;
1212
1213          Result := sigemptyset (Tmp_Set'Access);
1214          pragma Assert (Result = 0);
1215          act.sa_mask := Tmp_Set;
1216
1217          Result :=
1218            sigaction (
1219              Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1220              act'Unchecked_Access,
1221              old_act'Unchecked_Access);
1222          pragma Assert (Result = 0);
1223       end if;
1224    end Initialize;
1225
1226    --  NOTE: Unlike other pthread implementations, we do *not* mask all
1227    --  signals here since we handle signals using the process-wide primitive
1228    --  signal, rather than using sigthreadmask and sigwait. The reason of
1229    --  this difference is that sigwait doesn't work when some critical
1230    --  signals (SIGABRT, SIGPIPE) are masked.
1231
1232    -----------------------
1233    -- Set_Task_Affinity --
1234    -----------------------
1235
1236    procedure Set_Task_Affinity (T : ST.Task_Id) is
1237       pragma Unreferenced (T);
1238
1239    begin
1240       --  Setting task affinity is not supported by the underlying system
1241
1242       null;
1243    end Set_Task_Affinity;
1244
1245 end System.Task_Primitives.Operations;