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       function Get_Policy (Prio : System.Any_Priority) return Character;
 606       pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching");
 607       --  Get priority specific dispatching policy
 608
 609       Priority_Specific_Policy : constant Character := Get_Policy (Prio);
 610       --  Upper case first character of the policy name corresponding to the
 611       --  task as set by a Priority_Specific_Dispatching pragma.
 612
 613    begin
 614       T.Common.Current_Priority := Prio;
 615       Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
 616
 617       if Dispatching_Policy = 'R'
 618         or else Priority_Specific_Policy = 'R'
 619         or else Time_Slice_Val > 0
 620       then
 621          Result := pthread_setschedparam
 622            (T.Common.LL.Thread, SCHED_RR, Param'Access);
 623
 624       elsif Dispatching_Policy = 'F'
 625         or else Priority_Specific_Policy = 'F'
 626         or else Time_Slice_Val = 0
 627       then
 628          Result := pthread_setschedparam
 629            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 630
 631       else
 632          --  SCHED_OTHER priorities are restricted to the range 8 - 15.
 633          --  Since the translation from Underlying priorities results
 634          --  in a range of 16 - 31, dividing by 2 gives the correct result.
 635
 636          Param.sched_priority := Param.sched_priority / 2;
 637          Result := pthread_setschedparam
 638            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 639       end if;
 640
 641       pragma Assert (Result = 0);
 642    end Set_Priority;
 643
 644    ------------------
 645    -- Get_Priority --
 646    ------------------
 647
 648    function Get_Priority (T : Task_Id) return System.Any_Priority is
 649    begin
 650       return T.Common.Current_Priority;
 651    end Get_Priority;
 652
 653    ----------------
 654    -- Enter_Task --
 655    ----------------
 656
 657    procedure Enter_Task (Self_ID : Task_Id) is
 658    begin
 659       Self_ID.Common.LL.Thread := pthread_self;
 660
 661       Specific.Set (Self_ID);
 662
 663       Lock_RTS;
 664
 665       for J in Known_Tasks'Range loop
 666          if Known_Tasks (J) = null then
 667             Known_Tasks (J) := Self_ID;
 668             Self_ID.Known_Tasks_Index := J;
 669             exit;
 670          end if;
 671       end loop;
 672
 673       Unlock_RTS;
 674    end Enter_Task;
 675
 676    --------------
 677    -- New_ATCB --
 678    --------------
 679
 680    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_Id is
 681    begin
 682       return new Ada_Task_Control_Block (Entry_Num);
 683    end New_ATCB;
 684
 685    -------------------
 686    -- Is_Valid_Task --
 687    -------------------
 688
 689    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 690
 691    -----------------------------
 692    -- Register_Foreign_Thread --
 693    -----------------------------
 694
 695    function Register_Foreign_Thread return Task_Id is
 696    begin
 697       if Is_Valid_Task then
 698          return Self;
 699       else
 700          return Register_Foreign_Thread (pthread_self);
 701       end if;
 702    end Register_Foreign_Thread;
 703
 704    --------------------
 705    -- Initialize_TCB --
 706    --------------------
 707
 708    procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
 709       Mutex_Attr : aliased pthread_mutexattr_t;
 710       Result     : Interfaces.C.int;
 711       Cond_Attr  : aliased pthread_condattr_t;
 712
 713    begin
 714       --  More comments required in body below ???
 715
 716       if not Single_Lock then
 717          Result := pthread_mutexattr_init (Mutex_Attr'Access);
 718          pragma Assert (Result = 0 or else Result = ENOMEM);
 719
 720          if Result = 0 then
 721             Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
 722               Mutex_Attr'Access);
 723             pragma Assert (Result = 0 or else Result = ENOMEM);
 724          end if;
 725
 726          if Result /= 0 then
 727             Succeeded := False;
 728             return;
 729          end if;
 730
 731          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 732          pragma Assert (Result = 0);
 733       end if;
 734
 735       Result := pthread_condattr_init (Cond_Attr'Access);
 736       pragma Assert (Result = 0 or else Result = ENOMEM);
 737
 738       if Result = 0 then
 739          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 740            Cond_Attr'Access);
 741          pragma Assert (Result = 0 or else Result = ENOMEM);
 742       end if;
 743
 744       if Result = 0 then
 745          Succeeded := True;
 746          Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T;
 747
 748       else
 749          if not Single_Lock then
 750             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 751             pragma Assert (Result = 0);
 752          end if;
 753
 754          Succeeded := False;
 755       end if;
 756
 757       Result := pthread_condattr_destroy (Cond_Attr'Access);
 758       pragma Assert (Result = 0);
 759    end Initialize_TCB;
 760
 761    ------------------------
 762    -- Get_Exc_Stack_Addr --
 763    ------------------------
 764
 765    function Get_Exc_Stack_Addr return Address is
 766    begin
 767       return Self.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address;
 768    end Get_Exc_Stack_Addr;
 769
 770    -----------------
 771    -- Create_Task --
 772    -----------------
 773
 774    procedure Create_Task
 775      (T          : Task_Id;
 776       Wrapper    : System.Address;
 777       Stack_Size : System.Parameters.Size_Type;
 778       Priority   : System.Any_Priority;
 779       Succeeded  : out Boolean)
 780    is
 781       Attributes : aliased pthread_attr_t;
 782       Result     : Interfaces.C.int;
 783
 784       function Thread_Body_Access is new
 785         Unchecked_Conversion (System.Address, Thread_Body);
 786
 787    begin
 788       --  Since the initial signal mask of a thread is inherited from the
 789       --  creator, we need to set our local signal mask mask all signals
 790       --  during the creation operation, to make sure the new thread is
 791       --  not disturbed by signals before it has set its own Task_Id.
 792
 793       Result := pthread_attr_init (Attributes'Access);
 794       pragma Assert (Result = 0 or else Result = ENOMEM);
 795
 796       if Result /= 0 then
 797          Succeeded := False;
 798          return;
 799       end if;
 800
 801       Result := pthread_attr_setdetachstate
 802         (Attributes'Access, PTHREAD_CREATE_DETACHED);
 803       pragma Assert (Result = 0);
 804
 805       Result := pthread_attr_setstacksize
 806         (Attributes'Access, Interfaces.C.size_t (Stack_Size));
 807       pragma Assert (Result = 0);
 808
 809       --  This call may be unnecessary, not sure. ???
 810
 811       Result :=
 812         pthread_attr_setinheritsched
 813           (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
 814       pragma Assert (Result = 0);
 815
 816       Result := pthread_create
 817         (T.Common.LL.Thread'Access,
 818          Attributes'Access,
 819          Thread_Body_Access (Wrapper),
 820          To_Address (T));
 821
 822       --  ENOMEM is a valid run-time error.  Don't shut down.
 823
 824       pragma Assert (Result = 0
 825         or else Result = EAGAIN or else Result = ENOMEM);
 826
 827       Succeeded := Result = 0;
 828
 829       Result := pthread_attr_destroy (Attributes'Access);
 830       pragma Assert (Result = 0);
 831
 832       if Succeeded then
 833          Set_Priority (T, Priority);
 834       end if;
 835    end Create_Task;
 836
 837    ------------------
 838    -- Finalize_TCB --
 839    ------------------
 840
 841    procedure Finalize_TCB (T : Task_Id) is
 842       Result  : Interfaces.C.int;
 843       Tmp     : Task_Id := T;
 844       Is_Self : constant Boolean := T = Self;
 845
 846       procedure Free is new
 847         Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
 848
 849       procedure Free is new Unchecked_Deallocation
 850        (Exc_Stack_T, Exc_Stack_Ptr_T);
 851
 852    begin
 853       if not Single_Lock then
 854          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 855          pragma Assert (Result = 0);
 856       end if;
 857
 858       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 859       pragma Assert (Result = 0);
 860
 861       if T.Known_Tasks_Index /= -1 then
 862          Known_Tasks (T.Known_Tasks_Index) := null;
 863       end if;
 864
 865       Free (T.Common.LL.Exc_Stack_Ptr);
 866
 867       Free (Tmp);
 868
 869       if Is_Self then
 870          Specific.Set (null);
 871       end if;
 872    end Finalize_TCB;
 873
 874    ---------------
 875    -- Exit_Task --
 876    ---------------
 877
 878    procedure Exit_Task is
 879    begin
 880       null;
 881    end Exit_Task;
 882
 883    ----------------
 884    -- Abort_Task --
 885    ----------------
 886
 887    procedure Abort_Task (T : Task_Id) is
 888    begin
 889       --  Interrupt Server_Tasks may be waiting on an event flag
 890
 891       if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
 892          Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag);
 893       end if;
 894    end Abort_Task;
 895
 896    ----------------
 897    -- Initialize --
 898    ----------------
 899
 900    procedure Initialize (S : in out Suspension_Object) is
 901       Mutex_Attr : aliased pthread_mutexattr_t;
 902       Cond_Attr  : aliased pthread_condattr_t;
 903       Result     : Interfaces.C.int;
 904    begin
 905       --  Initialize internal state. It is always initialized to False (ARM
 906       --  D.10 par. 6).
 907
 908       S.State := False;
 909       S.Waiting := False;
 910
 911       --  Initialize internal mutex
 912
 913       Result := pthread_mutexattr_init (Mutex_Attr'Access);
 914       pragma Assert (Result = 0 or else Result = ENOMEM);
 915
 916       if Result = ENOMEM then
 917          raise Storage_Error;
 918       end if;
 919
 920       Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access);
 921       pragma Assert (Result = 0 or else Result = ENOMEM);
 922
 923       if Result = ENOMEM then
 924          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 925          pragma Assert (Result = 0);
 926
 927          raise Storage_Error;
 928       end if;
 929
 930       Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 931       pragma Assert (Result = 0);
 932
 933       --  Initialize internal condition variable
 934
 935       Result := pthread_condattr_init (Cond_Attr'Access);
 936       pragma Assert (Result = 0 or else Result = ENOMEM);
 937
 938       if Result /= 0 then
 939          Result := pthread_mutex_destroy (S.L'Access);
 940          pragma Assert (Result = 0);
 941
 942          if Result = ENOMEM then
 943             raise Storage_Error;
 944          end if;
 945       end if;
 946
 947       Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
 948       pragma Assert (Result = 0 or else Result = ENOMEM);
 949
 950       if Result /= 0 then
 951          Result := pthread_mutex_destroy (S.L'Access);
 952          pragma Assert (Result = 0);
 953
 954          if Result = ENOMEM then
 955             Result := pthread_condattr_destroy (Cond_Attr'Access);
 956             pragma Assert (Result = 0);
 957
 958             raise Storage_Error;
 959          end if;
 960       end if;
 961
 962       Result := pthread_condattr_destroy (Cond_Attr'Access);
 963       pragma Assert (Result = 0);
 964    end Initialize;
 965
 966    --------------
 967    -- Finalize --
 968    --------------
 969
 970    procedure Finalize (S : in out Suspension_Object) is
 971       Result  : Interfaces.C.int;
 972    begin
 973       --  Destroy internal mutex
 974
 975       Result := pthread_mutex_destroy (S.L'Access);
 976       pragma Assert (Result = 0);
 977
 978       --  Destroy internal condition variable
 979
 980       Result := pthread_cond_destroy (S.CV'Access);
 981       pragma Assert (Result = 0);
 982    end Finalize;
 983
 984    -------------------
 985    -- Current_State --
 986    -------------------
 987
 988    function Current_State (S : Suspension_Object) return Boolean is
 989    begin
 990       --  We do not want to use lock on this read operation. State is marked
 991       --  as Atomic so that we ensure that the value retrieved is correct.
 992
 993       return S.State;
 994    end Current_State;
 995
 996    ---------------
 997    -- Set_False --
 998    ---------------
 999
1000    procedure Set_False (S : in out Suspension_Object) is
1001       Result  : Interfaces.C.int;
1002    begin
1003       SSL.Abort_Defer.all;
1004
1005       Result := pthread_mutex_lock (S.L'Access);
1006       pragma Assert (Result = 0);
1007
1008       S.State := False;
1009
1010       Result := pthread_mutex_unlock (S.L'Access);
1011       pragma Assert (Result = 0);
1012
1013       SSL.Abort_Undefer.all;
1014    end Set_False;
1015
1016    --------------
1017    -- Set_True --
1018    --------------
1019
1020    procedure Set_True (S : in out Suspension_Object) is
1021       Result : Interfaces.C.int;
1022    begin
1023       SSL.Abort_Defer.all;
1024
1025       Result := pthread_mutex_lock (S.L'Access);
1026       pragma Assert (Result = 0);
1027
1028       --  If there is already a task waiting on this suspension object then
1029       --  we resume it, leaving the state of the suspension object to False,
1030       --  as it is specified in ARM D.10 par. 9. Otherwise, it just leaves
1031       --  the state to True.
1032
1033       if S.Waiting then
1034          S.Waiting := False;
1035          S.State := False;
1036
1037          Result := pthread_cond_signal (S.CV'Access);
1038          pragma Assert (Result = 0);
1039       else
1040          S.State := True;
1041       end if;
1042
1043       Result := pthread_mutex_unlock (S.L'Access);
1044       pragma Assert (Result = 0);
1045
1046       SSL.Abort_Undefer.all;
1047    end Set_True;
1048
1049    ------------------------
1050    -- Suspend_Until_True --
1051    ------------------------
1052
1053    procedure Suspend_Until_True (S : in out Suspension_Object) is
1054       Result : Interfaces.C.int;
1055    begin
1056       SSL.Abort_Defer.all;
1057
1058       Result := pthread_mutex_lock (S.L'Access);
1059       pragma Assert (Result = 0);
1060
1061       if S.Waiting then
1062          --  Program_Error must be raised upon calling Suspend_Until_True
1063          --  if another task is already waiting on that suspension object
1064          --  (ARM D.10 par. 10).
1065
1066          Result := pthread_mutex_unlock (S.L'Access);
1067          pragma Assert (Result = 0);
1068
1069          SSL.Abort_Undefer.all;
1070
1071          raise Program_Error;
1072       else
1073          --  Suspend the task if the state is False. Otherwise, the task
1074          --  continues its execution, and the state of the suspension object
1075          --  is set to False (ARM D.10 par. 9).
1076
1077          if S.State then
1078             S.State := False;
1079          else
1080             S.Waiting := True;
1081             Result := pthread_cond_wait (S.CV'Access, S.L'Access);
1082          end if;
1083
1084          Result := pthread_mutex_unlock (S.L'Access);
1085          pragma Assert (Result = 0);
1086
1087          SSL.Abort_Undefer.all;
1088       end if;
1089    end Suspend_Until_True;
1090
1091    ----------------
1092    -- Check_Exit --
1093    ----------------
1094
1095    --  Dummy version
1096
1097    function Check_Exit (Self_ID : ST.Task_Id) return Boolean is
1098       pragma Unreferenced (Self_ID);
1099    begin
1100       return True;
1101    end Check_Exit;
1102
1103    --------------------
1104    -- Check_No_Locks --
1105    --------------------
1106
1107    function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is
1108       pragma Unreferenced (Self_ID);
1109    begin
1110       return True;
1111    end Check_No_Locks;
1112
1113    ----------------------
1114    -- Environment_Task --
1115    ----------------------
1116
1117    function Environment_Task return Task_Id is
1118    begin
1119       return Environment_Task_Id;
1120    end Environment_Task;
1121
1122    --------------
1123    -- Lock_RTS --
1124    --------------
1125
1126    procedure Lock_RTS is
1127    begin
1128       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
1129    end Lock_RTS;
1130
1131    ----------------
1132    -- Unlock_RTS --
1133    ----------------
1134
1135    procedure Unlock_RTS is
1136    begin
1137       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
1138    end Unlock_RTS;
1139
1140    ------------------
1141    -- Suspend_Task --
1142    ------------------
1143
1144    function Suspend_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 Suspend_Task;
1153
1154    -----------------
1155    -- Resume_Task --
1156    -----------------
1157
1158    function Resume_Task
1159      (T           : ST.Task_Id;
1160       Thread_Self : Thread_Id) return Boolean
1161    is
1162       pragma Unreferenced (T);
1163       pragma Unreferenced (Thread_Self);
1164    begin
1165       return False;
1166    end Resume_Task;
1167
1168    ----------------
1169    -- Initialize --
1170    ----------------
1171
1172    procedure Initialize (Environment_Task : Task_Id) is
1173    begin
1174       Environment_Task_Id := Environment_Task;
1175
1176       SSL.Get_Exc_Stack_Addr := Get_Exc_Stack_Addr'Access;
1177
1178       --  Initialize the lock used to synchronize chain of all ATCBs
1179
1180       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1181
1182       Specific.Initialize (Environment_Task);
1183
1184       Enter_Task (Environment_Task);
1185    end Initialize;
1186
1187 end System.Task_Primitives.Operations;