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