gcc/ada/s-taprop-vms.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S    --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2006, 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 OpenVMS/Alpha 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 System.OS_Primitives;
  47 --  used for Delay_Modes
  48
  49 with Interfaces.C;
  50 --  used for int
  51 --           size_t
  52
  53 with System.Soft_Links;
  54 --  used for Get_Exc_Stack_Addr
  55 --           Abort_Defer/Undefer
  56
  57 with Unchecked_Conversion;
  58 with Unchecked_Deallocation;
  59
  60 package body System.Task_Primitives.Operations is
  61
  62    use System.Tasking.Debug;
  63    use System.Tasking;
  64    use Interfaces.C;
  65    use System.OS_Interface;
  66    use System.Parameters;
  67    use System.OS_Primitives;
  68    use type System.OS_Primitives.OS_Time;
  69
  70    package SSL renames System.Soft_Links;
  71
  72    ----------------
  73    -- Local Data --
  74    ----------------
  75
  76    --  The followings are logically constants, but need to be initialized
  77    --  at run time.
  78
  79    Single_RTS_Lock : aliased RTS_Lock;
  80    --  This is a lock to allow only one thread of control in the RTS at
  81    --  a time; it is used to execute in mutual exclusion from all other tasks.
  82    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
  83
  84    ATCB_Key : aliased pthread_key_t;
  85    --  Key used to find the Ada Task_Id associated with a thread
  86
  87    Environment_Task_Id : Task_Id;
  88    --  A variable to hold Task_Id for the environment task.
  89
  90    Time_Slice_Val : Integer;
  91    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
  92
  93    Dispatching_Policy : Character;
  94    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
  95
  96    Foreign_Task_Elaborated : aliased Boolean := True;
  97    --  Used to identified fake tasks (i.e., non-Ada Threads).
  98
  99    --------------------
 100    -- Local Packages --
 101    --------------------
 102
 103    package Specific is
 104
 105       procedure Initialize (Environment_Task : Task_Id);
 106       pragma Inline (Initialize);
 107       --  Initialize various data needed by this package.
 108
 109       function Is_Valid_Task return Boolean;
 110       pragma Inline (Is_Valid_Task);
 111       --  Does executing thread have a TCB?
 112
 113       procedure Set (Self_Id : Task_Id);
 114       pragma Inline (Set);
 115       --  Set the self id for the current task
 116
 117       function Self return Task_Id;
 118       pragma Inline (Self);
 119       --  Return a pointer to the Ada Task Control Block of the calling task
 120
 121    end Specific;
 122
 123    package body Specific is separate;
 124    --  The body of this package is target specific.
 125
 126    ---------------------------------
 127    -- Support for foreign threads --
 128    ---------------------------------
 129
 130    function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id;
 131    --  Allocate and Initialize a new ATCB for the current Thread
 132
 133    function Register_Foreign_Thread
 134      (Thread : Thread_Id) return Task_Id is separate;
 135
 136    -----------------------
 137    -- Local Subprograms --
 138    -----------------------
 139
 140    function To_Task_Id is new Unchecked_Conversion (System.Address, Task_Id);
 141
 142    function To_Address is new Unchecked_Conversion (Task_Id, System.Address);
 143
 144    function Get_Exc_Stack_Addr return Address;
 145    --  Replace System.Soft_Links.Get_Exc_Stack_Addr_NT
 146
 147    procedure Timer_Sleep_AST (ID : Address);
 148    --  Signal the condition variable when AST fires.
 149
 150    procedure Timer_Sleep_AST (ID : Address) is
 151       Result  : Interfaces.C.int;
 152       Self_ID : constant Task_Id := To_Task_Id (ID);
 153    begin
 154       Self_ID.Common.LL.AST_Pending := False;
 155       Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
 156       pragma Assert (Result = 0);
 157    end Timer_Sleep_AST;
 158
 159    -----------------
 160    -- Stack_Guard --
 161    -----------------
 162
 163    --  The underlying thread system sets a guard page at the
 164    --  bottom of a thread stack, so nothing is needed.
 165    --  ??? Check the comment above
 166
 167    procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is
 168       pragma Unreferenced (T);
 169       pragma Unreferenced (On);
 170    begin
 171       null;
 172    end Stack_Guard;
 173
 174    --------------------
 175    -- Get_Thread_Id  --
 176    --------------------
 177
 178    function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is
 179    begin
 180       return T.Common.LL.Thread;
 181    end Get_Thread_Id;
 182
 183    ----------
 184    -- Self --
 185    ----------
 186
 187    function Self return Task_Id renames Specific.Self;
 188
 189    ---------------------
 190    -- Initialize_Lock --
 191    ---------------------
 192
 193    --  Note: mutexes and cond_variables needed per-task basis are
 194    --  initialized in Initialize_TCB and the Storage_Error is
 195    --  handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 196    --  used in RTS is initialized before any status change of RTS.
 197    --  Therefore rasing Storage_Error in the following routines
 198    --  should be able to be handled safely.
 199
 200    procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
 201       Attributes : aliased pthread_mutexattr_t;
 202       Result     : Interfaces.C.int;
 203
 204    begin
 205       Result := pthread_mutexattr_init (Attributes'Access);
 206       pragma Assert (Result = 0 or else Result = ENOMEM);
 207
 208       if Result = ENOMEM then
 209          raise Storage_Error;
 210       end if;
 211
 212       L.Prio_Save := 0;
 213       L.Prio := Interfaces.C.int (Prio);
 214
 215       Result := pthread_mutex_init (L.L'Access, Attributes'Access);
 216       pragma Assert (Result = 0 or else Result = ENOMEM);
 217
 218       if Result = ENOMEM then
 219          raise Storage_Error;
 220       end if;
 221
 222       Result := pthread_mutexattr_destroy (Attributes'Access);
 223       pragma Assert (Result = 0);
 224    end Initialize_Lock;
 225
 226    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 227       pragma Unreferenced (Level);
 228
 229       Attributes : aliased pthread_mutexattr_t;
 230       Result : Interfaces.C.int;
 231
 232    begin
 233       Result := pthread_mutexattr_init (Attributes'Access);
 234       pragma Assert (Result = 0 or else Result = ENOMEM);
 235
 236       if Result = ENOMEM then
 237          raise Storage_Error;
 238       end if;
 239
 240 --      Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes???
 241 --      Result := pthread_mutexattr_settype_np
 242 --        (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP);
 243 --      pragma Assert (Result = 0);
 244
 245 --      Result := pthread_mutexattr_setprotocol
 246 --        (Attributes'Access, PTHREAD_PRIO_PROTECT);
 247 --      pragma Assert (Result = 0);
 248
 249 --      Result := pthread_mutexattr_setprioceiling
 250 --         (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
 251 --      pragma Assert (Result = 0);
 252
 253       Result := pthread_mutex_init (L, Attributes'Access);
 254
 255       pragma Assert (Result = 0 or else Result = ENOMEM);
 256
 257       if Result = ENOMEM then
 258          raise Storage_Error;
 259       end if;
 260
 261       Result := pthread_mutexattr_destroy (Attributes'Access);
 262       pragma Assert (Result = 0);
 263    end Initialize_Lock;
 264
 265    -------------------
 266    -- Finalize_Lock --
 267    -------------------
 268
 269    procedure Finalize_Lock (L : access Lock) is
 270       Result : Interfaces.C.int;
 271    begin
 272       Result := pthread_mutex_destroy (L.L'Access);
 273       pragma Assert (Result = 0);
 274    end Finalize_Lock;
 275
 276    procedure Finalize_Lock (L : access RTS_Lock) is
 277       Result : Interfaces.C.int;
 278    begin
 279       Result := pthread_mutex_destroy (L);
 280       pragma Assert (Result = 0);
 281    end Finalize_Lock;
 282
 283    ----------------
 284    -- Write_Lock --
 285    ----------------
 286
 287    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 288       Self_ID        : constant Task_Id := Self;
 289       All_Tasks_Link : constant Task_Id := Self.Common.All_Tasks_Link;
 290       Current_Prio   : System.Any_Priority;
 291       Result         : Interfaces.C.int;
 292
 293    begin
 294       Current_Prio := Get_Priority (Self_ID);
 295
 296       --  If there is no other tasks, no need to check priorities
 297
 298       if All_Tasks_Link /= Null_Task
 299         and then L.Prio < Interfaces.C.int (Current_Prio)
 300       then
 301          Ceiling_Violation := True;
 302          return;
 303       end if;
 304
 305       Result := pthread_mutex_lock (L.L'Access);
 306       pragma Assert (Result = 0);
 307
 308       Ceiling_Violation := False;
 309 --  Why is this commented out ???
 310 --      L.Prio_Save := Interfaces.C.int (Current_Prio);
 311 --      Set_Priority (Self_ID, System.Any_Priority (L.Prio));
 312    end Write_Lock;
 313
 314    procedure Write_Lock
 315      (L           : access RTS_Lock;
 316       Global_Lock : Boolean := False)
 317    is
 318       Result : Interfaces.C.int;
 319    begin
 320       if not Single_Lock or else Global_Lock then
 321          Result := pthread_mutex_lock (L);
 322          pragma Assert (Result = 0);
 323       end if;
 324    end Write_Lock;
 325
 326    procedure Write_Lock (T : Task_Id) is
 327       Result : Interfaces.C.int;
 328    begin
 329       if not Single_Lock then
 330          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 331          pragma Assert (Result = 0);
 332       end if;
 333    end Write_Lock;
 334
 335    ---------------
 336    -- Read_Lock --
 337    ---------------
 338
 339    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 340    begin
 341       Write_Lock (L, Ceiling_Violation);
 342    end Read_Lock;
 343
 344    ------------
 345    -- Unlock --
 346    ------------
 347
 348    procedure Unlock (L : access Lock) is
 349       Result : Interfaces.C.int;
 350    begin
 351       Result := pthread_mutex_unlock (L.L'Access);
 352       pragma Assert (Result = 0);
 353    end Unlock;
 354
 355    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 356       Result : Interfaces.C.int;
 357    begin
 358       if not Single_Lock or else Global_Lock then
 359          Result := pthread_mutex_unlock (L);
 360          pragma Assert (Result = 0);
 361       end if;
 362    end Unlock;
 363
 364    procedure Unlock (T : Task_Id) is
 365       Result : Interfaces.C.int;
 366    begin
 367       if not Single_Lock then
 368          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 369          pragma Assert (Result = 0);
 370       end if;
 371    end Unlock;
 372
 373    -----------
 374    -- Sleep --
 375    -----------
 376
 377    procedure Sleep
 378      (Self_ID : Task_Id;
 379       Reason  : System.Tasking.Task_States)
 380    is
 381       pragma Unreferenced (Reason);
 382       Result : Interfaces.C.int;
 383
 384    begin
 385       if Single_Lock then
 386          Result := pthread_cond_wait
 387            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 388       else
 389          Result := pthread_cond_wait
 390            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 391       end if;
 392
 393       --  EINTR is not considered a failure
 394
 395       pragma Assert (Result = 0 or else Result = EINTR);
 396
 397       if Self_ID.Deferral_Level = 0
 398         and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 399       then
 400          Unlock (Self_ID);
 401          raise Standard'Abort_Signal;
 402       end if;
 403    end Sleep;
 404
 405    -----------------
 406    -- Timed_Sleep --
 407    -----------------
 408
 409    procedure Timed_Sleep
 410      (Self_ID  : Task_Id;
 411       Time     : Duration;
 412       Mode     : ST.Delay_Modes;
 413       Reason   : System.Tasking.Task_States;
 414       Timedout : out Boolean;
 415       Yielded  : out Boolean)
 416    is
 417       pragma Unreferenced (Reason);
 418
 419       Sleep_Time : OS_Time;
 420       Result     : Interfaces.C.int;
 421       Status     : Cond_Value_Type;
 422
 423       --  The body below requires more comments ???
 424
 425    begin
 426       Timedout := False;
 427       Yielded := False;
 428
 429       Sleep_Time := To_OS_Time (Time, Mode);
 430
 431       if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 432         or else Self_ID.Pending_Priority_Change
 433       then
 434          return;
 435       end if;
 436
 437       Self_ID.Common.LL.AST_Pending := True;
 438
 439       Sys_Setimr
 440        (Status, 0, Sleep_Time,
 441         Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
 442
 443       if (Status and 1) /= 1 then
 444          raise Storage_Error;
 445       end if;
 446
 447       if Single_Lock then
 448          Result := pthread_cond_wait
 449            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 450          pragma Assert (Result = 0);
 451
 452       else
 453          Result := pthread_cond_wait
 454            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 455          pragma Assert (Result = 0);
 456       end if;
 457
 458       Yielded := True;
 459
 460       if not Self_ID.Common.LL.AST_Pending then
 461          Timedout := True;
 462       else
 463          Sys_Cantim (Status, To_Address (Self_ID), 0);
 464          pragma Assert ((Status and 1) = 1);
 465       end if;
 466    end Timed_Sleep;
 467
 468    -----------------
 469    -- Timed_Delay --
 470    -----------------
 471
 472    procedure Timed_Delay
 473      (Self_ID : Task_Id;
 474       Time    : Duration;
 475       Mode    : ST.Delay_Modes)
 476    is
 477       Sleep_Time : OS_Time;
 478       Result     : Interfaces.C.int;
 479       Status     : Cond_Value_Type;
 480       Yielded    : Boolean := False;
 481
 482    begin
 483       if Single_Lock then
 484          Lock_RTS;
 485       end if;
 486
 487       --  More comments required in body below ???
 488
 489       Write_Lock (Self_ID);
 490
 491       if Time /= 0.0 or else Mode /= Relative then
 492          Sleep_Time := To_OS_Time (Time, Mode);
 493
 494          if Mode = Relative or else OS_Clock < Sleep_Time then
 495             Self_ID.Common.State := Delay_Sleep;
 496             Self_ID.Common.LL.AST_Pending := True;
 497
 498             Sys_Setimr
 499              (Status, 0, Sleep_Time,
 500               Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
 501
 502             if (Status and 1) /= 1 then
 503                raise Storage_Error;
 504             end if;
 505
 506             loop
 507                if Self_ID.Pending_Priority_Change then
 508                   Self_ID.Pending_Priority_Change := False;
 509                   Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 510                   Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 511                end if;
 512
 513                if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then
 514                   Sys_Cantim (Status, To_Address (Self_ID), 0);
 515                   pragma Assert ((Status and 1) = 1);
 516                   exit;
 517                end if;
 518
 519                if Single_Lock then
 520                   Result := pthread_cond_wait
 521                     (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 522                   pragma Assert (Result = 0);
 523                else
 524                   Result := pthread_cond_wait
 525                     (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 526                   pragma Assert (Result = 0);
 527                end if;
 528
 529                Yielded := True;
 530
 531                exit when not Self_ID.Common.LL.AST_Pending;
 532             end loop;
 533
 534             Self_ID.Common.State := Runnable;
 535          end if;
 536       end if;
 537
 538       Unlock (Self_ID);
 539
 540       if Single_Lock then
 541          Unlock_RTS;
 542       end if;
 543
 544       if not Yielded then
 545          Result := sched_yield;
 546          pragma Assert (Result = 0);
 547       end if;
 548    end Timed_Delay;
 549
 550    ---------------------
 551    -- Monotonic_Clock --
 552    ---------------------
 553
 554    function Monotonic_Clock return Duration
 555      renames System.OS_Primitives.Monotonic_Clock;
 556
 557    -------------------
 558    -- RT_Resolution --
 559    -------------------
 560
 561    function RT_Resolution return Duration is
 562    begin
 563       return 10#1.0#E-3;
 564    end RT_Resolution;
 565
 566    ------------
 567    -- Wakeup --
 568    ------------
 569
 570    procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is
 571       pragma Unreferenced (Reason);
 572       Result : Interfaces.C.int;
 573    begin
 574       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 575       pragma Assert (Result = 0);
 576    end Wakeup;
 577
 578    -----------
 579    -- Yield --
 580    -----------
 581
 582    procedure Yield (Do_Yield : Boolean := True) is
 583       Result : Interfaces.C.int;
 584       pragma Unreferenced (Result);
 585    begin
 586       if Do_Yield then
 587          Result := sched_yield;
 588       end if;
 589    end Yield;
 590
 591    ------------------
 592    -- Set_Priority --
 593    ------------------
 594
 595    procedure Set_Priority
 596      (T                   : Task_Id;
 597       Prio                : System.Any_Priority;
 598       Loss_Of_Inheritance : Boolean := False)
 599    is
 600       pragma Unreferenced (Loss_Of_Inheritance);
 601
 602       Result : Interfaces.C.int;
 603       Param  : aliased struct_sched_param;
 604
 605    begin
 606       T.Common.Current_Priority := Prio;
 607       Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
 608
 609       if Time_Slice_Val > 0 then
 610          Result := pthread_setschedparam
 611            (T.Common.LL.Thread, SCHED_RR, Param'Access);
 612
 613       elsif Dispatching_Policy = 'F' or else Time_Slice_Val = 0 then
 614          Result := pthread_setschedparam
 615            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 616
 617       else
 618          --  SCHED_OTHER priorities are restricted to the range 8 - 15.
 619          --  Since the translation from Underlying priorities results
 620          --  in a range of 16 - 31, dividing by 2 gives the correct result.
 621
 622          Param.sched_priority := Param.sched_priority / 2;
 623          Result := pthread_setschedparam
 624            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 625       end if;
 626
 627       pragma Assert (Result = 0);
 628    end Set_Priority;
 629
 630    ------------------
 631    -- Get_Priority --
 632    ------------------
 633
 634    function Get_Priority (T : Task_Id) return System.Any_Priority is
 635    begin
 636       return T.Common.Current_Priority;
 637    end Get_Priority;
 638
 639    ----------------
 640    -- Enter_Task --
 641    ----------------
 642
 643    procedure Enter_Task (Self_ID : Task_Id) is
 644    begin
 645       Self_ID.Common.LL.Thread := pthread_self;
 646
 647       Specific.Set (Self_ID);
 648
 649       Lock_RTS;
 650
 651       for J in Known_Tasks'Range loop
 652          if Known_Tasks (J) = null then
 653             Known_Tasks (J) := Self_ID;
 654             Self_ID.Known_Tasks_Index := J;
 655             exit;
 656          end if;
 657       end loop;
 658
 659       Unlock_RTS;
 660    end Enter_Task;
 661
 662    --------------
 663    -- New_ATCB --
 664    --------------
 665
 666    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 667    begin
 668       return new Ada_Task_Control_Block (Entry_Num);
 669    end New_ATCB;
 670
 671    -------------------
 672    -- Is_Valid_Task --
 673    -------------------
 674
 675    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 676
 677    -----------------------------
 678    -- Register_Foreign_Thread --
 679    -----------------------------
 680
 681    function Register_Foreign_Thread return Task_Id is
 682    begin
 683       if Is_Valid_Task then
 684          return Self;
 685       else
 686          return Register_Foreign_Thread (pthread_self);
 687       end if;
 688    end Register_Foreign_Thread;
 689
 690    --------------------
 691    -- Initialize_TCB --
 692    --------------------
 693
 694    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 695       Mutex_Attr : aliased pthread_mutexattr_t;
 696       Result     : Interfaces.C.int;
 697       Cond_Attr  : aliased pthread_condattr_t;
 698
 699    begin
 700       --  More comments required in body below ???
 701
 702       if not Single_Lock then
 703          Result := pthread_mutexattr_init (Mutex_Attr'Access);
 704          pragma Assert (Result = 0 or else Result = ENOMEM);
 705
 706          if Result = 0 then
 707             Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
 708               Mutex_Attr'Access);
 709             pragma Assert (Result = 0 or else Result = ENOMEM);
 710          end if;
 711
 712          if Result /= 0 then
 713             Succeeded := False;
 714             return;
 715          end if;
 716
 717          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 718          pragma Assert (Result = 0);
 719       end if;
 720
 721       Result := pthread_condattr_init (Cond_Attr'Access);
 722       pragma Assert (Result = 0 or else Result = ENOMEM);
 723
 724       if Result = 0 then
 725          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 726            Cond_Attr'Access);
 727          pragma Assert (Result = 0 or else Result = ENOMEM);
 728       end if;
 729
 730       if Result = 0 then
 731          Succeeded := True;
 732          Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T;
 733
 734       else
 735          if not Single_Lock then
 736             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 737             pragma Assert (Result = 0);
 738          end if;
 739
 740          Succeeded := False;
 741       end if;
 742
 743       Result := pthread_condattr_destroy (Cond_Attr'Access);
 744       pragma Assert (Result = 0);
 745    end Initialize_TCB;
 746
 747    ------------------------
 748    -- Get_Exc_Stack_Addr --
 749    ------------------------
 750
 751    function Get_Exc_Stack_Addr return Address is
 752    begin
 753       return Self.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address;
 754    end Get_Exc_Stack_Addr;
 755
 756    -----------------
 757    -- Create_Task --
 758    -----------------
 759
 760    procedure Create_Task
 761      (T          : Task_Id;
 762       Wrapper    : System.Address;
 763       Stack_Size : System.Parameters.Size_Type;
 764       Priority   : System.Any_Priority;
 765       Succeeded  : out Boolean)
 766    is
 767       Attributes : aliased pthread_attr_t;
 768       Result     : Interfaces.C.int;
 769
 770       function Thread_Body_Access is new
 771         Unchecked_Conversion (System.Address, Thread_Body);
 772
 773    begin
 774       --  Since the initial signal mask of a thread is inherited from the
 775       --  creator, we need to set our local signal mask mask all signals
 776       --  during the creation operation, to make sure the new thread is
 777       --  not disturbed by signals before it has set its own Task_Id.
 778
 779       Result := pthread_attr_init (Attributes'Access);
 780       pragma Assert (Result = 0 or else Result = ENOMEM);
 781
 782       if Result /= 0 then
 783          Succeeded := False;
 784          return;
 785       end if;
 786
 787       Result := pthread_attr_setdetachstate
 788         (Attributes'Access, PTHREAD_CREATE_DETACHED);
 789       pragma Assert (Result = 0);
 790
 791       Result := pthread_attr_setstacksize
 792         (Attributes'Access, Interfaces.C.size_t (Stack_Size));
 793       pragma Assert (Result = 0);
 794
 795       --  This call may be unnecessary, not sure. ???
 796
 797       Result :=
 798         pthread_attr_setinheritsched
 799           (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
 800       pragma Assert (Result = 0);
 801
 802       Result := pthread_create
 803         (T.Common.LL.Thread'Access,
 804          Attributes'Access,
 805          Thread_Body_Access (Wrapper),
 806          To_Address (T));
 807
 808       --  ENOMEM is a valid run-time error.  Don't shut down.
 809
 810       pragma Assert (Result = 0
 811         or else Result = EAGAIN or else Result = ENOMEM);
 812
 813       Succeeded := Result = 0;
 814
 815       Result := pthread_attr_destroy (Attributes'Access);
 816       pragma Assert (Result = 0);
 817
 818       if Succeeded then
 819          Set_Priority (T, Priority);
 820       end if;
 821    end Create_Task;
 822
 823    ------------------
 824    -- Finalize_TCB --
 825    ------------------
 826
 827    procedure Finalize_TCB (T : Task_Id) is
 828       Result  : Interfaces.C.int;
 829       Tmp     : Task_Id := T;
 830       Is_Self : constant Boolean := T = Self;
 831
 832       procedure Free is new
 833         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 834
 835       procedure Free is new Unchecked_Deallocation
 836        (Exc_Stack_T, Exc_Stack_Ptr_T);
 837
 838    begin
 839       if not Single_Lock then
 840          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 841          pragma Assert (Result = 0);
 842       end if;
 843
 844       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 845       pragma Assert (Result = 0);
 846
 847       if T.Known_Tasks_Index /= -1 then
 848          Known_Tasks (T.Known_Tasks_Index) := null;
 849       end if;
 850
 851       Free (T.Common.LL.Exc_Stack_Ptr);
 852
 853       Free (Tmp);
 854
 855       if Is_Self then
 856          Specific.Set (null);
 857       end if;
 858    end Finalize_TCB;
 859
 860    ---------------
 861    -- Exit_Task --
 862    ---------------
 863
 864    procedure Exit_Task is
 865    begin
 866       null;
 867    end Exit_Task;
 868
 869    ----------------
 870    -- Abort_Task --
 871    ----------------
 872
 873    procedure Abort_Task (T : Task_Id) is
 874    begin
 875       --  Interrupt Server_Tasks may be waiting on an event flag
 876
 877       if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
 878          Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag);
 879       end if;
 880    end Abort_Task;
 881
 882    ----------------
 883    -- Initialize --
 884    ----------------
 885
 886    procedure Initialize (S : in out Suspension_Object) is
 887       Mutex_Attr : aliased pthread_mutexattr_t;
 888       Cond_Attr  : aliased pthread_condattr_t;
 889       Result     : Interfaces.C.int;
 890    begin
 891       --  Initialize internal state. It is always initialized to False (ARM
 892       --  D.10 par. 6).
 893
 894       S.State := False;
 895       S.Waiting := False;
 896
 897       --  Initialize internal mutex
 898
 899       Result := pthread_mutexattr_init (Mutex_Attr'Access);
 900       pragma Assert (Result = 0 or else Result = ENOMEM);
 901
 902       if Result = ENOMEM then
 903          raise Storage_Error;
 904       end if;
 905
 906       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
 907       pragma Assert (Result = 0 or else Result = ENOMEM);
 908
 909       if Result = ENOMEM then
 910          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 911          pragma Assert (Result = 0);
 912
 913          raise Storage_Error;
 914       end if;
 915
 916       Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 917       pragma Assert (Result = 0);
 918
 919       --  Initialize internal condition variable
 920
 921       Result := pthread_condattr_init (Cond_Attr'Access);
 922       pragma Assert (Result = 0 or else Result = ENOMEM);
 923
 924       if Result /= 0 then
 925          Result := pthread_mutex_destroy (S.L'Access);
 926          pragma Assert (Result = 0);
 927
 928          if Result = ENOMEM then
 929             raise Storage_Error;
 930          end if;
 931       end if;
 932
 933       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
 934       pragma Assert (Result = 0 or else Result = ENOMEM);
 935
 936       if Result /= 0 then
 937          Result := pthread_mutex_destroy (S.L'Access);
 938          pragma Assert (Result = 0);
 939
 940          if Result = ENOMEM then
 941             Result := pthread_condattr_destroy (Cond_Attr'Access);
 942             pragma Assert (Result = 0);
 943
 944             raise Storage_Error;
 945          end if;
 946       end if;
 947
 948       Result := pthread_condattr_destroy (Cond_Attr'Access);
 949       pragma Assert (Result = 0);
 950    end Initialize;
 951
 952    --------------
 953    -- Finalize --
 954    --------------
 955
 956    procedure Finalize (S : in out Suspension_Object) is
 957       Result  : Interfaces.C.int;
 958    begin
 959       --  Destroy internal mutex
 960
 961       Result := pthread_mutex_destroy (S.L'Access);
 962       pragma Assert (Result = 0);
 963
 964       --  Destroy internal condition variable
 965
 966       Result := pthread_cond_destroy (S.CV'Access);
 967       pragma Assert (Result = 0);
 968    end Finalize;
 969
 970    -------------------
 971    -- Current_State --
 972    -------------------
 973
 974    function Current_State (S : Suspension_Object) return Boolean is
 975    begin
 976       --  We do not want to use lock on this read operation. State is marked
 977       --  as Atomic so that we ensure that the value retrieved is correct.
 978
 979       return S.State;
 980    end Current_State;
 981
 982    ---------------
 983    -- Set_False --
 984    ---------------
 985
 986    procedure Set_False (S : in out Suspension_Object) is
 987       Result  : Interfaces.C.int;
 988    begin
 989       SSL.Abort_Defer.all;
 990
 991       Result := pthread_mutex_lock (S.L'Access);
 992       pragma Assert (Result = 0);
 993
 994       S.State := False;
 995
 996       Result := pthread_mutex_unlock (S.L'Access);
 997       pragma Assert (Result = 0);
 998
 999       SSL.Abort_Undefer.all;
1000    end Set_False;
1001
1002    --------------
1003    -- Set_True --
1004    --------------
1005
1006    procedure Set_True (S : in out Suspension_Object) is
1007       Result : Interfaces.C.int;
1008    begin
1009       SSL.Abort_Defer.all;
1010
1011       Result := pthread_mutex_lock (S.L'Access);
1012       pragma Assert (Result = 0);
1013
1014       --  If there is already a task waiting on this suspension object then
1015       --  we resume it, leaving the state of the suspension object to False,
1016       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1017       --  the state to True.
1018
1019       if S.Waiting then
1020          S.Waiting := False;
1021          S.State := False;
1022
1023          Result := pthread_cond_signal (S.CV'Access);
1024          pragma Assert (Result = 0);
1025       else
1026          S.State := True;
1027       end if;
1028
1029       Result := pthread_mutex_unlock (S.L'Access);
1030       pragma Assert (Result = 0);
1031
1032       SSL.Abort_Undefer.all;
1033    end Set_True;
1034
1035    ------------------------
1036    -- Suspend_Until_True --
1037    ------------------------
1038
1039    procedure Suspend_Until_True (S : in out Suspension_Object) is
1040       Result : Interfaces.C.int;
1041    begin
1042       SSL.Abort_Defer.all;
1043
1044       Result := pthread_mutex_lock (S.L'Access);
1045       pragma Assert (Result = 0);
1046
1047       if S.Waiting then
1048          --  Program_Error must be raised upon calling Suspend_Until_True
1049          --  if another task is already waiting on that suspension object
1050          --  (ARM D.10 par. 10).
1051
1052          Result := pthread_mutex_unlock (S.L'Access);
1053          pragma Assert (Result = 0);
1054
1055          SSL.Abort_Undefer.all;
1056
1057          raise Program_Error;
1058       else
1059          --  Suspend the task if the state is False. Otherwise, the task
1060          --  continues its execution, and the state of the suspension object
1061          --  is set to False (ARM D.10 par. 9).
1062
1063          if S.State then
1064             S.State := False;
1065          else
1066             S.Waiting := True;
1067             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1068          end if;
1069
1070          Result := pthread_mutex_unlock (S.L'Access);
1071          pragma Assert (Result = 0);
1072
1073          SSL.Abort_Undefer.all;
1074       end if;
1075    end Suspend_Until_True;
1076
1077    ----------------
1078    -- Check_Exit --
1079    ----------------
1080
1081    --  Dummy version
1082
1083    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1084       pragma Unreferenced (Self_ID);
1085    begin
1086       return True;
1087    end Check_Exit;
1088
1089    --------------------
1090    -- Check_No_Locks --
1091    --------------------
1092
1093    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1094       pragma Unreferenced (Self_ID);
1095    begin
1096       return True;
1097    end Check_No_Locks;
1098
1099    ----------------------
1100    -- Environment_Task --
1101    ----------------------
1102
1103    function Environment_Task return Task_Id is
1104    begin
1105       return Environment_Task_Id;
1106    end Environment_Task;
1107
1108    --------------
1109    -- Lock_RTS --
1110    --------------
1111
1112    procedure Lock_RTS is
1113    begin
1114       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1115    end Lock_RTS;
1116
1117    ----------------
1118    -- Unlock_RTS --
1119    ----------------
1120
1121    procedure Unlock_RTS is
1122    begin
1123       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1124    end Unlock_RTS;
1125
1126    ------------------
1127    -- Suspend_Task --
1128    ------------------
1129
1130    function Suspend_Task
1131      (T           : ST.Task_Id;
1132       Thread_Self : Thread_Id) return Boolean
1133    is
1134       pragma Unreferenced (T);
1135       pragma Unreferenced (Thread_Self);
1136    begin
1137       return False;
1138    end Suspend_Task;
1139
1140    -----------------
1141    -- Resume_Task --
1142    -----------------
1143
1144    function Resume_Task
1145      (T           : ST.Task_Id;
1146       Thread_Self : Thread_Id) return Boolean
1147    is
1148       pragma Unreferenced (T);
1149       pragma Unreferenced (Thread_Self);
1150    begin
1151       return False;
1152    end Resume_Task;
1153
1154    ----------------
1155    -- Initialize --
1156    ----------------
1157
1158    procedure Initialize (Environment_Task : Task_Id) is
1159    begin
1160       Environment_Task_Id := Environment_Task;
1161
1162       SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access;
1163
1164       --  Initialize the lock used to synchronize chain of all ATCBs
1165
1166       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1167
1168       Specific.Initialize (Environment_Task);
1169
1170       Enter_Task (Environment_Task);
1171    end Initialize;
1172
1173 end System.Task_Primitives.Operations;