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