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