gomp-20050608-branch/gcc/ada/s-taprop-tru64.adb

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