gcc/ada/s-taprop-linux.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-2007, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  This is a GNU/Linux (GNU/LinuxThreads) version of this package
  35
  36 --  This package contains all the GNULL primitives that interface directly
  37 --  with the underlying OS.
  38
  39 pragma Polling (Off);
  40 --  Turn off polling, we do not want ATC polling to take place during
  41 --  tasking operations. It causes infinite loops and other problems.
  42
  43 with Interfaces.C;
  44 --  used for int
  45 --           size_t
  46
  47 with System.Task_Info;
  48 --  used for Unspecified_Task_Info
  49
  50 with System.Tasking.Debug;
  51 --  used for Known_Tasks
  52
  53 with System.Interrupt_Management;
  54 --  used for Keep_Unmasked
  55 --           Abort_Task_Interrupt
  56 --           Interrupt_ID
  57
  58 with System.OS_Primitives;
  59 --  used for Delay_Modes
  60
  61 with System.Soft_Links;
  62 --  used for Abort_Defer/Undefer
  63
  64 --  We use System.Soft_Links instead of System.Tasking.Initialization
  65 --  because the later is a higher level package that we shouldn't depend on.
  66 --  For example when using the restricted run time, it is replaced by
  67 --  System.Tasking.Restricted.Stages.
  68
  69 with System.Storage_Elements;
  70 with System.Stack_Checking.Operations;
  71 --  Used for Invalidate_Stack_Cache and Notify_Stack_Attributes;
  72
  73 with Ada.Exceptions;
  74 --  used for Raise_Exception
  75 --           Raise_From_Signal_Handler
  76 --           Exception_Id
  77
  78 with Ada.Unchecked_Conversion;
  79 with Ada.Unchecked_Deallocation;
  80
  81 package body System.Task_Primitives.Operations is
  82
  83    package SSL renames System.Soft_Links;
  84    package SC renames System.Stack_Checking.Operations;
  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    use System.Storage_Elements;
  93    use System.Task_Info;
  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    Unblocked_Signal_Mask : aliased sigset_t;
 114    --  The set of signals that should be unblocked in all tasks
 115
 116    --  The followings are internal configuration constants needed
 117
 118    Next_Serial_Number : Task_Serial_Number := 100;
 119    --  We start at 100 (reserve some special values for using in error checks)
 120
 121    Time_Slice_Val : Integer;
 122    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 123
 124    Dispatching_Policy : Character;
 125    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 126
 127    --  The following are effectively constants, but they need to be initialized
 128    --  by calling a pthread_ function.
 129
 130    Mutex_Attr   : aliased pthread_mutexattr_t;
 131    Cond_Attr    : aliased pthread_condattr_t;
 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 executing thread have a TCB?
 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    subtype unsigned_long is Interfaces.C.unsigned_long;
 178
 179    procedure Abort_Handler (signo : Signal);
 180
 181    function To_pthread_t is new Ada.Unchecked_Conversion
 182      (unsigned_long, System.OS_Interface.pthread_t);
 183
 184    procedure Get_Stack_Attributes
 185      (T    : Task_Id;
 186       ISP  : out System.Address;
 187       Size : out Storage_Offset);
 188    --  Fill ISP and Size with the Initial Stack Pointer value and the
 189    --  thread stack size for task T.
 190
 191    -------------------
 192    -- Abort_Handler --
 193    -------------------
 194
 195    procedure Abort_Handler (signo : Signal) is
 196       pragma Unreferenced (signo);
 197
 198       Self_Id : constant Task_Id := Self;
 199       Result  : Interfaces.C.int;
 200       Old_Set : aliased sigset_t;
 201
 202    begin
 203       if ZCX_By_Default and then GCC_ZCX_Support then
 204          return;
 205       end if;
 206
 207       if Self_Id.Deferral_Level = 0
 208         and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
 209         and then not Self_Id.Aborting
 210       then
 211          Self_Id.Aborting := True;
 212
 213          --  Make sure signals used for RTS internal purpose are unmasked
 214
 215          Result :=
 216            pthread_sigmask
 217              (SIG_UNBLOCK,
 218               Unblocked_Signal_Mask'Access,
 219               Old_Set'Access);
 220          pragma Assert (Result = 0);
 221
 222          raise Standard'Abort_Signal;
 223       end if;
 224    end Abort_Handler;
 225
 226    --------------
 227    -- Lock_RTS --
 228    --------------
 229
 230    procedure Lock_RTS is
 231    begin
 232       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 233    end Lock_RTS;
 234
 235    ----------------
 236    -- Unlock_RTS --
 237    ----------------
 238
 239    procedure Unlock_RTS is
 240    begin
 241       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 242    end Unlock_RTS;
 243
 244    -----------------
 245    -- Stack_Guard --
 246    -----------------
 247
 248    --  The underlying thread system extends the memory (up to 2MB) when needed
 249
 250    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 251       pragma Unreferenced (T);
 252       pragma Unreferenced (On);
 253    begin
 254       null;
 255    end Stack_Guard;
 256
 257    --------------------
 258    -- Get_Thread_Id  --
 259    --------------------
 260
 261    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 262    begin
 263       return T.Common.LL.Thread;
 264    end Get_Thread_Id;
 265
 266    ----------
 267    -- Self --
 268    ----------
 269
 270    function Self return Task_Id renames Specific.Self;
 271
 272    ---------------------
 273    -- Initialize_Lock --
 274    ---------------------
 275
 276    --  Note: mutexes and cond_variables needed per-task basis are
 277    --  initialized in Initialize_TCB and the Storage_Error is
 278    --  handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 279    --  used in RTS is initialized before any status change of RTS.
 280    --  Therefore rasing Storage_Error in the following routines
 281    --  should be able to be handled safely.
 282
 283    procedure Initialize_Lock
 284      (Prio : System.Any_Priority;
 285       L    : not null access Lock)
 286    is
 287       pragma Unreferenced (Prio);
 288
 289       Result : Interfaces.C.int;
 290
 291    begin
 292       Result := pthread_mutex_init (L, Mutex_Attr'Access);
 293
 294       pragma Assert (Result = 0 or else Result = ENOMEM);
 295
 296       if Result = ENOMEM then
 297          Ada.Exceptions.Raise_Exception (Storage_Error'Identity,
 298            "Failed to allocate a lock");
 299       end if;
 300    end Initialize_Lock;
 301
 302    procedure Initialize_Lock
 303      (L     : not null access RTS_Lock;
 304       Level : Lock_Level)
 305    is
 306       pragma Unreferenced (Level);
 307
 308       Result : Interfaces.C.int;
 309
 310    begin
 311       Result := pthread_mutex_init (L, Mutex_Attr'Access);
 312
 313       pragma Assert (Result = 0 or else Result = ENOMEM);
 314
 315       if Result = ENOMEM then
 316          raise Storage_Error;
 317       end if;
 318    end Initialize_Lock;
 319
 320    -------------------
 321    -- Finalize_Lock --
 322    -------------------
 323
 324    procedure Finalize_Lock (L : not null access Lock) is
 325       Result : Interfaces.C.int;
 326    begin
 327       Result := pthread_mutex_destroy (L);
 328       pragma Assert (Result = 0);
 329    end Finalize_Lock;
 330
 331    procedure Finalize_Lock (L : not null access RTS_Lock) is
 332       Result : Interfaces.C.int;
 333    begin
 334       Result := pthread_mutex_destroy (L);
 335       pragma Assert (Result = 0);
 336    end Finalize_Lock;
 337
 338    ----------------
 339    -- Write_Lock --
 340    ----------------
 341
 342    procedure Write_Lock
 343      (L                 : not null access Lock;
 344       Ceiling_Violation : out Boolean)
 345    is
 346       Result : Interfaces.C.int;
 347    begin
 348       Result := pthread_mutex_lock (L);
 349       Ceiling_Violation := Result = EINVAL;
 350
 351       --  Assume the cause of EINVAL is a priority ceiling violation
 352
 353       pragma Assert (Result = 0 or else Result = EINVAL);
 354    end Write_Lock;
 355
 356    procedure Write_Lock
 357      (L           : not null access RTS_Lock;
 358       Global_Lock : Boolean := False)
 359    is
 360       Result : Interfaces.C.int;
 361    begin
 362       if not Single_Lock or else Global_Lock then
 363          Result := pthread_mutex_lock (L);
 364          pragma Assert (Result = 0);
 365       end if;
 366    end Write_Lock;
 367
 368    procedure Write_Lock (T : Task_Id) is
 369       Result : Interfaces.C.int;
 370    begin
 371       if not Single_Lock then
 372          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 373          pragma Assert (Result = 0);
 374       end if;
 375    end Write_Lock;
 376
 377    ---------------
 378    -- Read_Lock --
 379    ---------------
 380
 381    procedure Read_Lock
 382      (L                 : not null access Lock;
 383       Ceiling_Violation : out Boolean)
 384    is
 385    begin
 386       Write_Lock (L, Ceiling_Violation);
 387    end Read_Lock;
 388
 389    ------------
 390    -- Unlock --
 391    ------------
 392
 393    procedure Unlock (L : not null access Lock) is
 394       Result : Interfaces.C.int;
 395    begin
 396       Result := pthread_mutex_unlock (L);
 397       pragma Assert (Result = 0);
 398    end Unlock;
 399
 400    procedure Unlock
 401      (L           : not null access RTS_Lock;
 402       Global_Lock : Boolean := False)
 403    is
 404       Result : Interfaces.C.int;
 405    begin
 406       if not Single_Lock or else Global_Lock then
 407          Result := pthread_mutex_unlock (L);
 408          pragma Assert (Result = 0);
 409       end if;
 410    end Unlock;
 411
 412    procedure Unlock (T : Task_Id) is
 413       Result : Interfaces.C.int;
 414    begin
 415       if not Single_Lock then
 416          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 417          pragma Assert (Result = 0);
 418       end if;
 419    end Unlock;
 420
 421    -----------------
 422    -- Set_Ceiling --
 423    -----------------
 424
 425    --  Dynamic priority ceilings are not supported by the underlying system
 426
 427    procedure Set_Ceiling
 428      (L    : not null access Lock;
 429       Prio : System.Any_Priority)
 430    is
 431       pragma Unreferenced (L, Prio);
 432    begin
 433       null;
 434    end Set_Ceiling;
 435
 436    -----------
 437    -- Sleep --
 438    -----------
 439
 440    procedure Sleep
 441      (Self_ID  : Task_Id;
 442       Reason   : System.Tasking.Task_States)
 443    is
 444       pragma Unreferenced (Reason);
 445
 446       Result : Interfaces.C.int;
 447
 448    begin
 449       pragma Assert (Self_ID = Self);
 450
 451       if Single_Lock then
 452          Result :=
 453            pthread_cond_wait
 454              (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 455       else
 456          Result :=
 457            pthread_cond_wait
 458              (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 459       end if;
 460
 461       --  EINTR is not considered a failure
 462
 463       pragma Assert (Result = 0 or else Result = EINTR);
 464    end Sleep;
 465
 466    -----------------
 467    -- Timed_Sleep --
 468    -----------------
 469
 470    --  This is for use within the run-time system, so abort is
 471    --  assumed to be already deferred, and the caller should be
 472    --  holding its own ATCB lock.
 473
 474    procedure Timed_Sleep
 475      (Self_ID  : Task_Id;
 476       Time     : Duration;
 477       Mode     : ST.Delay_Modes;
 478       Reason   : System.Tasking.Task_States;
 479       Timedout : out Boolean;
 480       Yielded  : out Boolean)
 481    is
 482       pragma Unreferenced (Reason);
 483
 484       Base_Time  : constant Duration := Monotonic_Clock;
 485       Check_Time : Duration := Base_Time;
 486       Abs_Time   : Duration;
 487       Request    : aliased timespec;
 488       Result     : Interfaces.C.int;
 489
 490    begin
 491       Timedout := True;
 492       Yielded := False;
 493
 494       if Mode = Relative then
 495          Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
 496       else
 497          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 498       end if;
 499
 500       if Abs_Time > Check_Time then
 501          Request := To_Timespec (Abs_Time);
 502
 503          loop
 504             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 505
 506             if Single_Lock then
 507                Result :=
 508                  pthread_cond_timedwait
 509                    (Self_ID.Common.LL.CV'Access,
 510                     Single_RTS_Lock'Access,
 511                     Request'Access);
 512
 513             else
 514                Result :=
 515                  pthread_cond_timedwait
 516                    (Self_ID.Common.LL.CV'Access,
 517                     Self_ID.Common.LL.L'Access,
 518                     Request'Access);
 519             end if;
 520
 521             Check_Time := Monotonic_Clock;
 522             exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
 523
 524             if Result = 0 or else Result = EINTR then
 525
 526                --  Somebody may have called Wakeup for us
 527
 528                Timedout := False;
 529                exit;
 530             end if;
 531
 532             pragma Assert (Result = ETIMEDOUT);
 533          end loop;
 534       end if;
 535    end Timed_Sleep;
 536
 537    -----------------
 538    -- Timed_Delay --
 539    -----------------
 540
 541    --  This is for use in implementing delay statements, so we assume the
 542    --  caller is abort-deferred but is holding no locks.
 543
 544    procedure Timed_Delay
 545      (Self_ID : Task_Id;
 546       Time    : Duration;
 547       Mode    : ST.Delay_Modes)
 548    is
 549       Base_Time  : constant Duration := Monotonic_Clock;
 550       Check_Time : Duration := Base_Time;
 551       Abs_Time   : Duration;
 552       Request    : aliased timespec;
 553
 554       Result : Interfaces.C.int;
 555       pragma Warnings (Off, Result);
 556
 557    begin
 558       if Single_Lock then
 559          Lock_RTS;
 560       end if;
 561
 562       Write_Lock (Self_ID);
 563
 564       if Mode = Relative then
 565          Abs_Time := Time + Check_Time;
 566       else
 567          Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
 568       end if;
 569
 570       if Abs_Time > Check_Time then
 571          Request := To_Timespec (Abs_Time);
 572          Self_ID.Common.State := Delay_Sleep;
 573
 574          loop
 575             exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
 576
 577             if Single_Lock then
 578                Result := pthread_cond_timedwait
 579                            (Self_ID.Common.LL.CV'Access,
 580                             Single_RTS_Lock'Access,
 581                             Request'Access);
 582             else
 583                Result := pthread_cond_timedwait
 584                            (Self_ID.Common.LL.CV'Access,
 585                             Self_ID.Common.LL.L'Access,
 586                             Request'Access);
 587             end if;
 588
 589             Check_Time := Monotonic_Clock;
 590             exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
 591
 592             pragma Assert (Result = 0 or else
 593               Result = ETIMEDOUT or else
 594               Result = EINTR);
 595          end loop;
 596
 597          Self_ID.Common.State := Runnable;
 598       end if;
 599
 600       Unlock (Self_ID);
 601
 602       if Single_Lock then
 603          Unlock_RTS;
 604       end if;
 605
 606       Result := sched_yield;
 607    end Timed_Delay;
 608
 609    ---------------------
 610    -- Monotonic_Clock --
 611    ---------------------
 612
 613    function Monotonic_Clock return Duration is
 614       TV     : aliased struct_timeval;
 615       Result : Interfaces.C.int;
 616    begin
 617       Result := gettimeofday (TV'Access, System.Null_Address);
 618       pragma Assert (Result = 0);
 619       return To_Duration (TV);
 620    end Monotonic_Clock;
 621
 622    -------------------
 623    -- RT_Resolution --
 624    -------------------
 625
 626    function RT_Resolution return Duration is
 627    begin
 628       return 10#1.0#E-6;
 629    end RT_Resolution;
 630
 631    ------------
 632    -- Wakeup --
 633    ------------
 634
 635    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 636       pragma Unreferenced (Reason);
 637       Result : Interfaces.C.int;
 638    begin
 639       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 640       pragma Assert (Result = 0);
 641    end Wakeup;
 642
 643    -----------
 644    -- Yield --
 645    -----------
 646
 647    procedure Yield (Do_Yield : Boolean := True) is
 648       Result : Interfaces.C.int;
 649       pragma Unreferenced (Result);
 650    begin
 651       if Do_Yield then
 652          Result := sched_yield;
 653       end if;
 654    end Yield;
 655
 656    ------------------
 657    -- Set_Priority --
 658    ------------------
 659
 660    procedure Set_Priority
 661      (T                   : Task_Id;
 662       Prio                : System.Any_Priority;
 663       Loss_Of_Inheritance : Boolean := False)
 664    is
 665       pragma Unreferenced (Loss_Of_Inheritance);
 666
 667       Result : Interfaces.C.int;
 668       Param  : aliased struct_sched_param;
 669
 670       function Get_Policy (Prio : System.Any_Priority) return Character;
 671       pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
 672       --  Get priority specific dispatching policy
 673
 674       Priority_Specific_Policy : constant Character := Get_Policy (Prio);
 675       --  Upper case first character of the policy name corresponding to the
 676       --  task as set by a Priority_Specific_Dispatching pragma.
 677
 678    begin
 679       T.Common.Current_Priority := Prio;
 680
 681       --  Priorities are 1 .. 99 on GNU/Linux, so we map 0 .. 98 to 1 .. 99
 682
 683       Param.sched_priority := Interfaces.C.int (Prio) + 1;
 684
 685       if Dispatching_Policy = 'R'
 686         or else Priority_Specific_Policy = 'R'
 687         or else Time_Slice_Val > 0
 688       then
 689          Result :=
 690            pthread_setschedparam
 691              (T.Common.LL.Thread, SCHED_RR, Param'Access);
 692
 693       elsif Dispatching_Policy = 'F'
 694         or else Priority_Specific_Policy = 'F'
 695         or else Time_Slice_Val = 0
 696       then
 697          Result :=
 698            pthread_setschedparam
 699              (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 700
 701       else
 702          Param.sched_priority := 0;
 703          Result :=
 704            pthread_setschedparam
 705              (T.Common.LL.Thread,
 706               SCHED_OTHER, Param'Access);
 707       end if;
 708
 709       pragma Assert (Result = 0 or else Result = EPERM);
 710    end Set_Priority;
 711
 712    ------------------
 713    -- Get_Priority --
 714    ------------------
 715
 716    function Get_Priority (T : Task_Id) return System.Any_Priority is
 717    begin
 718       return T.Common.Current_Priority;
 719    end Get_Priority;
 720
 721    --------------------------
 722    -- Get_Stack_Attributes --
 723    --------------------------
 724
 725    procedure Get_Stack_Attributes
 726      (T    : Task_Id;
 727       ISP  : out System.Address;
 728       Size : out Storage_Offset)
 729    is
 730       function pthread_getattr_np
 731         (thread : pthread_t;
 732          attr   : System.Address) return Interfaces.C.int;
 733       pragma Import (C, pthread_getattr_np, "pthread_getattr_np");
 734
 735       function pthread_attr_getstack
 736         (attr : System.Address;
 737          base : System.Address;
 738          size : System.Address) return Interfaces.C.int;
 739       pragma Import (C, pthread_attr_getstack, "pthread_attr_getstack");
 740
 741       Result : Interfaces.C.int;
 742
 743       Attributes : aliased pthread_attr_t;
 744       Stack_Base : aliased System.Address;
 745       Stack_Size : aliased Storage_Offset;
 746
 747    begin
 748       Result :=
 749         pthread_getattr_np
 750           (T.Common.LL.Thread, Attributes'Address);
 751       pragma Assert (Result = 0);
 752
 753       Result :=
 754         pthread_attr_getstack
 755           (Attributes'Address, Stack_Base'Address, Stack_Size'Address);
 756       pragma Assert (Result = 0);
 757
 758       Result := pthread_attr_destroy (Attributes'Access);
 759       pragma Assert (Result = 0);
 760
 761       ISP  := Stack_Base + Stack_Size;
 762       Size := Stack_Size;
 763    end Get_Stack_Attributes;
 764
 765    ----------------
 766    -- Enter_Task --
 767    ----------------
 768
 769    procedure Enter_Task (Self_ID : Task_Id) is
 770    begin
 771       if Self_ID.Common.Task_Info /= null
 772         and then
 773           Self_ID.Common.Task_Info.CPU_Affinity = No_CPU
 774       then
 775          raise Invalid_CPU_Number;
 776       end if;
 777
 778       Self_ID.Common.LL.Thread := pthread_self;
 779
 780       Specific.Set (Self_ID);
 781
 782       Lock_RTS;
 783
 784       for J in Known_Tasks'Range loop
 785          if Known_Tasks (J) = null then
 786             Known_Tasks (J) := Self_ID;
 787             Self_ID.Known_Tasks_Index := J;
 788             exit;
 789          end if;
 790       end loop;
 791
 792       Unlock_RTS;
 793
 794       --  Determine where the task stack starts, how large it is, and let the
 795       --  stack checking engine know about it.
 796
 797       declare
 798          Initial_SP : System.Address;
 799          Stack_Size : Storage_Offset;
 800       begin
 801          Get_Stack_Attributes (Self_ID, Initial_SP, Stack_Size);
 802          System.Stack_Checking.Operations.Notify_Stack_Attributes
 803            (Initial_SP, Stack_Size);
 804       end;
 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       Result : Interfaces.C.int;
 841
 842    begin
 843       --  Give the task a unique serial number
 844
 845       Self_ID.Serial_Number := Next_Serial_Number;
 846       Next_Serial_Number := Next_Serial_Number + 1;
 847       pragma Assert (Next_Serial_Number /= 0);
 848
 849       Self_ID.Common.LL.Thread := To_pthread_t (-1);
 850
 851       if not Single_Lock then
 852          Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
 853            Mutex_Attr'Access);
 854          pragma Assert (Result = 0 or else Result = ENOMEM);
 855
 856          if Result /= 0 then
 857             Succeeded := False;
 858             return;
 859          end if;
 860       end if;
 861
 862       Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 863         Cond_Attr'Access);
 864       pragma Assert (Result = 0 or else Result = ENOMEM);
 865
 866       if Result = 0 then
 867          Succeeded := True;
 868       else
 869          if not Single_Lock then
 870             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 871             pragma Assert (Result = 0);
 872          end if;
 873
 874          Succeeded := False;
 875       end if;
 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       Result     : Interfaces.C.int;
 891
 892    begin
 893       Result := pthread_attr_init (Attributes'Access);
 894       pragma Assert (Result = 0 or else Result = ENOMEM);
 895
 896       if Result /= 0 then
 897          Succeeded := False;
 898          return;
 899       end if;
 900
 901       Result :=
 902         pthread_attr_setstacksize
 903           (Attributes'Access, Interfaces.C.size_t (Stack_Size));
 904       pragma Assert (Result = 0);
 905
 906       Result :=
 907         pthread_attr_setdetachstate
 908           (Attributes'Access, PTHREAD_CREATE_DETACHED);
 909       pragma Assert (Result = 0);
 910
 911       --  Since the initial signal mask of a thread is inherited from the
 912       --  creator, and the Environment task has all its signals masked, we
 913       --  do not need to manipulate caller's signal mask at this point.
 914       --  All tasks in RTS will have All_Tasks_Mask initially.
 915
 916       Result := pthread_create
 917         (T.Common.LL.Thread'Access,
 918          Attributes'Access,
 919          Thread_Body_Access (Wrapper),
 920          To_Address (T));
 921       pragma Assert (Result = 0 or else Result = EAGAIN);
 922
 923       Succeeded := Result = 0;
 924
 925       --  Handle Task_Info
 926
 927       if T.Common.Task_Info /= null then
 928          if T.Common.Task_Info.CPU_Affinity /= Task_Info.Any_CPU then
 929             Result :=
 930               pthread_setaffinity_np
 931                 (T.Common.LL.Thread,
 932                  CPU_SETSIZE / 8,
 933                  T.Common.Task_Info.CPU_Affinity'Access);
 934             pragma Assert (Result = 0);
 935          end if;
 936       end if;
 937
 938       Result := pthread_attr_destroy (Attributes'Access);
 939       pragma Assert (Result = 0);
 940
 941       Set_Priority (T, Priority);
 942    end Create_Task;
 943
 944    ------------------
 945    -- Finalize_TCB --
 946    ------------------
 947
 948    procedure Finalize_TCB (T : Task_Id) is
 949       Result  : Interfaces.C.int;
 950       Tmp     : Task_Id := T;
 951       Is_Self : constant Boolean := T = Self;
 952
 953       procedure Free is new
 954         Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 955
 956    begin
 957       if not Single_Lock then
 958          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 959          pragma Assert (Result = 0);
 960       end if;
 961
 962       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 963       pragma Assert (Result = 0);
 964
 965       if T.Known_Tasks_Index /= -1 then
 966          Known_Tasks (T.Known_Tasks_Index) := null;
 967       end if;
 968       SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access);
 969       Free (Tmp);
 970
 971       if Is_Self then
 972          Specific.Set (null);
 973       end if;
 974    end Finalize_TCB;
 975
 976    ---------------
 977    -- Exit_Task --
 978    ---------------
 979
 980    procedure Exit_Task is
 981    begin
 982       Specific.Set (null);
 983    end Exit_Task;
 984
 985    ----------------
 986    -- Abort_Task --
 987    ----------------
 988
 989    procedure Abort_Task (T : Task_Id) is
 990       Result : Interfaces.C.int;
 991    begin
 992       Result :=
 993         pthread_kill
 994           (T.Common.LL.Thread,
 995            Signal (System.Interrupt_Management.Abort_Task_Interrupt));
 996       pragma Assert (Result = 0);
 997    end Abort_Task;
 998
 999    ----------------
1000    -- Initialize --
1001    ----------------
1002
1003    procedure Initialize (S : in out Suspension_Object) is
1004       Result : Interfaces.C.int;
1005
1006    begin
1007       --  Initialize internal state (always to False (RM D.10(6)))
1008
1009       S.State := False;
1010       S.Waiting := False;
1011
1012       --  Initialize internal mutex
1013
1014       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
1015
1016       pragma Assert (Result = 0 or else Result = ENOMEM);
1017
1018       if Result = ENOMEM then
1019          raise Storage_Error;
1020       end if;
1021
1022       --  Initialize internal condition variable
1023
1024       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
1025
1026       pragma Assert (Result = 0 or else Result = ENOMEM);
1027
1028       if Result /= 0 then
1029          Result := pthread_mutex_destroy (S.L'Access);
1030          pragma Assert (Result = 0);
1031
1032          if Result = ENOMEM then
1033             raise Storage_Error;
1034          end if;
1035       end if;
1036    end Initialize;
1037
1038    --------------
1039    -- Finalize --
1040    --------------
1041
1042    procedure Finalize (S : in out Suspension_Object) is
1043       Result : Interfaces.C.int;
1044
1045    begin
1046       --  Destroy internal mutex
1047
1048       Result := pthread_mutex_destroy (S.L'Access);
1049       pragma Assert (Result = 0);
1050
1051       --  Destroy internal condition variable
1052
1053       Result := pthread_cond_destroy (S.CV'Access);
1054       pragma Assert (Result = 0);
1055    end Finalize;
1056
1057    -------------------
1058    -- Current_State --
1059    -------------------
1060
1061    function Current_State (S : Suspension_Object) return Boolean is
1062    begin
1063       --  We do not want to use lock on this read operation. State is marked
1064       --  as Atomic so that we ensure that the value retrieved is correct.
1065
1066       return S.State;
1067    end Current_State;
1068
1069    ---------------
1070    -- Set_False --
1071    ---------------
1072
1073    procedure Set_False (S : in out Suspension_Object) is
1074       Result : Interfaces.C.int;
1075
1076    begin
1077       SSL.Abort_Defer.all;
1078
1079       Result := pthread_mutex_lock (S.L'Access);
1080       pragma Assert (Result = 0);
1081
1082       S.State := False;
1083
1084       Result := pthread_mutex_unlock (S.L'Access);
1085       pragma Assert (Result = 0);
1086
1087       SSL.Abort_Undefer.all;
1088    end Set_False;
1089
1090    --------------
1091    -- Set_True --
1092    --------------
1093
1094    procedure Set_True (S : in out Suspension_Object) is
1095       Result : Interfaces.C.int;
1096
1097    begin
1098       SSL.Abort_Defer.all;
1099
1100       Result := pthread_mutex_lock (S.L'Access);
1101       pragma Assert (Result = 0);
1102
1103       --  If there is already a task waiting on this suspension object then
1104       --  we resume it, leaving the state of the suspension object to False,
1105       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1106       --  the state to True.
1107
1108       if S.Waiting then
1109          S.Waiting := False;
1110          S.State := False;
1111
1112          Result := pthread_cond_signal (S.CV'Access);
1113          pragma Assert (Result = 0);
1114
1115       else
1116          S.State := True;
1117       end if;
1118
1119       Result := pthread_mutex_unlock (S.L'Access);
1120       pragma Assert (Result = 0);
1121
1122       SSL.Abort_Undefer.all;
1123    end Set_True;
1124
1125    ------------------------
1126    -- Suspend_Until_True --
1127    ------------------------
1128
1129    procedure Suspend_Until_True (S : in out Suspension_Object) is
1130       Result : Interfaces.C.int;
1131
1132    begin
1133       SSL.Abort_Defer.all;
1134
1135       Result := pthread_mutex_lock (S.L'Access);
1136       pragma Assert (Result = 0);
1137
1138       if S.Waiting then
1139
1140          --  Program_Error must be raised upon calling Suspend_Until_True
1141          --  if another task is already waiting on that suspension object
1142          --  (RM D.10(10)).
1143
1144          Result := pthread_mutex_unlock (S.L'Access);
1145          pragma Assert (Result = 0);
1146
1147          SSL.Abort_Undefer.all;
1148
1149          raise Program_Error;
1150       else
1151          --  Suspend the task if the state is False. Otherwise, the task
1152          --  continues its execution, and the state of the suspension object
1153          --  is set to False (ARM D.10 par. 9).
1154
1155          if S.State then
1156             S.State := False;
1157          else
1158             S.Waiting := True;
1159             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1160          end if;
1161
1162          Result := pthread_mutex_unlock (S.L'Access);
1163          pragma Assert (Result = 0);
1164
1165          SSL.Abort_Undefer.all;
1166       end
1167       if;
1168    end Suspend_Until_True;
1169
1170    ----------------
1171    -- Check_Exit --
1172    ----------------
1173
1174    --  Dummy version
1175
1176    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1177       pragma Unreferenced (Self_ID);
1178    begin
1179       return True;
1180    end Check_Exit;
1181
1182    --------------------
1183    -- Check_No_Locks --
1184    --------------------
1185
1186    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1187       pragma Unreferenced (Self_ID);
1188    begin
1189       return True;
1190    end Check_No_Locks;
1191
1192    ----------------------
1193    -- Environment_Task --
1194    ----------------------
1195
1196    function Environment_Task return Task_Id is
1197    begin
1198       return Environment_Task_Id;
1199    end Environment_Task;
1200
1201    ------------------
1202    -- Suspend_Task --
1203    ------------------
1204
1205    function Suspend_Task
1206      (T           : ST.Task_Id;
1207       Thread_Self : Thread_Id) return Boolean
1208    is
1209    begin
1210       if T.Common.LL.Thread /= Thread_Self then
1211          return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0;
1212       else
1213          return True;
1214       end if;
1215    end Suspend_Task;
1216
1217    -----------------
1218    -- Resume_Task --
1219    -----------------
1220
1221    function Resume_Task
1222      (T           : ST.Task_Id;
1223       Thread_Self : Thread_Id) return Boolean
1224    is
1225    begin
1226       if T.Common.LL.Thread /= Thread_Self then
1227          return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0;
1228       else
1229          return True;
1230       end if;
1231    end Resume_Task;
1232
1233    --------------------
1234    -- Stop_All_Tasks --
1235    --------------------
1236
1237    procedure Stop_All_Tasks is
1238    begin
1239       null;
1240    end Stop_All_Tasks;
1241
1242    ---------------
1243    -- Stop_Task --
1244    ---------------
1245
1246    function Stop_Task (T : ST.Task_Id) return Boolean is
1247       pragma Unreferenced (T);
1248    begin
1249       return False;
1250    end Stop_Task;
1251
1252    -------------------
1253    -- Continue_Task --
1254    -------------------
1255
1256    function Continue_Task (T : ST.Task_Id) return Boolean is
1257       pragma Unreferenced (T);
1258    begin
1259       return False;
1260    end Continue_Task;
1261
1262    ----------------
1263    -- Initialize --
1264    ----------------
1265
1266    procedure Initialize (Environment_Task : Task_Id) is
1267       act     : aliased struct_sigaction;
1268       old_act : aliased struct_sigaction;
1269       Tmp_Set : aliased sigset_t;
1270       Result  : Interfaces.C.int;
1271
1272       function State
1273         (Int : System.Interrupt_Management.Interrupt_ID) return Character;
1274       pragma Import (C, State, "__gnat_get_interrupt_state");
1275       --  Get interrupt state.  Defined in a-init.c
1276       --  The input argument is the interrupt number,
1277       --  and the result is one of the following:
1278
1279       Default : constant Character := 's';
1280       --    'n'   this interrupt not set by any Interrupt_State pragma
1281       --    'u'   Interrupt_State pragma set state to User
1282       --    'r'   Interrupt_State pragma set state to Runtime
1283       --    's'   Interrupt_State pragma set state to System (use "default"
1284       --           system handler)
1285
1286    begin
1287       Environment_Task_Id := Environment_Task;
1288
1289       Interrupt_Management.Initialize;
1290
1291       --  Prepare the set of signals that should be unblocked in all tasks
1292
1293       Result := sigemptyset (Unblocked_Signal_Mask'Access);
1294       pragma Assert (Result = 0);
1295
1296       for J in Interrupt_Management.Interrupt_ID loop
1297          if System.Interrupt_Management.Keep_Unmasked (J) then
1298             Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
1299             pragma Assert (Result = 0);
1300          end if;
1301       end loop;
1302
1303       Result := pthread_mutexattr_init (Mutex_Attr'Access);
1304       pragma Assert (Result = 0);
1305
1306       Result := pthread_condattr_init (Cond_Attr'Access);
1307       pragma Assert (Result = 0);
1308
1309       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1310
1311       --  Initialize the global RTS lock
1312
1313       Specific.Initialize (Environment_Task);
1314
1315       Enter_Task (Environment_Task);
1316
1317       --  Install the abort-signal handler
1318
1319       if State
1320           (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
1321       then
1322          act.sa_flags := 0;
1323          act.sa_handler := Abort_Handler'Address;
1324
1325          Result := sigemptyset (Tmp_Set'Access);
1326          pragma Assert (Result = 0);
1327          act.sa_mask := Tmp_Set;
1328
1329          Result :=
1330            sigaction
1331            (Signal (Interrupt_Management.Abort_Task_Interrupt),
1332             act'Unchecked_Access,
1333             old_act'Unchecked_Access);
1334          pragma Assert (Result = 0);
1335       end if;
1336    end Initialize;
1337
1338 end System.Task_Primitives.Operations;