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