gcc/ada/s-taprop-vms.adb

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