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