gcc/ada/s-taprop-lynxos.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 LynxOS version of this file, adapted to make
  35 --  SCHED_FIFO and ceiling locking (Annex D compliance) work properly
  36
  37 --  This package contains all the GNULL primitives that interface directly
  38 --  with the underlying OS.
  39
  40 pragma Polling (Off);
  41 --  Turn off polling, we do not want ATC polling to take place during
  42 --  tasking operations. It causes infinite loops and other problems.
  43
  44 with System.Tasking.Debug;
  45 --  used for Known_Tasks
  46
  47 with System.Interrupt_Management;
  48 --  used for Keep_Unmasked
  49 --           Abort_Task_Interrupt
  50 --           Interrupt_ID
  51
  52 with System.OS_Primitives;
  53 --  used for Delay_Modes
  54
  55 with System.Task_Info;
  56 --  used for Task_Info_Type
  57
  58 with Interfaces.C;
  59 --  used for int
  60 --           size_t
  61
  62 with Unchecked_Deallocation;
  63
  64 package body System.Task_Primitives.Operations is
  65
  66    use System.Tasking.Debug;
  67    use System.Tasking;
  68    use Interfaces.C;
  69    use System.OS_Interface;
  70    use System.Parameters;
  71    use System.OS_Primitives;
  72
  73    ----------------
  74    -- Local Data --
  75    ----------------
  76
  77    --  The followings are logically constants, but need to be initialized
  78    --  at run time.
  79
  80    Single_RTS_Lock : aliased RTS_Lock;
  81    --  This is a lock to allow only one thread of control in the RTS at
  82    --  a time; it is used to execute in mutual exclusion from all other tasks.
  83    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
  84
  85    ATCB_Key : aliased pthread_key_t;
  86    --  Key used to find the Ada Task_Id associated with a thread
  87
  88    Environment_Task_Id : Task_Id;
  89    --  A variable to hold Task_Id for the environment task
  90
  91    Locking_Policy : Character;
  92    pragma Import (C, Locking_Policy, "__gl_locking_policy");
  93    --  Value of the pragma Locking_Policy:
  94    --    'C' for Ceiling_Locking
  95    --    'I' for Inherit_Locking
  96    --    ' ' for none.
  97
  98    Unblocked_Signal_Mask : aliased sigset_t;
  99    --  The set of signals that should unblocked in all tasks
 100
 101    --  The followings are internal configuration constants needed
 102
 103    Next_Serial_Number : Task_Serial_Number := 100;
 104    --  We start at 100, to reserve some special values for
 105    --  using in error checking.
 106
 107    Time_Slice_Val : Integer;
 108    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 109
 110    Dispatching_Policy : Character;
 111    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 112
 113    Foreign_Task_Elaborated : aliased Boolean := True;
 114    --  Used to identified fake tasks (i.e., non-Ada Threads)
 115
 116    --------------------
 117    -- Local Packages --
 118    --------------------
 119
 120    package Specific is
 121
 122       procedure Initialize (Environment_Task : Task_Id);
 123       pragma Inline (Initialize);
 124       --  Initialize various data needed by this package
 125
 126       function Is_Valid_Task return Boolean;
 127       pragma Inline (Is_Valid_Task);
 128       --  Does the current thread have an ATCB?
 129
 130       procedure Set (Self_Id : Task_Id);
 131       pragma Inline (Set);
 132       --  Set the self id for the current task
 133
 134       function Self return Task_Id;
 135       pragma Inline (Self);
 136       --  Return a pointer to the Ada Task Control Block of the calling task
 137
 138    end Specific;
 139
 140    package body Specific is separate;
 141    --  The body of this package is target specific
 142
 143    ---------------------------------
 144    -- Support for foreign threads --
 145    ---------------------------------
 146
 147    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
 148    --  Allocate and Initialize a new ATCB for the current Thread
 149
 150    function Register_Foreign_Thread
 151      (Thread : Thread_Id) return Task_Id is separate;
 152
 153    -----------------------
 154    -- Local Subprograms --
 155    -----------------------
 156
 157    procedure Abort_Handler (Sig : Signal);
 158    --  Signal handler used to implement asynchronous abort
 159
 160    procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority);
 161    --  This procedure calls the scheduler of the OS to set thread's priority
 162
 163    -------------------
 164    -- Abort_Handler --
 165    -------------------
 166
 167    procedure Abort_Handler (Sig : Signal) is
 168       pragma Unreferenced (Sig);
 169
 170       T       : constant Task_Id := Self;
 171       Result  : Interfaces.C.int;
 172       Old_Set : aliased sigset_t;
 173
 174    begin
 175       --  It is not safe to raise an exception when using ZCX and the GCC
 176       --  exception handling mechanism.
 177
 178       if ZCX_By_Default and then GCC_ZCX_Support then
 179          return;
 180       end if;
 181
 182       if T.Deferral_Level = 0
 183         and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
 184         not T.Aborting
 185       then
 186          T.Aborting := True;
 187
 188          --  Make sure signals used for RTS internal purpose are unmasked
 189
 190          Result :=
 191            pthread_sigmask (SIG_UNBLOCK,
 192                             Unblocked_Signal_Mask'Unchecked_Access,
 193                             Old_Set'Unchecked_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    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 205       Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
 206       Guard_Page_Address : Address;
 207
 208       Res : Interfaces.C.int;
 209
 210    begin
 211       if Stack_Base_Available then
 212
 213          --  Compute the guard page address
 214
 215          Guard_Page_Address :=
 216            Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size;
 217
 218          if On then
 219             Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON);
 220          else
 221             Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF);
 222          end if;
 223
 224          pragma Assert (Res = 0);
 225       end if;
 226    end Stack_Guard;
 227
 228    --------------------
 229    -- Get_Thread_Id  --
 230    --------------------
 231
 232    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 233    begin
 234       return T.Common.LL.Thread;
 235    end Get_Thread_Id;
 236
 237    ----------
 238    -- Self --
 239    ----------
 240
 241    function Self return Task_Id renames Specific.Self;
 242
 243    ---------------------
 244    -- Initialize_Lock --
 245    ---------------------
 246
 247    procedure Initialize_Lock
 248      (Prio : System.Any_Priority;
 249       L    : access Lock)
 250    is
 251       Attributes : aliased pthread_mutexattr_t;
 252       Result : Interfaces.C.int;
 253
 254    begin
 255       Result := pthread_mutexattr_init (Attributes'Access);
 256       pragma Assert (Result = 0 or else Result = ENOMEM);
 257
 258       if Result = ENOMEM then
 259          raise Storage_Error;
 260       end if;
 261
 262       if Locking_Policy = 'C' then
 263          L.Ceiling := Prio;
 264       end if;
 265
 266       Result := pthread_mutex_init (L.Mutex'Access, Attributes'Access);
 267       pragma Assert (Result = 0 or else Result = ENOMEM);
 268
 269       if Result = ENOMEM then
 270          raise Storage_Error;
 271       end if;
 272
 273       Result := pthread_mutexattr_destroy (Attributes'Access);
 274       pragma Assert (Result = 0);
 275    end Initialize_Lock;
 276
 277    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 278       pragma Unreferenced (Level);
 279
 280       Attributes : aliased pthread_mutexattr_t;
 281       Result : Interfaces.C.int;
 282
 283    begin
 284       Result := pthread_mutexattr_init (Attributes'Access);
 285       pragma Assert (Result = 0 or else Result = ENOMEM);
 286
 287       if Result = ENOMEM then
 288          raise Storage_Error;
 289       end if;
 290
 291       Result := pthread_mutex_init (L, Attributes'Access);
 292       pragma Assert (Result = 0 or else Result = ENOMEM);
 293
 294       if Result = ENOMEM then
 295          Result := pthread_mutexattr_destroy (Attributes'Access);
 296          raise Storage_Error;
 297       end if;
 298
 299       Result := pthread_mutexattr_destroy (Attributes'Access);
 300       pragma Assert (Result = 0);
 301    end Initialize_Lock;
 302
 303    -------------------
 304    -- Finalize_Lock --
 305    -------------------
 306
 307    procedure Finalize_Lock (L : access Lock) is
 308       Result : Interfaces.C.int;
 309    begin
 310       Result := pthread_mutex_destroy (L.Mutex'Access);
 311       pragma Assert (Result = 0);
 312    end Finalize_Lock;
 313
 314    procedure Finalize_Lock (L : access RTS_Lock) is
 315       Result : Interfaces.C.int;
 316    begin
 317       Result := pthread_mutex_destroy (L);
 318       pragma Assert (Result = 0);
 319    end Finalize_Lock;
 320
 321    ----------------
 322    -- Write_Lock --
 323    ----------------
 324
 325    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 326       Result : Interfaces.C.int;
 327       T : constant Task_Id := Self;
 328
 329    begin
 330       if Locking_Policy = 'C' then
 331          if T.Common.Current_Priority > L.Ceiling then
 332             Ceiling_Violation := True;
 333             return;
 334          end if;
 335
 336          L.Saved_Priority := T.Common.Current_Priority;
 337
 338          if T.Common.Current_Priority < L.Ceiling then
 339             Set_OS_Priority (T, L.Ceiling);
 340          end if;
 341       end if;
 342
 343       Result := pthread_mutex_lock (L.Mutex'Access);
 344
 345       --  Assume that the cause of EINVAL is a priority ceiling violation
 346
 347       Ceiling_Violation := (Result = EINVAL);
 348       pragma Assert (Result = 0 or else Result = EINVAL);
 349    end Write_Lock;
 350
 351    --  No tricks on RTS_Locks
 352
 353    procedure Write_Lock
 354      (L : access RTS_Lock; Global_Lock : Boolean := False)
 355    is
 356       Result : Interfaces.C.int;
 357    begin
 358       if not Single_Lock or else Global_Lock then
 359          Result := pthread_mutex_lock (L);
 360          pragma Assert (Result = 0);
 361       end if;
 362    end Write_Lock;
 363
 364    procedure Write_Lock (T : Task_Id) is
 365       Result : Interfaces.C.int;
 366    begin
 367       if not Single_Lock then
 368          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 369          pragma Assert (Result = 0);
 370       end if;
 371    end Write_Lock;
 372
 373    ---------------
 374    -- Read_Lock --
 375    ---------------
 376
 377    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 378    begin
 379       Write_Lock (L, Ceiling_Violation);
 380    end Read_Lock;
 381
 382    ------------
 383    -- Unlock --
 384    ------------
 385
 386    procedure Unlock (L : access Lock) is
 387       Result : Interfaces.C.int;
 388       T : constant Task_Id := Self;
 389
 390    begin
 391       Result := pthread_mutex_unlock (L.Mutex'Access);
 392       pragma Assert (Result = 0);
 393
 394       if Locking_Policy = 'C' then
 395          if T.Common.Current_Priority > L.Saved_Priority then
 396             Set_OS_Priority (T, L.Saved_Priority);
 397          end if;
 398       end if;
 399    end Unlock;
 400
 401    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) 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    -- Sleep --
 421    -----------
 422
 423    procedure Sleep
 424      (Self_ID : Task_Id;
 425       Reason   : System.Tasking.Task_States)
 426    is
 427       pragma Unreferenced (Reason);
 428       Result : Interfaces.C.int;
 429
 430    begin
 431       if Single_Lock then
 432          Result := pthread_cond_wait
 433            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 434       else
 435          Result := pthread_cond_wait
 436            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 437       end if;
 438
 439       --  EINTR is not considered a failure
 440
 441       pragma Assert (Result = 0 or else Result = EINTR);
 442    end Sleep;
 443
 444    -----------------
 445    -- Timed_Sleep --
 446    -----------------
 447
 448    --  This is for use within the run-time system, so abort is
 449    --  assumed to be already deferred, and the caller should be
 450    --  holding its own ATCB lock.
 451
 452    procedure Timed_Sleep
 453      (Self_ID  : Task_Id;
 454       Time     : Duration;
 455       Mode     : ST.Delay_Modes;
 456       Reason   : Task_States;
 457       Timedout : out Boolean;
 458       Yielded  : out Boolean)
 459    is
 460       pragma Unreferenced (Reason);
 461
 462       Check_Time : constant Duration := Monotonic_Clock;
 463       Rel_Time   : Duration;
 464       Abs_Time   : Duration;
 465       Request    : aliased timespec;
 466       Result     : Interfaces.C.int;
 467
 468    begin
 469       Timedout := True;
 470       Yielded := False;
 471
 472       if Mode = Relative then
 473          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 474
 475          if Relative_Timed_Wait then
 476             Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
 477          end if;
 478
 479       else
 480          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 481
 482          if Relative_Timed_Wait then
 483             Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
 484          end if;
 485       end if;
 486
 487       if Abs_Time > Check_Time then
 488          if Relative_Timed_Wait then
 489             Request := To_Timespec (Rel_Time);
 490          else
 491             Request := To_Timespec (Abs_Time);
 492          end if;
 493
 494          loop
 495             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 496               or else Self_ID.Pending_Priority_Change;
 497
 498             if Single_Lock then
 499                Result := pthread_cond_timedwait
 500                  (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
 501                   Request'Access);
 502
 503             else
 504                Result := pthread_cond_timedwait
 505                  (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
 506                   Request'Access);
 507             end if;
 508
 509             exit when Abs_Time <= Monotonic_Clock;
 510
 511             if Result = 0 or Result = EINTR then
 512
 513                --  Somebody may have called Wakeup for us
 514
 515                Timedout := False;
 516                exit;
 517             end if;
 518
 519             pragma Assert (Result = ETIMEDOUT);
 520          end loop;
 521       end if;
 522    end Timed_Sleep;
 523
 524    -----------------
 525    -- Timed_Delay --
 526    -----------------
 527
 528    --  This is for use in implementing delay statements, so we assume
 529    --  the caller is abort-deferred but is holding no locks.
 530
 531    procedure Timed_Delay
 532      (Self_ID  : Task_Id;
 533       Time     : Duration;
 534       Mode     : ST.Delay_Modes)
 535    is
 536       Check_Time : constant Duration := Monotonic_Clock;
 537       Abs_Time   : Duration;
 538       Rel_Time   : Duration;
 539       Request    : aliased timespec;
 540       Result     : Interfaces.C.int;
 541
 542    begin
 543       if Single_Lock then
 544          Lock_RTS;
 545       end if;
 546
 547       --  Comments needed in code below ???
 548
 549       Write_Lock (Self_ID);
 550
 551       if Mode = Relative then
 552          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 553
 554          if Relative_Timed_Wait then
 555             Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
 556          end if;
 557
 558       else
 559          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 560
 561          if Relative_Timed_Wait then
 562             Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
 563          end if;
 564       end if;
 565
 566       if Abs_Time > Check_Time then
 567          if Relative_Timed_Wait then
 568             Request := To_Timespec (Rel_Time);
 569          else
 570             Request := To_Timespec (Abs_Time);
 571          end if;
 572
 573          Self_ID.Common.State := Delay_Sleep;
 574
 575          loop
 576             if Self_ID.Pending_Priority_Change then
 577                Self_ID.Pending_Priority_Change := False;
 578                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 579                Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 580             end if;
 581
 582             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 583
 584             if Single_Lock then
 585                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 586                  Single_RTS_Lock'Access, Request'Access);
 587             else
 588                Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
 589                  Self_ID.Common.LL.L'Access, Request'Access);
 590             end if;
 591
 592             exit when Abs_Time <= Monotonic_Clock;
 593
 594             pragma Assert (Result = 0
 595                              or else Result = ETIMEDOUT
 596                              or else Result = EINTR);
 597          end loop;
 598
 599          Self_ID.Common.State := Runnable;
 600       end if;
 601
 602       Unlock (Self_ID);
 603
 604       if Single_Lock then
 605          Unlock_RTS;
 606       end if;
 607
 608       Result := sched_yield;
 609    end Timed_Delay;
 610
 611    ---------------------
 612    -- Monotonic_Clock --
 613    ---------------------
 614
 615    function Monotonic_Clock return Duration is
 616       TS     : aliased timespec;
 617       Result : Interfaces.C.int;
 618    begin
 619       Result := clock_gettime
 620         (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
 621       pragma Assert (Result = 0);
 622       return To_Duration (TS);
 623    end Monotonic_Clock;
 624
 625    -------------------
 626    -- RT_Resolution --
 627    -------------------
 628
 629    function RT_Resolution return Duration is
 630       Res    : aliased timespec;
 631       Result : Interfaces.C.int;
 632    begin
 633       Result := clock_getres
 634         (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access);
 635       pragma Assert (Result = 0);
 636       return To_Duration (Res);
 637    end RT_Resolution;
 638
 639    ------------
 640    -- Wakeup --
 641    ------------
 642
 643    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 644       pragma Unreferenced (Reason);
 645       Result : Interfaces.C.int;
 646    begin
 647       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 648       pragma Assert (Result = 0);
 649    end Wakeup;
 650
 651    -----------
 652    -- Yield --
 653    -----------
 654
 655    procedure Yield (Do_Yield : Boolean := True) is
 656       Result : Interfaces.C.int;
 657       pragma Unreferenced (Result);
 658    begin
 659       if Do_Yield then
 660          Result := sched_yield;
 661       end if;
 662    end Yield;
 663
 664    ------------------
 665    -- Set_Priority --
 666    ------------------
 667
 668    procedure Set_OS_Priority (T : Task_Id; Prio : System.Any_Priority) is
 669       Result : Interfaces.C.int;
 670       Param  : aliased struct_sched_param;
 671
 672    begin
 673       Param.sched_priority := Interfaces.C.int (Prio);
 674
 675       if Time_Slice_Supported and then Time_Slice_Val > 0 then
 676          Result := pthread_setschedparam
 677            (T.Common.LL.Thread, SCHED_RR, Param'Access);
 678
 679       elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
 680          Result := pthread_setschedparam
 681            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 682
 683       else
 684          Result := pthread_setschedparam
 685            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 686       end if;
 687
 688       pragma Assert (Result = 0);
 689    end Set_OS_Priority;
 690
 691    type Prio_Array_Type is array (System.Any_Priority) of Integer;
 692    pragma Atomic_Components (Prio_Array_Type);
 693    Prio_Array : Prio_Array_Type;
 694    --  Comments needed for these declarations ???
 695
 696    procedure Set_Priority
 697      (T                   : Task_Id;
 698       Prio                : System.Any_Priority;
 699       Loss_Of_Inheritance : Boolean := False)
 700    is
 701       Array_Item : Integer;
 702
 703    begin
 704       Set_OS_Priority (T, Prio);
 705
 706       if Locking_Policy = 'C' then
 707          --  Annex D requirements: loss of inheritance puts task at the
 708          --  beginning of the queue for that prio; copied from 5ztaprop
 709          --  (VxWorks)
 710
 711          if Loss_Of_Inheritance
 712            and then Prio < T.Common.Current_Priority then
 713
 714             Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
 715             Prio_Array (T.Common.Base_Priority) := Array_Item;
 716
 717             loop
 718                Yield;
 719                exit when Array_Item = Prio_Array (T.Common.Base_Priority)
 720                  or else Prio_Array (T.Common.Base_Priority) = 1;
 721             end loop;
 722
 723             Prio_Array (T.Common.Base_Priority) :=
 724               Prio_Array (T.Common.Base_Priority) - 1;
 725          end if;
 726       end if;
 727
 728       T.Common.Current_Priority := Prio;
 729    end Set_Priority;
 730
 731    ------------------
 732    -- Get_Priority --
 733    ------------------
 734
 735    function Get_Priority (T : Task_Id) return System.Any_Priority is
 736    begin
 737       return T.Common.Current_Priority;
 738    end Get_Priority;
 739
 740    ----------------
 741    -- Enter_Task --
 742    ----------------
 743
 744    procedure Enter_Task (Self_ID : Task_Id) is
 745    begin
 746       Self_ID.Common.LL.Thread := pthread_self;
 747       Self_ID.Common.LL.LWP := lwp_self;
 748
 749       Specific.Set (Self_ID);
 750
 751       Lock_RTS;
 752
 753       for J in Known_Tasks'Range loop
 754          if Known_Tasks (J) = null then
 755             Known_Tasks (J) := Self_ID;
 756             Self_ID.Known_Tasks_Index := J;
 757             exit;
 758          end if;
 759       end loop;
 760
 761       Unlock_RTS;
 762    end Enter_Task;
 763
 764    --------------
 765    -- New_ATCB --
 766    --------------
 767
 768    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 769    begin
 770       return new Ada_Task_Control_Block (Entry_Num);
 771    end New_ATCB;
 772
 773    -------------------
 774    -- Is_Valid_Task --
 775    -------------------
 776
 777    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 778
 779    -----------------------------
 780    -- Register_Foreign_Thread --
 781    -----------------------------
 782
 783    function Register_Foreign_Thread return Task_Id is
 784    begin
 785       if Is_Valid_Task then
 786          return Self;
 787       else
 788          return Register_Foreign_Thread (pthread_self);
 789       end if;
 790    end Register_Foreign_Thread;
 791
 792    --------------------
 793    -- Initialize_TCB --
 794    --------------------
 795
 796    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 797       Mutex_Attr : aliased pthread_mutexattr_t;
 798       Result     : Interfaces.C.int;
 799       Cond_Attr  : aliased pthread_condattr_t;
 800
 801    begin
 802       --  Give the task a unique serial number
 803
 804       Self_ID.Serial_Number := Next_Serial_Number;
 805       Next_Serial_Number := Next_Serial_Number + 1;
 806       pragma Assert (Next_Serial_Number /= 0);
 807
 808       if not Single_Lock then
 809          Result := pthread_mutexattr_init (Mutex_Attr'Access);
 810          pragma Assert (Result = 0 or else Result = ENOMEM);
 811
 812          if Result = 0 then
 813             Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
 814               Mutex_Attr'Access);
 815             pragma Assert (Result = 0 or else Result = ENOMEM);
 816          end if;
 817
 818          if Result /= 0 then
 819             Succeeded := False;
 820             return;
 821          end if;
 822
 823          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 824          pragma Assert (Result = 0);
 825       end if;
 826
 827       Result := pthread_condattr_init (Cond_Attr'Access);
 828       pragma Assert (Result = 0 or else Result = ENOMEM);
 829
 830       if Result = 0 then
 831          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 832            Cond_Attr'Access);
 833          pragma Assert (Result = 0 or else Result = ENOMEM);
 834       end if;
 835
 836       if Result = 0 then
 837          Succeeded := True;
 838       else
 839          if not Single_Lock then
 840             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 841             pragma Assert (Result = 0);
 842          end if;
 843
 844          Succeeded := False;
 845       end if;
 846
 847       Result := pthread_condattr_destroy (Cond_Attr'Access);
 848       pragma Assert (Result = 0);
 849    end Initialize_TCB;
 850
 851    -----------------
 852    -- Create_Task --
 853    -----------------
 854
 855    procedure Create_Task
 856      (T          : Task_Id;
 857       Wrapper    : System.Address;
 858       Stack_Size : System.Parameters.Size_Type;
 859       Priority   : System.Any_Priority;
 860       Succeeded  : out Boolean)
 861    is
 862       Attributes          : aliased pthread_attr_t;
 863       Adjusted_Stack_Size : Interfaces.C.size_t;
 864       Result              : Interfaces.C.int;
 865
 866       use System.Task_Info;
 867
 868    begin
 869       Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 870
 871       if Stack_Base_Available then
 872
 873          --  If Stack Checking is supported then allocate 2 additional pages:
 874          --
 875          --  In the worst case, stack is allocated at something like
 876          --  N * Get_Page_Size - epsilon, we need to add the size for 2 pages
 877          --  to be sure the effective stack size is greater than what
 878          --  has been asked.
 879
 880          Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size;
 881       end if;
 882
 883       Result := pthread_attr_init (Attributes'Access);
 884       pragma Assert (Result = 0 or else Result = ENOMEM);
 885
 886       if Result /= 0 then
 887          Succeeded := False;
 888          return;
 889       end if;
 890
 891       Result := pthread_attr_setdetachstate
 892         (Attributes'Access, PTHREAD_CREATE_DETACHED);
 893       pragma Assert (Result = 0);
 894
 895       Result := pthread_attr_setstacksize
 896         (Attributes'Access, Adjusted_Stack_Size);
 897       pragma Assert (Result = 0);
 898
 899       if T.Common.Task_Info /= Default_Scope then
 900
 901          --  We are assuming that Scope_Type has the same values than the
 902          --  corresponding C macros
 903
 904          Result := pthread_attr_setscope
 905            (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info));
 906          pragma Assert (Result = 0);
 907       end if;
 908
 909       --  Since the initial signal mask of a thread is inherited from the
 910       --  creator, and the Environment task has all its signals masked, we
 911       --  do not need to manipulate caller's signal mask at this point.
 912       --  All tasks in RTS will have All_Tasks_Mask initially.
 913
 914       Result := pthread_create
 915         (T.Common.LL.Thread'Access,
 916          Attributes'Access,
 917          Thread_Body_Access (Wrapper),
 918          To_Address (T));
 919       pragma Assert (Result = 0 or else Result = EAGAIN);
 920
 921       Succeeded := Result = 0;
 922
 923       Result := pthread_attr_destroy (Attributes'Access);
 924       pragma Assert (Result = 0);
 925
 926       Set_Priority (T, Priority);
 927    end Create_Task;
 928
 929    ------------------
 930    -- Finalize_TCB --
 931    ------------------
 932
 933    procedure Finalize_TCB (T : Task_Id) is
 934       Result : Interfaces.C.int;
 935       Tmp    : Task_Id := T;
 936       Is_Self : constant Boolean := T = Self;
 937
 938       procedure Free is new
 939         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 940
 941    begin
 942       if not Single_Lock then
 943          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 944          pragma Assert (Result = 0);
 945       end if;
 946
 947       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 948       pragma Assert (Result = 0);
 949
 950       if T.Known_Tasks_Index /= -1 then
 951          Known_Tasks (T.Known_Tasks_Index) := null;
 952       end if;
 953
 954       Free (Tmp);
 955
 956       if Is_Self then
 957          Result := st_setspecific (ATCB_Key, System.Null_Address);
 958          pragma Assert (Result = 0);
 959       end if;
 960
 961    end Finalize_TCB;
 962
 963    ---------------
 964    -- Exit_Task --
 965    ---------------
 966
 967    procedure Exit_Task is
 968    begin
 969       Specific.Set (null);
 970    end Exit_Task;
 971
 972    ----------------
 973    -- Abort_Task --
 974    ----------------
 975
 976    procedure Abort_Task (T : Task_Id) is
 977       Result : Interfaces.C.int;
 978    begin
 979       Result := pthread_kill (T.Common.LL.Thread,
 980          Signal (System.Interrupt_Management.Abort_Task_Interrupt));
 981       pragma Assert (Result = 0);
 982    end Abort_Task;
 983
 984    ----------------
 985    -- Initialize --
 986    ----------------
 987
 988    procedure Initialize (S : in out Suspension_Object) is
 989       Mutex_Attr : aliased pthread_mutexattr_t;
 990       Cond_Attr  : aliased pthread_condattr_t;
 991       Result     : Interfaces.C.int;
 992
 993    begin
 994       --  Initialize internal state. It is always initialized to False (ARM
 995       --  D.10 par. 6).
 996
 997       S.State := False;
 998       S.Waiting := False;
 999
1000       --  Initialize internal mutex
1001
1002       Result := pthread_mutexattr_init (Mutex_Attr'Access);
1003       pragma Assert (Result = 0 or else Result = ENOMEM);
1004
1005       if Result = ENOMEM then
1006          raise Storage_Error;
1007       end if;
1008
1009       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
1010       pragma Assert (Result = 0 or else Result = ENOMEM);
1011
1012       if Result = ENOMEM then
1013          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1014          pragma Assert (Result = 0);
1015
1016          raise Storage_Error;
1017       end if;
1018
1019       Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
1020       pragma Assert (Result = 0);
1021
1022       --  Initialize internal condition variable
1023
1024       Result := pthread_condattr_init (Cond_Attr'Access);
1025       pragma Assert (Result = 0 or else Result = ENOMEM);
1026
1027       if Result /= 0 then
1028          Result := pthread_mutex_destroy (S.L'Access);
1029          pragma Assert (Result = 0);
1030
1031          if Result = ENOMEM then
1032             raise Storage_Error;
1033          end if;
1034       end if;
1035
1036       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1037       pragma Assert (Result = 0 or else Result = ENOMEM);
1038
1039       if Result /= 0 then
1040          Result := pthread_mutex_destroy (S.L'Access);
1041          pragma Assert (Result = 0);
1042
1043          if Result = ENOMEM then
1044             Result := pthread_condattr_destroy (Cond_Attr'Access);
1045             pragma Assert (Result = 0);
1046
1047             raise Storage_Error;
1048          end if;
1049       end if;
1050
1051       Result := pthread_condattr_destroy (Cond_Attr'Access);
1052       pragma Assert (Result = 0);
1053    end Initialize;
1054
1055    --------------
1056    -- Finalize --
1057    --------------
1058
1059    procedure Finalize (S : in out Suspension_Object) is
1060       Result  : Interfaces.C.int;
1061    begin
1062       --  Destroy internal mutex
1063
1064       Result := pthread_mutex_destroy (S.L'Access);
1065       pragma Assert (Result = 0);
1066
1067       --  Destroy internal condition variable
1068
1069       Result := pthread_cond_destroy (S.CV'Access);
1070       pragma Assert (Result = 0);
1071    end Finalize;
1072
1073    -------------------
1074    -- Current_State --
1075    -------------------
1076
1077    function Current_State (S : Suspension_Object) return Boolean is
1078    begin
1079       --  We do not want to use lock on this read operation. State is marked
1080       --  as Atomic so that we ensure that the value retrieved is correct.
1081
1082       return S.State;
1083    end Current_State;
1084
1085    ---------------
1086    -- Set_False --
1087    ---------------
1088
1089    procedure Set_False (S : in out Suspension_Object) is
1090       Result  : Interfaces.C.int;
1091    begin
1092       Result := pthread_mutex_lock (S.L'Access);
1093       pragma Assert (Result = 0);
1094
1095       S.State := False;
1096
1097       Result := pthread_mutex_unlock (S.L'Access);
1098       pragma Assert (Result = 0);
1099    end Set_False;
1100
1101    --------------
1102    -- Set_True --
1103    --------------
1104
1105    procedure Set_True (S : in out Suspension_Object) is
1106       Result : Interfaces.C.int;
1107    begin
1108       Result := pthread_mutex_lock (S.L'Access);
1109       pragma Assert (Result = 0);
1110
1111       --  If there is already a task waiting on this suspension object then
1112       --  we resume it, leaving the state of the suspension object to False,
1113       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1114       --  the state to True.
1115
1116       if S.Waiting then
1117          S.Waiting := False;
1118          S.State := False;
1119
1120          Result := pthread_cond_signal (S.CV'Access);
1121          pragma Assert (Result = 0);
1122       else
1123          S.State := True;
1124       end if;
1125
1126       Result := pthread_mutex_unlock (S.L'Access);
1127       pragma Assert (Result = 0);
1128    end Set_True;
1129
1130    ------------------------
1131    -- Suspend_Until_True --
1132    ------------------------
1133
1134    procedure Suspend_Until_True (S : in out Suspension_Object) is
1135       Result : Interfaces.C.int;
1136    begin
1137       Result := pthread_mutex_lock (S.L'Access);
1138       pragma Assert (Result = 0);
1139
1140       if S.Waiting then
1141          --  Program_Error must be raised upon calling Suspend_Until_True
1142          --  if another task is already waiting on that suspension object
1143          --  (ARM D.10 par. 10).
1144
1145          Result := pthread_mutex_unlock (S.L'Access);
1146          pragma Assert (Result = 0);
1147
1148          raise Program_Error;
1149       else
1150          --  Suspend the task if the state is False. Otherwise, the task
1151          --  continues its execution, and the state of the suspension object
1152          --  is set to False (ARM D.10 par. 9).
1153
1154          if S.State then
1155             S.State := False;
1156          else
1157             S.Waiting := True;
1158             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1159          end if;
1160       end if;
1161
1162       Result := pthread_mutex_unlock (S.L'Access);
1163       pragma Assert (Result = 0);
1164    end Suspend_Until_True;
1165
1166    ----------------
1167    -- Check_Exit --
1168    ----------------
1169
1170    --  Dummy versions
1171
1172    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1173       pragma Unreferenced (Self_ID);
1174    begin
1175       return True;
1176    end Check_Exit;
1177
1178    --------------------
1179    -- Check_No_Locks --
1180    --------------------
1181
1182    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1183       pragma Unreferenced (Self_ID);
1184    begin
1185       return True;
1186    end Check_No_Locks;
1187
1188    ----------------------
1189    -- Environment_Task --
1190    ----------------------
1191
1192    function Environment_Task return Task_Id is
1193    begin
1194       return Environment_Task_Id;
1195    end Environment_Task;
1196
1197    --------------
1198    -- Lock_RTS --
1199    --------------
1200
1201    procedure Lock_RTS is
1202    begin
1203       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1204    end Lock_RTS;
1205
1206    ----------------
1207    -- Unlock_RTS --
1208    ----------------
1209
1210    procedure Unlock_RTS is
1211    begin
1212       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1213    end Unlock_RTS;
1214
1215    ------------------
1216    -- Suspend_Task --
1217    ------------------
1218
1219    function Suspend_Task
1220      (T           : ST.Task_Id;
1221       Thread_Self : Thread_Id) return Boolean
1222    is
1223       pragma Unreferenced (T);
1224       pragma Unreferenced (Thread_Self);
1225    begin
1226       return False;
1227    end Suspend_Task;
1228
1229    -----------------
1230    -- Resume_Task --
1231    -----------------
1232
1233    function Resume_Task
1234      (T           : ST.Task_Id;
1235       Thread_Self : Thread_Id) return Boolean
1236    is
1237       pragma Unreferenced (T);
1238       pragma Unreferenced (Thread_Self);
1239    begin
1240       return False;
1241    end Resume_Task;
1242
1243    ----------------
1244    -- Initialize --
1245    ----------------
1246
1247    procedure Initialize (Environment_Task : Task_Id) is
1248       act     : aliased struct_sigaction;
1249       old_act : aliased struct_sigaction;
1250       Tmp_Set : aliased sigset_t;
1251       Result  : Interfaces.C.int;
1252
1253       function State
1254         (Int  : System.Interrupt_Management.Interrupt_ID) return Character;
1255       pragma Import (C, State, "__gnat_get_interrupt_state");
1256       --  Get interrupt state.  Defined in a-init.c
1257       --  The input argument is the interrupt number,
1258       --  and the result is one of the following:
1259
1260       Default : constant Character := 's';
1261       --    'n'   this interrupt not set by any Interrupt_State pragma
1262       --    'u'   Interrupt_State pragma set state to User
1263       --    'r'   Interrupt_State pragma set state to Runtime
1264       --    's'   Interrupt_State pragma set state to System (use "default"
1265       --           system handler)
1266
1267    begin
1268       Environment_Task_Id := Environment_Task;
1269
1270       Interrupt_Management.Initialize;
1271
1272       --  Prepare the set of signals that should unblocked in all tasks
1273
1274       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1275       pragma Assert (Result = 0);
1276
1277       for J in Interrupt_Management.Interrupt_ID loop
1278          if System.Interrupt_Management.Keep_Unmasked (J) then
1279             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1280             pragma Assert (Result = 0);
1281          end if;
1282       end loop;
1283
1284       --  Initialize the lock used to synchronize chain of all ATCBs
1285
1286       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1287
1288       Specific.Initialize (Environment_Task);
1289
1290       Enter_Task (Environment_Task);
1291
1292       --  Install the abort-signal handler
1293
1294       if State (System.Interrupt_Management.Abort_Task_Interrupt)
1295         /= Default
1296       then
1297          act.sa_flags := 0;
1298          act.sa_handler := Abort_Handler'Address;
1299
1300          Result := sigemptyset (Tmp_Set'Access);
1301          pragma Assert (Result = 0);
1302          act.sa_mask := Tmp_Set;
1303
1304          Result :=
1305            sigaction
1306            (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
1307             act'Unchecked_Access,
1308             old_act'Unchecked_Access);
1309
1310          pragma Assert (Result = 0);
1311       end if;
1312    end Initialize;
1313
1314 end System.Task_Primitives.Operations;