gcc/ada/56taprop.adb

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