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