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