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