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