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