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