gcc/ada/5htaprop.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA 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-2003, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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
  37 --  with the underlying OS.
  38
  39 pragma Polling (Off);
  40 --  Turn off polling, we do not want ATC polling to take place during
  41 --  tasking operations. It causes infinite loops and other problems.
  42
  43 with System.Tasking.Debug;
  44 --  used for Known_Tasks
  45
  46 with Interfaces.C;
  47 --  used for int
  48 --           size_t
  49
  50 with System.Interrupt_Management;
  51 --  used for Keep_Unmasked
  52 --           Abort_Task_Interrupt
  53 --           Interrupt_ID
  54
  55 with System.Interrupt_Management.Operations;
  56 --  used for Set_Interrupt_Mask
  57 --           All_Tasks_Mask
  58 pragma Elaborate_All (System.Interrupt_Management.Operations);
  59
  60 with System.Parameters;
  61 --  used for Size_Type
  62
  63 with System.Task_Primitives.Interrupt_Operations;
  64 --  used for Get_Interrupt_ID
  65
  66 with System.Tasking;
  67 --  used for Ada_Task_Control_Block
  68 --           Task_ID
  69
  70 with System.Soft_Links;
  71 --  used for Defer/Undefer_Abort
  72
  73 --  Note that we do not use System.Tasking.Initialization directly since
  74 --  this is a higher level package that we shouldn't depend on. For example
  75 --  when using the restricted run time, it is replaced by
  76 --  System.Tasking.Restricted.Initialization
  77
  78 with System.OS_Primitives;
  79 --  used for Delay_Modes
  80
  81 with Unchecked_Conversion;
  82 with Unchecked_Deallocation;
  83
  84 package body System.Task_Primitives.Operations is
  85
  86    use System.Tasking.Debug;
  87    use System.Tasking;
  88    use Interfaces.C;
  89    use System.OS_Interface;
  90    use System.Parameters;
  91    use System.OS_Primitives;
  92
  93    package PIO renames System.Task_Primitives.Interrupt_Operations;
  94    package SSL renames System.Soft_Links;
  95
  96    ------------------
  97    --  Local Data  --
  98    ------------------
  99
 100    --  The followings are logically constants, but need to be initialized
 101    --  at run time.
 102
 103    Single_RTS_Lock : aliased RTS_Lock;
 104    --  This is a lock to allow only one thread of control in the RTS at
 105    --  a time; it is used to execute in mutual exclusion from all other tasks.
 106    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
 107
 108    ATCB_Key : aliased pthread_key_t;
 109    --  Key used to find the Ada Task_ID associated with a thread
 110
 111    Environment_Task_ID : Task_ID;
 112    --  A variable to hold Task_ID for the environment task.
 113
 114    Unblocked_Signal_Mask : aliased sigset_t;
 115    --  The set of signals that should unblocked in all tasks
 116
 117    Time_Slice_Val : Integer;
 118    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 119
 120    Dispatching_Policy : Character;
 121    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 122
 123    --  Note: the reason that Locking_Policy is not needed is that this
 124    --  is not implemented for DCE threads. The HPUX 10 port is at this
 125    --  stage considered dead, and no further work is planned on it.
 126
 127    FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
 128    --  Indicates whether FIFO_Within_Priorities is set.
 129
 130    Foreign_Task_Elaborated : aliased Boolean := True;
 131    --  Used to identified fake tasks (i.e., non-Ada Threads).
 132
 133    --------------------
 134    -- Local Packages --
 135    --------------------
 136
 137    package Specific is
 138
 139       procedure Initialize (Environment_Task : Task_ID);
 140       pragma Inline (Initialize);
 141       --  Initialize various data needed by this package.
 142
 143       function Is_Valid_Task return Boolean;
 144       pragma Inline (Is_Valid_Task);
 145       --  Does the executing thread have a TCB?
 146
 147       procedure Set (Self_Id : Task_ID);
 148       pragma Inline (Set);
 149       --  Set the self id for the current task.
 150
 151       function Self return Task_ID;
 152       pragma Inline (Self);
 153       --  Return a pointer to the Ada Task Control Block of the calling task.
 154
 155    end Specific;
 156
 157    package body Specific is separate;
 158    --  The body of this package is target specific.
 159
 160    ---------------------------------
 161    -- Support for foreign threads --
 162    ---------------------------------
 163
 164    function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
 165    --  Allocate and Initialize a new ATCB for the current Thread.
 166
 167    function Register_Foreign_Thread
 168      (Thread : Thread_Id) return Task_ID is separate;
 169
 170    -----------------------
 171    -- Local Subprograms --
 172    -----------------------
 173
 174    procedure Abort_Handler (Sig : Signal);
 175
 176    function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
 177
 178    -------------------
 179    -- Abort_Handler --
 180    -------------------
 181
 182    procedure Abort_Handler (Sig : Signal) is
 183       pragma Unreferenced (Sig);
 184
 185       Self_Id : constant Task_ID := Self;
 186       Result  : Interfaces.C.int;
 187       Old_Set : aliased sigset_t;
 188
 189    begin
 190       if Self_Id.Deferral_Level = 0
 191         and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then
 192         not Self_Id.Aborting
 193       then
 194          Self_Id.Aborting := True;
 195
 196          --  Make sure signals used for RTS internal purpose are unmasked
 197
 198          Result := pthread_sigmask (SIG_UNBLOCK,
 199            Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
 200          pragma Assert (Result = 0);
 201
 202          raise Standard'Abort_Signal;
 203       end if;
 204    end Abort_Handler;
 205
 206    -----------------
 207    -- Stack_Guard --
 208    -----------------
 209
 210    --  The underlying thread system sets a guard page at the
 211    --  bottom of a thread stack, so nothing is needed.
 212    --  ??? Check the comment above
 213
 214    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
 215       pragma Unreferenced (T, On);
 216    begin
 217       null;
 218    end Stack_Guard;
 219
 220    -------------------
 221    -- Get_Thread_Id --
 222    -------------------
 223
 224    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
 225    begin
 226       return T.Common.LL.Thread;
 227    end Get_Thread_Id;
 228
 229    ----------
 230    -- Self --
 231    ----------
 232
 233    function Self return Task_ID renames Specific.Self;
 234
 235    ---------------------
 236    -- Initialize_Lock --
 237    ---------------------
 238
 239    --  Note: mutexes and cond_variables needed per-task basis are
 240    --        initialized in Initialize_TCB and the Storage_Error is
 241    --        handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 242    --        used in RTS is initialized before any status change of RTS.
 243    --        Therefore rasing Storage_Error in the following routines
 244    --        should be able to be handled safely.
 245
 246    procedure Initialize_Lock
 247      (Prio : System.Any_Priority;
 248       L    : access Lock)
 249    is
 250       Attributes : aliased pthread_mutexattr_t;
 251       Result     : Interfaces.C.int;
 252
 253    begin
 254       Result := pthread_mutexattr_init (Attributes'Access);
 255       pragma Assert (Result = 0 or else Result = ENOMEM);
 256
 257       if Result = ENOMEM then
 258          raise Storage_Error;
 259       end if;
 260
 261       L.Priority := Prio;
 262
 263       Result := pthread_mutex_init (L.L'Access, Attributes'Access);
 264       pragma Assert (Result = 0 or else Result = ENOMEM);
 265
 266       if Result = ENOMEM then
 267          raise Storage_Error;
 268       end if;
 269
 270       Result := pthread_mutexattr_destroy (Attributes'Access);
 271       pragma Assert (Result = 0);
 272    end Initialize_Lock;
 273
 274    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 275       pragma Unreferenced (Level);
 276
 277       Attributes : aliased pthread_mutexattr_t;
 278       Result     : Interfaces.C.int;
 279
 280    begin
 281       Result := pthread_mutexattr_init (Attributes'Access);
 282       pragma Assert (Result = 0 or else Result = ENOMEM);
 283
 284       if Result = ENOMEM then
 285          raise Storage_Error;
 286       end if;
 287
 288       Result := pthread_mutex_init (L, Attributes'Access);
 289
 290       pragma Assert (Result = 0 or else Result = ENOMEM);
 291
 292       if Result = ENOMEM then
 293          raise Storage_Error;
 294       end if;
 295
 296       Result := pthread_mutexattr_destroy (Attributes'Access);
 297       pragma Assert (Result = 0);
 298    end Initialize_Lock;
 299
 300    -------------------
 301    -- Finalize_Lock --
 302    -------------------
 303
 304    procedure Finalize_Lock (L : access Lock) is
 305       Result : Interfaces.C.int;
 306    begin
 307       Result := pthread_mutex_destroy (L.L'Access);
 308       pragma Assert (Result = 0);
 309    end Finalize_Lock;
 310
 311    procedure Finalize_Lock (L : access RTS_Lock) is
 312       Result : Interfaces.C.int;
 313    begin
 314       Result := pthread_mutex_destroy (L);
 315       pragma Assert (Result = 0);
 316    end Finalize_Lock;
 317
 318    ----------------
 319    -- Write_Lock --
 320    ----------------
 321
 322    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 323       Result : Interfaces.C.int;
 324
 325    begin
 326       L.Owner_Priority := Get_Priority (Self);
 327
 328       if L.Priority < L.Owner_Priority then
 329          Ceiling_Violation := True;
 330          return;
 331       end if;
 332
 333       Result := pthread_mutex_lock (L.L'Access);
 334       pragma Assert (Result = 0);
 335       Ceiling_Violation := False;
 336    end Write_Lock;
 337
 338    procedure Write_Lock
 339      (L : access RTS_Lock; Global_Lock : Boolean := False)
 340    is
 341       Result : Interfaces.C.int;
 342
 343    begin
 344       if not Single_Lock or else Global_Lock then
 345          Result := pthread_mutex_lock (L);
 346          pragma Assert (Result = 0);
 347       end if;
 348    end Write_Lock;
 349
 350    procedure Write_Lock (T : Task_ID) is
 351       Result : Interfaces.C.int;
 352
 353    begin
 354       if not Single_Lock then
 355          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 356          pragma Assert (Result = 0);
 357       end if;
 358    end Write_Lock;
 359
 360    ---------------
 361    -- Read_Lock --
 362    ---------------
 363
 364    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 365    begin
 366       Write_Lock (L, Ceiling_Violation);
 367    end Read_Lock;
 368
 369    ------------
 370    -- Unlock --
 371    ------------
 372
 373    procedure Unlock (L : access Lock) is
 374       Result : Interfaces.C.int;
 375
 376    begin
 377       Result := pthread_mutex_unlock (L.L'Access);
 378       pragma Assert (Result = 0);
 379    end Unlock;
 380
 381    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 382       Result : Interfaces.C.int;
 383    begin
 384       if not Single_Lock or else Global_Lock then
 385          Result := pthread_mutex_unlock (L);
 386          pragma Assert (Result = 0);
 387       end if;
 388    end Unlock;
 389
 390    procedure Unlock (T : Task_ID) is
 391       Result : Interfaces.C.int;
 392
 393    begin
 394       if not Single_Lock then
 395          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 396          pragma Assert (Result = 0);
 397       end if;
 398    end Unlock;
 399
 400    -----------
 401    -- Sleep --
 402    -----------
 403
 404    procedure Sleep
 405      (Self_ID : Task_ID;
 406       Reason  : System.Tasking.Task_States)
 407    is
 408       pragma Unreferenced (Reason);
 409
 410       Result : Interfaces.C.int;
 411    begin
 412       if Single_Lock then
 413          Result := pthread_cond_wait
 414            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 415       else
 416          Result := pthread_cond_wait
 417            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 418       end if;
 419
 420       --  EINTR is not considered a failure.
 421       pragma Assert (Result = 0 or else Result = EINTR);
 422    end Sleep;
 423
 424    -----------------
 425    -- Timed_Sleep --
 426    -----------------
 427
 428    procedure Timed_Sleep
 429      (Self_ID  : Task_ID;
 430       Time     : Duration;
 431       Mode     : ST.Delay_Modes;
 432       Reason   : System.Tasking.Task_States;
 433       Timedout : out Boolean;
 434       Yielded  : out Boolean)
 435    is
 436       pragma Unreferenced (Reason);
 437
 438       Check_Time : constant Duration := Monotonic_Clock;
 439       Abs_Time   : Duration;
 440       Request    : aliased timespec;
 441       Result     : Interfaces.C.int;
 442
 443    begin
 444       Timedout := True;
 445       Yielded := False;
 446
 447       if Mode = Relative then
 448          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 449       else
 450          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 451       end if;
 452
 453       if Abs_Time > Check_Time then
 454          Request := To_Timespec (Abs_Time);
 455
 456          loop
 457             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 458               or else Self_ID.Pending_Priority_Change;
 459
 460             if Single_Lock then
 461                Result := pthread_cond_timedwait
 462                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
 463                   Request'Access);
 464
 465             else
 466                Result := pthread_cond_timedwait
 467                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
 468                   Request'Access);
 469             end if;
 470
 471             exit when Abs_Time <= Monotonic_Clock;
 472
 473             if Result = 0 or Result = EINTR then
 474
 475                --  Somebody may have called Wakeup for us
 476
 477                Timedout := False;
 478                exit;
 479             end if;
 480
 481             pragma Assert (Result = ETIMEDOUT);
 482          end loop;
 483       end if;
 484    end Timed_Sleep;
 485
 486    -----------------
 487    -- Timed_Delay --
 488    -----------------
 489
 490    procedure Timed_Delay
 491      (Self_ID  : Task_ID;
 492       Time     : Duration;
 493       Mode     : ST.Delay_Modes)
 494    is
 495       Check_Time : constant Duration := Monotonic_Clock;
 496       Abs_Time   : Duration;
 497       Request    : aliased timespec;
 498       Result     : Interfaces.C.int;
 499
 500    begin
 501       --  Only the little window between deferring abort and
 502       --  locking Self_ID is the reason we need to
 503       --  check for pending abort and priority change below! :(
 504
 505       SSL.Abort_Defer.all;
 506
 507       if Single_Lock then
 508          Lock_RTS;
 509       end if;
 510
 511       Write_Lock (Self_ID);
 512
 513       if Mode = Relative then
 514          Abs_Time := Time + Check_Time;
 515       else
 516          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 517       end if;
 518
 519       if Abs_Time > Check_Time then
 520          Request := To_Timespec (Abs_Time);
 521          Self_ID.Common.State := Delay_Sleep;
 522
 523          loop
 524             if Self_ID.Pending_Priority_Change then
 525                Self_ID.Pending_Priority_Change := False;
 526                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 527                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 528             end if;
 529
 530             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 531
 532             if Single_Lock then
 533                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 534                  Single_RTS_Lock'Access, Request'Access);
 535             else
 536                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 537                  Self_ID.Common.LL.L'Access, Request'Access);
 538             end if;
 539
 540             exit when Abs_Time <= Monotonic_Clock;
 541
 542             pragma Assert (Result = 0 or else
 543               Result = ETIMEDOUT or else
 544               Result = EINTR);
 545          end loop;
 546
 547          Self_ID.Common.State := Runnable;
 548       end if;
 549
 550       Unlock (Self_ID);
 551
 552       if Single_Lock then
 553          Unlock_RTS;
 554       end if;
 555
 556       Result := sched_yield;
 557       SSL.Abort_Undefer.all;
 558    end Timed_Delay;
 559
 560    ---------------------
 561    -- Monotonic_Clock --
 562    ---------------------
 563
 564    function Monotonic_Clock return Duration is
 565       TS     : aliased timespec;
 566       Result : Interfaces.C.int;
 567
 568    begin
 569       Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access);
 570       pragma Assert (Result = 0);
 571       return To_Duration (TS);
 572    end Monotonic_Clock;
 573
 574    -------------------
 575    -- RT_Resolution --
 576    -------------------
 577
 578    function RT_Resolution return Duration is
 579    begin
 580       return 10#1.0#E-6;
 581    end RT_Resolution;
 582
 583    ------------
 584    -- Wakeup --
 585    ------------
 586
 587    procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
 588       pragma Unreferenced (Reason);
 589
 590       Result : Interfaces.C.int;
 591
 592    begin
 593       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 594       pragma Assert (Result = 0);
 595    end Wakeup;
 596
 597    -----------
 598    -- Yield --
 599    -----------
 600
 601    procedure Yield (Do_Yield : Boolean := True) is
 602       Result : Interfaces.C.int;
 603
 604    begin
 605       if Do_Yield then
 606          Result := sched_yield;
 607       end if;
 608    end Yield;
 609
 610    ------------------
 611    -- Set_Priority --
 612    ------------------
 613
 614    type Prio_Array_Type is array (System.Any_Priority) of Integer;
 615    pragma Atomic_Components (Prio_Array_Type);
 616
 617    Prio_Array : Prio_Array_Type;
 618    --  Global array containing the id of the currently running task for
 619    --  each priority.
 620    --
 621    --  Note: we assume that we are on a single processor with run-til-blocked
 622    --  scheduling.
 623
 624    procedure Set_Priority
 625      (T                   : Task_ID;
 626       Prio                : System.Any_Priority;
 627       Loss_Of_Inheritance : Boolean := False)
 628    is
 629       Result     : Interfaces.C.int;
 630       Array_Item : Integer;
 631       Param      : aliased struct_sched_param;
 632
 633    begin
 634       Param.sched_priority  := Interfaces.C.int (Underlying_Priorities (Prio));
 635
 636       if Time_Slice_Val > 0 then
 637          Result := pthread_setschedparam
 638            (T.Common.LL.Thread, SCHED_RR, Param'Access);
 639
 640       elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
 641          Result := pthread_setschedparam
 642            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 643
 644       else
 645          Result := pthread_setschedparam
 646            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 647       end if;
 648
 649       pragma Assert (Result = 0);
 650
 651       if FIFO_Within_Priorities then
 652
 653          --  Annex D requirement [RM D.2.2 par. 9]:
 654          --    If the task drops its priority due to the loss of inherited
 655          --    priority, it is added at the head of the ready queue for its
 656          --    new active priority.
 657
 658          if Loss_Of_Inheritance
 659            and then Prio < T.Common.Current_Priority
 660          then
 661             Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
 662             Prio_Array (T.Common.Base_Priority) := Array_Item;
 663
 664             loop
 665                --  Let some processes a chance to arrive
 666
 667                Yield;
 668
 669                --  Then wait for our turn to proceed
 670
 671                exit when Array_Item = Prio_Array (T.Common.Base_Priority)
 672                  or else Prio_Array (T.Common.Base_Priority) = 1;
 673             end loop;
 674
 675             Prio_Array (T.Common.Base_Priority) :=
 676               Prio_Array (T.Common.Base_Priority) - 1;
 677          end if;
 678       end if;
 679
 680       T.Common.Current_Priority := Prio;
 681    end Set_Priority;
 682
 683    ------------------
 684    -- Get_Priority --
 685    ------------------
 686
 687    function Get_Priority (T : Task_ID) return System.Any_Priority is
 688    begin
 689       return T.Common.Current_Priority;
 690    end Get_Priority;
 691
 692    ----------------
 693    -- Enter_Task --
 694    ----------------
 695
 696    procedure Enter_Task (Self_ID : Task_ID) is
 697    begin
 698       Self_ID.Common.LL.Thread := pthread_self;
 699       Specific.Set (Self_ID);
 700
 701       Lock_RTS;
 702
 703       for J in Known_Tasks'Range loop
 704          if Known_Tasks (J) = null then
 705             Known_Tasks (J) := Self_ID;
 706             Self_ID.Known_Tasks_Index := J;
 707             exit;
 708          end if;
 709       end loop;
 710
 711       Unlock_RTS;
 712    end Enter_Task;
 713
 714    --------------
 715    -- New_ATCB --
 716    --------------
 717
 718    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 719    begin
 720       return new Ada_Task_Control_Block (Entry_Num);
 721    end New_ATCB;
 722
 723    -------------------
 724    -- Is_Valid_Task --
 725    -------------------
 726
 727    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 728
 729    -----------------------------
 730    -- Register_Foreign_Thread --
 731    -----------------------------
 732
 733    function Register_Foreign_Thread return Task_ID is
 734    begin
 735       if Is_Valid_Task then
 736          return Self;
 737       else
 738          return Register_Foreign_Thread (pthread_self);
 739       end if;
 740    end Register_Foreign_Thread;
 741
 742    --------------------
 743    -- Initialize_TCB --
 744    --------------------
 745
 746    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 747       Mutex_Attr : aliased pthread_mutexattr_t;
 748       Result     : Interfaces.C.int;
 749       Cond_Attr  : aliased pthread_condattr_t;
 750
 751    begin
 752       if not Single_Lock then
 753          Result := pthread_mutexattr_init (Mutex_Attr'Access);
 754          pragma Assert (Result = 0 or else Result = ENOMEM);
 755
 756          if Result = 0 then
 757             Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
 758               Mutex_Attr'Access);
 759             pragma Assert (Result = 0 or else Result = ENOMEM);
 760          end if;
 761
 762          if Result /= 0 then
 763             Succeeded := False;
 764             return;
 765          end if;
 766
 767          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 768          pragma Assert (Result = 0);
 769       end if;
 770
 771       Result := pthread_condattr_init (Cond_Attr'Access);
 772       pragma Assert (Result = 0 or else Result = ENOMEM);
 773
 774       if Result = 0 then
 775          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 776            Cond_Attr'Access);
 777          pragma Assert (Result = 0 or else Result = ENOMEM);
 778       end if;
 779
 780       if Result = 0 then
 781          Succeeded := True;
 782       else
 783          if not Single_Lock then
 784             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 785             pragma Assert (Result = 0);
 786          end if;
 787
 788          Succeeded := False;
 789       end if;
 790
 791       Result := pthread_condattr_destroy (Cond_Attr'Access);
 792       pragma Assert (Result = 0);
 793    end Initialize_TCB;
 794
 795    -----------------
 796    -- Create_Task --
 797    -----------------
 798
 799    procedure Create_Task
 800      (T          : Task_ID;
 801       Wrapper    : System.Address;
 802       Stack_Size : System.Parameters.Size_Type;
 803       Priority   : System.Any_Priority;
 804       Succeeded  : out Boolean)
 805    is
 806       Attributes          : aliased pthread_attr_t;
 807       Adjusted_Stack_Size : Interfaces.C.size_t;
 808       Result              : Interfaces.C.int;
 809
 810       function Thread_Body_Access is new
 811         Unchecked_Conversion (System.Address, Thread_Body);
 812
 813    begin
 814       if Stack_Size = Unspecified_Size then
 815          Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
 816
 817       elsif Stack_Size < Minimum_Stack_Size then
 818          Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
 819
 820       else
 821          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 822       end if;
 823
 824       Result := pthread_attr_init (Attributes'Access);
 825       pragma Assert (Result = 0 or else Result = ENOMEM);
 826
 827       if Result /= 0 then
 828          Succeeded := False;
 829          return;
 830       end if;
 831
 832       Result := pthread_attr_setstacksize
 833         (Attributes'Access, Adjusted_Stack_Size);
 834       pragma Assert (Result = 0);
 835
 836       --  Since the initial signal mask of a thread is inherited from the
 837       --  creator, and the Environment task has all its signals masked, we
 838       --  do not need to manipulate caller's signal mask at this point.
 839       --  All tasks in RTS will have All_Tasks_Mask initially.
 840
 841       Result := pthread_create
 842         (T.Common.LL.Thread'Access,
 843          Attributes'Access,
 844          Thread_Body_Access (Wrapper),
 845          To_Address (T));
 846       pragma Assert (Result = 0 or else Result = EAGAIN);
 847
 848       Succeeded := Result = 0;
 849
 850       pthread_detach (T.Common.LL.Thread'Access);
 851       --  Detach the thread using pthread_detach, sinc DCE threads do not have
 852       --  pthread_attr_set_detachstate.
 853
 854       Result := pthread_attr_destroy (Attributes'Access);
 855       pragma Assert (Result = 0);
 856
 857       Set_Priority (T, Priority);
 858    end Create_Task;
 859
 860    ------------------
 861    -- Finalize_TCB --
 862    ------------------
 863
 864    procedure Finalize_TCB (T : Task_ID) is
 865       Result : Interfaces.C.int;
 866       Tmp    : Task_ID := T;
 867       Is_Self : constant Boolean := T = Self;
 868
 869       procedure Free is new
 870         Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
 871
 872    begin
 873       if not Single_Lock then
 874          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 875          pragma Assert (Result = 0);
 876       end if;
 877
 878       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 879       pragma Assert (Result = 0);
 880
 881       if T.Known_Tasks_Index /= -1 then
 882          Known_Tasks (T.Known_Tasks_Index) := null;
 883       end if;
 884
 885       Free (Tmp);
 886
 887       if Is_Self then
 888          Result := pthread_setspecific (ATCB_Key, System.Null_Address);
 889          pragma Assert (Result = 0);
 890       end if;
 891
 892    end Finalize_TCB;
 893
 894    ---------------
 895    -- Exit_Task --
 896    ---------------
 897
 898    procedure Exit_Task is
 899    begin
 900       Specific.Set (null);
 901    end Exit_Task;
 902
 903    ----------------
 904    -- Abort_Task --
 905    ----------------
 906
 907    procedure Abort_Task (T : Task_ID) is
 908    begin
 909       --
 910       --  Interrupt Server_Tasks may be waiting on an "event" flag (signal)
 911       --
 912       if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
 913          System.Interrupt_Management.Operations.Interrupt_Self_Process
 914            (System.Interrupt_Management.Interrupt_ID
 915              (PIO.Get_Interrupt_ID (T)));
 916       end if;
 917    end Abort_Task;
 918
 919    ----------------
 920    -- Check_Exit --
 921    ----------------
 922
 923    --  Dummy versions.  The only currently working versions is for solaris
 924    --  (native).
 925
 926    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 927       pragma Unreferenced (Self_ID);
 928    begin
 929       return True;
 930    end Check_Exit;
 931
 932    --------------------
 933    -- Check_No_Locks --
 934    --------------------
 935
 936    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 937       pragma Unreferenced (Self_ID);
 938    begin
 939       return True;
 940    end Check_No_Locks;
 941
 942    ----------------------
 943    -- Environment_Task --
 944    ----------------------
 945
 946    function Environment_Task return Task_ID is
 947    begin
 948       return Environment_Task_ID;
 949    end Environment_Task;
 950
 951    --------------
 952    -- Lock_RTS --
 953    --------------
 954
 955    procedure Lock_RTS is
 956    begin
 957       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 958    end Lock_RTS;
 959
 960    ----------------
 961    -- Unlock_RTS --
 962    ----------------
 963
 964    procedure Unlock_RTS is
 965    begin
 966       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 967    end Unlock_RTS;
 968
 969    ------------------
 970    -- Suspend_Task --
 971    ------------------
 972
 973    function Suspend_Task
 974      (T           : ST.Task_ID;
 975       Thread_Self : Thread_Id)
 976       return        Boolean
 977    is
 978       pragma Unreferenced (T);
 979       pragma Unreferenced (Thread_Self);
 980
 981    begin
 982       return False;
 983    end Suspend_Task;
 984
 985    -----------------
 986    -- Resume_Task --
 987    -----------------
 988
 989    function Resume_Task
 990      (T           : ST.Task_ID;
 991       Thread_Self : Thread_Id)
 992       return        Boolean
 993    is
 994       pragma Unreferenced (T);
 995       pragma Unreferenced (Thread_Self);
 996
 997    begin
 998       return False;
 999    end Resume_Task;
1000
1001    ----------------
1002    -- Initialize --
1003    ----------------
1004
1005    procedure Initialize (Environment_Task : Task_ID) is
1006       act       : aliased struct_sigaction;
1007       old_act   : aliased struct_sigaction;
1008       Tmp_Set   : aliased sigset_t;
1009       Result    : Interfaces.C.int;
1010
1011       function State (Int : System.Interrupt_Management.Interrupt_ID)
1012                      return Character;
1013       pragma Import (C, State, "__gnat_get_interrupt_state");
1014       --  Get interrupt state.  Defined in a-init.c
1015       --  The input argument is the interrupt number,
1016       --  and the result is one of the following:
1017
1018       Default : constant Character := 's';
1019       --    'n'   this interrupt not set by any Interrupt_State pragma
1020       --    'u'   Interrupt_State pragma set state to User
1021       --    'r'   Interrupt_State pragma set state to Runtime
1022       --    's'   Interrupt_State pragma set state to System (use "default"
1023       --           system handler)
1024
1025    begin
1026       Environment_Task_ID := Environment_Task;
1027
1028       --  Initialize the lock used to synchronize chain of all ATCBs.
1029
1030       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1031
1032       Specific.Initialize (Environment_Task);
1033
1034       Enter_Task (Environment_Task);
1035
1036       --  Install the abort-signal handler
1037
1038       if State (System.Interrupt_Management.Abort_Task_Interrupt)
1039                                                      /= Default
1040       then
1041          act.sa_flags := 0;
1042          act.sa_handler := Abort_Handler'Address;
1043
1044          Result := sigemptyset (Tmp_Set'Access);
1045          pragma Assert (Result = 0);
1046          act.sa_mask := Tmp_Set;
1047
1048          Result :=
1049            sigaction (
1050              Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1051              act'Unchecked_Access,
1052              old_act'Unchecked_Access);
1053          pragma Assert (Result = 0);
1054       end if;
1055    end Initialize;
1056
1057    --  NOTE: Unlike other pthread implementations, we do *not* mask all
1058    --  signals here since we handle signals using the process-wide primitive
1059    --  signal, rather than using sigthreadmask and sigwait. The reason of
1060    --  this difference is that sigwait doesn't work when some critical
1061    --  signals (SIGABRT, SIGPIPE) are masked.
1062
1063 end System.Task_Primitives.Operations;