gcc/ada/5vtaprop.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNU ADA 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-2003, 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 Interfaces.C;
  47 --  used for int
  48 --           size_t
  49
  50 with System.Parameters;
  51 --  used for Size_Type
  52
  53 with System.Tasking;
  54 --  used for Ada_Task_Control_Block
  55 --           Task_ID
  56
  57 with System.Soft_Links;
  58 --  used for Defer/Undefer_Abort
  59 --           Set_Exc_Stack_Addr
  60
  61 --  Note that we do not use System.Tasking.Initialization directly since
  62 --  this is a higher level package that we shouldn't depend on. For example
  63 --  when using the restricted run time, it is replaced by
  64 --  System.Tasking.Restricted.Initialization
  65
  66 with System.OS_Primitives;
  67 --  used for Delay_Modes
  68
  69 with Unchecked_Conversion;
  70 with Unchecked_Deallocation;
  71
  72 package body System.Task_Primitives.Operations is
  73
  74    use System.Tasking.Debug;
  75    use System.Tasking;
  76    use Interfaces.C;
  77    use System.OS_Interface;
  78    use System.Parameters;
  79    use System.OS_Primitives;
  80    use type System.OS_Primitives.OS_Time;
  81
  82    package SSL renames System.Soft_Links;
  83
  84    ------------------
  85    --  Local Data  --
  86    ------------------
  87
  88    --  The followings are logically constants, but need to be initialized
  89    --  at run time.
  90
  91    Single_RTS_Lock : aliased RTS_Lock;
  92    --  This is a lock to allow only one thread of control in the RTS at
  93    --  a time; it is used to execute in mutual exclusion from all other tasks.
  94    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
  95
  96    ATCB_Key : aliased pthread_key_t;
  97    --  Key used to find the Ada Task_ID associated with a thread
  98
  99    Environment_Task_ID : Task_ID;
 100    --  A variable to hold Task_ID for the environment task.
 101
 102    Time_Slice_Val : Integer;
 103    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 104
 105    Dispatching_Policy : Character;
 106    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 107
 108    FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
 109    --  Indicates whether FIFO_Within_Priorities is set.
 110
 111    Foreign_Task_Elaborated : aliased Boolean := True;
 112    --  Used to identified fake tasks (i.e., non-Ada Threads).
 113
 114    --------------------
 115    -- Local Packages --
 116    --------------------
 117
 118    package Specific is
 119
 120       procedure Initialize (Environment_Task : Task_ID);
 121       pragma Inline (Initialize);
 122       --  Initialize various data needed by this package.
 123
 124       function Is_Valid_Task return Boolean;
 125       pragma Inline (Is_Valid_Task);
 126       --  Does executing thread have a TCB?
 127
 128       procedure Set (Self_Id : Task_ID);
 129       pragma Inline (Set);
 130       --  Set the self id for the current task.
 131
 132       function Self return Task_ID;
 133       pragma Inline (Self);
 134       --  Return a pointer to the Ada Task Control Block of the calling task.
 135
 136    end Specific;
 137
 138    package body Specific is separate;
 139    --  The body of this package is target specific.
 140
 141    ---------------------------------
 142    -- Support for foreign threads --
 143    ---------------------------------
 144
 145    function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
 146    --  Allocate and Initialize a new ATCB for the current Thread.
 147
 148    function Register_Foreign_Thread
 149      (Thread : Thread_Id) return Task_ID is separate;
 150
 151    -----------------------
 152    -- Local Subprograms --
 153    -----------------------
 154
 155    function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
 156
 157    function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
 158
 159    procedure Timer_Sleep_AST (ID : Address);
 160    --  Signal the condition variable when AST fires.
 161
 162    procedure Timer_Sleep_AST (ID : Address) is
 163       Result     : Interfaces.C.int;
 164       Self_ID    : Task_ID := To_Task_ID (ID);
 165
 166    begin
 167       Self_ID.Common.LL.AST_Pending := False;
 168       Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
 169    end Timer_Sleep_AST;
 170
 171    -------------------
 172    --  Stack_Guard  --
 173    -------------------
 174
 175    --  The underlying thread system sets a guard page at the
 176    --  bottom of a thread stack, so nothing is needed.
 177    --  ??? Check the comment above
 178
 179    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
 180       pragma Unreferenced (T);
 181       pragma Unreferenced (On);
 182
 183    begin
 184       null;
 185    end Stack_Guard;
 186
 187    --------------------
 188    -- Get_Thread_Id  --
 189    --------------------
 190
 191    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
 192    begin
 193       return T.Common.LL.Thread;
 194    end Get_Thread_Id;
 195
 196    ----------
 197    -- Self --
 198    ----------
 199
 200    function Self return Task_ID renames Specific.Self;
 201
 202    ---------------------
 203    -- Initialize_Lock --
 204    ---------------------
 205
 206    --  Note: mutexes and cond_variables needed per-task basis are
 207    --  initialized in Initialize_TCB and the Storage_Error is
 208    --  handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 209    --  used in RTS is initialized before any status change of RTS.
 210    --  Therefore rasing Storage_Error in the following routines
 211    --  should be able to be handled safely.
 212
 213    procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
 214       Attributes : aliased pthread_mutexattr_t;
 215       Result     : Interfaces.C.int;
 216
 217    begin
 218       Result := pthread_mutexattr_init (Attributes'Access);
 219       pragma Assert (Result = 0 or else Result = ENOMEM);
 220
 221       if Result = ENOMEM then
 222          raise Storage_Error;
 223       end if;
 224
 225       L.Prio_Save := 0;
 226       L.Prio := Interfaces.C.int (Prio);
 227
 228       Result := pthread_mutex_init (L.L'Access, Attributes'Access);
 229       pragma Assert (Result = 0 or else Result = ENOMEM);
 230
 231       if Result = ENOMEM then
 232          raise Storage_Error;
 233       end if;
 234
 235       Result := pthread_mutexattr_destroy (Attributes'Access);
 236       pragma Assert (Result = 0);
 237    end Initialize_Lock;
 238
 239    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 240       pragma Unreferenced (Level);
 241
 242       Attributes : aliased pthread_mutexattr_t;
 243       Result : Interfaces.C.int;
 244
 245    begin
 246       Result := pthread_mutexattr_init (Attributes'Access);
 247       pragma Assert (Result = 0 or else Result = ENOMEM);
 248
 249       if Result = ENOMEM then
 250          raise Storage_Error;
 251       end if;
 252
 253 --      Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes???
 254 --      Result := pthread_mutexattr_settype_np
 255 --        (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP);
 256 --      pragma Assert (Result = 0);
 257
 258 --      Result := pthread_mutexattr_setprotocol
 259 --        (Attributes'Access, PTHREAD_PRIO_PROTECT);
 260 --      pragma Assert (Result = 0);
 261
 262 --      Result := pthread_mutexattr_setprioceiling
 263 --         (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
 264 --      pragma Assert (Result = 0);
 265
 266       Result := pthread_mutex_init (L, Attributes'Access);
 267
 268       pragma Assert (Result = 0 or else Result = ENOMEM);
 269
 270       if Result = ENOMEM then
 271          raise Storage_Error;
 272       end if;
 273
 274       Result := pthread_mutexattr_destroy (Attributes'Access);
 275       pragma Assert (Result = 0);
 276    end Initialize_Lock;
 277
 278    -------------------
 279    -- Finalize_Lock --
 280    -------------------
 281
 282    procedure Finalize_Lock (L : access Lock) is
 283       Result : Interfaces.C.int;
 284
 285    begin
 286       Result := pthread_mutex_destroy (L.L'Access);
 287       pragma Assert (Result = 0);
 288    end Finalize_Lock;
 289
 290    procedure Finalize_Lock (L : access RTS_Lock) is
 291       Result : Interfaces.C.int;
 292
 293    begin
 294       Result := pthread_mutex_destroy (L);
 295       pragma Assert (Result = 0);
 296    end Finalize_Lock;
 297
 298    ----------------
 299    -- Write_Lock --
 300    ----------------
 301
 302    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 303       Self_ID        : constant Task_ID := Self;
 304       All_Tasks_Link : constant Task_ID := Self.Common.All_Tasks_Link;
 305       Current_Prio   : System.Any_Priority;
 306       Result         : Interfaces.C.int;
 307
 308    begin
 309       Current_Prio := Get_Priority (Self_ID);
 310
 311       --  If there is no other tasks, no need to check priorities.
 312
 313       if All_Tasks_Link /= Null_Task
 314         and then L.Prio < Interfaces.C.int (Current_Prio)
 315       then
 316          Ceiling_Violation := True;
 317          return;
 318       end if;
 319
 320       Result := pthread_mutex_lock (L.L'Access);
 321       pragma Assert (Result = 0);
 322
 323       Ceiling_Violation := False;
 324 --  Why is this commented out ???
 325 --      L.Prio_Save := Interfaces.C.int (Current_Prio);
 326 --      Set_Priority (Self_ID, System.Any_Priority (L.Prio));
 327    end Write_Lock;
 328
 329    procedure Write_Lock
 330      (L           : access RTS_Lock;
 331       Global_Lock : Boolean := False)
 332    is
 333       Result : Interfaces.C.int;
 334
 335    begin
 336       if not Single_Lock or else Global_Lock then
 337          Result := pthread_mutex_lock (L);
 338          pragma Assert (Result = 0);
 339       end if;
 340    end Write_Lock;
 341
 342    procedure Write_Lock (T : Task_ID) is
 343       Result : Interfaces.C.int;
 344
 345    begin
 346       if not Single_Lock then
 347          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 348          pragma Assert (Result = 0);
 349       end if;
 350    end Write_Lock;
 351
 352    ---------------
 353    -- Read_Lock --
 354    ---------------
 355
 356    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 357    begin
 358       Write_Lock (L, Ceiling_Violation);
 359    end Read_Lock;
 360
 361    ------------
 362    -- Unlock --
 363    ------------
 364
 365    procedure Unlock (L : access Lock) is
 366       Result : Interfaces.C.int;
 367
 368    begin
 369       Result := pthread_mutex_unlock (L.L'Access);
 370       pragma Assert (Result = 0);
 371    end Unlock;
 372
 373    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 374       Result : Interfaces.C.int;
 375
 376    begin
 377       if not Single_Lock or else Global_Lock then
 378          Result := pthread_mutex_unlock (L);
 379          pragma Assert (Result = 0);
 380       end if;
 381    end Unlock;
 382
 383    procedure Unlock (T : Task_ID) is
 384       Result : Interfaces.C.int;
 385
 386    begin
 387       if not Single_Lock then
 388          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 389          pragma Assert (Result = 0);
 390       end if;
 391    end Unlock;
 392
 393    -----------
 394    -- Sleep --
 395    -----------
 396
 397    procedure Sleep
 398      (Self_ID : Task_ID;
 399       Reason  : System.Tasking.Task_States)
 400    is
 401       pragma Unreferenced (Reason);
 402       Result : Interfaces.C.int;
 403
 404    begin
 405       if Single_Lock then
 406          Result := pthread_cond_wait
 407            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 408       else
 409          Result := pthread_cond_wait
 410            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 411       end if;
 412
 413       --  EINTR is not considered a failure.
 414
 415       pragma Assert (Result = 0 or else Result = EINTR);
 416
 417       if Self_ID.Deferral_Level = 0
 418         and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 419       then
 420          Unlock (Self_ID);
 421          raise Standard'Abort_Signal;
 422       end if;
 423    end Sleep;
 424
 425    -----------------
 426    -- Timed_Sleep --
 427    -----------------
 428
 429    procedure Timed_Sleep
 430      (Self_ID  : Task_ID;
 431       Time     : Duration;
 432       Mode     : ST.Delay_Modes;
 433       Reason   : System.Tasking.Task_States;
 434       Timedout : out Boolean;
 435       Yielded  : out Boolean)
 436    is
 437       pragma Unreferenced (Reason);
 438
 439       Sleep_Time : OS_Time;
 440       Result     : Interfaces.C.int;
 441       Status     : Cond_Value_Type;
 442
 443    begin
 444       Timedout := False;
 445       Yielded := False;
 446
 447       Sleep_Time := To_OS_Time (Time, Mode);
 448
 449       if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 450         or else Self_ID.Pending_Priority_Change
 451       then
 452          return;
 453       end if;
 454
 455       Self_ID.Common.LL.AST_Pending := True;
 456
 457       Sys_Setimr
 458        (Status, 0, Sleep_Time,
 459         Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
 460
 461       if (Status and 1) /= 1 then
 462          raise Storage_Error;
 463       end if;
 464
 465       if Single_Lock then
 466          Result := pthread_cond_wait
 467            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 468
 469       else
 470          Result := pthread_cond_wait
 471            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 472       end if;
 473
 474       Yielded := True;
 475
 476       if not Self_ID.Common.LL.AST_Pending then
 477          Timedout := True;
 478       else
 479          Sys_Cantim (Status, To_Address (Self_ID), 0);
 480          pragma Assert ((Status and 1) = 1);
 481       end if;
 482    end Timed_Sleep;
 483
 484    -----------------
 485    -- Timed_Delay --
 486    -----------------
 487
 488    procedure Timed_Delay
 489      (Self_ID : Task_ID;
 490       Time    : Duration;
 491       Mode    : ST.Delay_Modes)
 492    is
 493       Sleep_Time : OS_Time;
 494       Result     : Interfaces.C.int;
 495       Status     : Cond_Value_Type;
 496       Yielded    : Boolean := False;
 497
 498    begin
 499       --  Only the little window between deferring abort and
 500       --  locking Self_ID is the reason we need to
 501       --  check for pending abort and priority change below!
 502
 503       if Single_Lock then
 504          Lock_RTS;
 505       end if;
 506
 507       SSL.Abort_Defer.all;
 508       Write_Lock (Self_ID);
 509
 510       if Time /= 0.0 or else Mode /= Relative then
 511          Sleep_Time := To_OS_Time (Time, Mode);
 512
 513          if Mode = Relative or else OS_Clock < Sleep_Time then
 514             Self_ID.Common.State := Delay_Sleep;
 515             Self_ID.Common.LL.AST_Pending := True;
 516
 517             Sys_Setimr
 518              (Status, 0, Sleep_Time,
 519               Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
 520
 521             if (Status and 1) /= 1 then
 522                raise Storage_Error;
 523             end if;
 524
 525             loop
 526                if Self_ID.Pending_Priority_Change then
 527                   Self_ID.Pending_Priority_Change := False;
 528                   Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 529                   Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 530                end if;
 531
 532                if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then
 533                   Sys_Cantim (Status, To_Address (Self_ID), 0);
 534                   pragma Assert ((Status and 1) = 1);
 535                   exit;
 536                end if;
 537
 538                if Single_Lock then
 539                   Result := pthread_cond_wait
 540                     (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 541                else
 542                   Result := pthread_cond_wait
 543                     (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 544                end if;
 545
 546                Yielded := True;
 547
 548                exit when not Self_ID.Common.LL.AST_Pending;
 549             end loop;
 550
 551             Self_ID.Common.State := Runnable;
 552          end if;
 553       end if;
 554
 555       Unlock (Self_ID);
 556
 557       if Single_Lock then
 558          Unlock_RTS;
 559       end if;
 560
 561       if not Yielded then
 562          Result := sched_yield;
 563       end if;
 564
 565       SSL.Abort_Undefer.all;
 566    end Timed_Delay;
 567
 568    ---------------------
 569    -- Monotonic_Clock --
 570    ---------------------
 571
 572    function Monotonic_Clock return Duration
 573      renames System.OS_Primitives.Monotonic_Clock;
 574
 575    -------------------
 576    -- RT_Resolution --
 577    -------------------
 578
 579    function RT_Resolution return Duration is
 580    begin
 581       return 10#1.0#E-3;
 582    end RT_Resolution;
 583
 584    ------------
 585    -- Wakeup --
 586    ------------
 587
 588    procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
 589       pragma Unreferenced (Reason);
 590
 591       Result : Interfaces.C.int;
 592
 593    begin
 594       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 595       pragma Assert (Result = 0);
 596    end Wakeup;
 597
 598    -----------
 599    -- Yield --
 600    -----------
 601
 602    procedure Yield (Do_Yield : Boolean := True) is
 603       Result : Interfaces.C.int;
 604
 605    begin
 606       if Do_Yield then
 607          Result := sched_yield;
 608       end if;
 609    end Yield;
 610
 611    ------------------
 612    -- Set_Priority --
 613    ------------------
 614
 615    procedure Set_Priority
 616      (T                   : Task_ID;
 617       Prio                : System.Any_Priority;
 618       Loss_Of_Inheritance : Boolean := False)
 619    is
 620       pragma Unreferenced (Loss_Of_Inheritance);
 621
 622       Result : Interfaces.C.int;
 623       Param  : aliased struct_sched_param;
 624
 625    begin
 626       T.Common.Current_Priority := Prio;
 627       Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
 628
 629       if Time_Slice_Val > 0 then
 630          Result := pthread_setschedparam
 631            (T.Common.LL.Thread, SCHED_RR, Param'Access);
 632
 633       elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
 634          Result := pthread_setschedparam
 635            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 636
 637       else
 638          --  SCHED_OTHER priorities are restricted to the range 8 - 15.
 639          --  Since the translation from Underlying priorities results
 640          --  in a range of 16 - 31, dividing by 2 gives the correct result.
 641
 642          Param.sched_priority := Param.sched_priority / 2;
 643          Result := pthread_setschedparam
 644            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 645       end if;
 646
 647       pragma Assert (Result = 0);
 648    end Set_Priority;
 649
 650    ------------------
 651    -- Get_Priority --
 652    ------------------
 653
 654    function Get_Priority (T : Task_ID) return System.Any_Priority is
 655    begin
 656       return T.Common.Current_Priority;
 657    end Get_Priority;
 658
 659    ----------------
 660    -- Enter_Task --
 661    ----------------
 662
 663    procedure Enter_Task (Self_ID : Task_ID) is
 664    begin
 665       Self_ID.Common.LL.Thread := pthread_self;
 666
 667       Specific.Set (Self_ID);
 668
 669       Lock_RTS;
 670
 671       for J in Known_Tasks'Range loop
 672          if Known_Tasks (J) = null then
 673             Known_Tasks (J) := Self_ID;
 674             Self_ID.Known_Tasks_Index := J;
 675             exit;
 676          end if;
 677       end loop;
 678
 679       Unlock_RTS;
 680    end Enter_Task;
 681
 682    --------------
 683    -- New_ATCB --
 684    --------------
 685
 686    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 687    begin
 688       return new Ada_Task_Control_Block (Entry_Num);
 689    end New_ATCB;
 690
 691    -------------------
 692    -- Is_Valid_Task --
 693    -------------------
 694
 695    function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
 696
 697    -----------------------------
 698    -- Register_Foreign_Thread --
 699    -----------------------------
 700
 701    function Register_Foreign_Thread return Task_ID is
 702    begin
 703       if Is_Valid_Task then
 704          return Self;
 705       else
 706          return Register_Foreign_Thread (pthread_self);
 707       end if;
 708    end Register_Foreign_Thread;
 709
 710    ----------------------
 711    --  Initialize_TCB  --
 712    ----------------------
 713
 714    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 715       Mutex_Attr   : aliased pthread_mutexattr_t;
 716       Result       : Interfaces.C.int;
 717       Cond_Attr    : aliased pthread_condattr_t;
 718
 719    begin
 720       if not Single_Lock then
 721          Result := pthread_mutexattr_init (Mutex_Attr'Access);
 722          pragma Assert (Result = 0 or else Result = ENOMEM);
 723
 724          if Result = 0 then
 725             Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
 726               Mutex_Attr'Access);
 727             pragma Assert (Result = 0 or else Result = ENOMEM);
 728          end if;
 729
 730          if Result /= 0 then
 731             Succeeded := False;
 732             return;
 733          end if;
 734
 735          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 736          pragma Assert (Result = 0);
 737       end if;
 738
 739       Result := pthread_condattr_init (Cond_Attr'Access);
 740       pragma Assert (Result = 0 or else Result = ENOMEM);
 741
 742       if Result = 0 then
 743          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 744            Cond_Attr'Access);
 745          pragma Assert (Result = 0 or else Result = ENOMEM);
 746       end if;
 747
 748       if Result = 0 then
 749          Succeeded := True;
 750          Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T;
 751          SSL.Set_Exc_Stack_Addr
 752            (To_Address (Self_ID),
 753             Self_ID.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address);
 754
 755       else
 756          if not Single_Lock then
 757             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 758             pragma Assert (Result = 0);
 759          end if;
 760
 761          Succeeded := False;
 762       end if;
 763
 764       Result := pthread_condattr_destroy (Cond_Attr'Access);
 765       pragma Assert (Result = 0);
 766    end Initialize_TCB;
 767
 768    -----------------
 769    -- Create_Task --
 770    -----------------
 771
 772    procedure Create_Task
 773      (T          : Task_ID;
 774       Wrapper    : System.Address;
 775       Stack_Size : System.Parameters.Size_Type;
 776       Priority   : System.Any_Priority;
 777       Succeeded  : out Boolean)
 778    is
 779       Attributes          : aliased pthread_attr_t;
 780       Adjusted_Stack_Size : Interfaces.C.size_t;
 781       Result              : Interfaces.C.int;
 782
 783       function Thread_Body_Access is new
 784         Unchecked_Conversion (System.Address, Thread_Body);
 785
 786    begin
 787       if Stack_Size = Unspecified_Size then
 788          Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
 789
 790       elsif Stack_Size < Minimum_Stack_Size then
 791          Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
 792
 793       else
 794          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 795       end if;
 796
 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, Adjusted_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          Result := pthread_setspecific (ATCB_Key, System.Null_Address);
 880          pragma Assert (Result = 0);
 881       end if;
 882    end Finalize_TCB;
 883
 884    ---------------
 885    -- Exit_Task --
 886    ---------------
 887
 888    procedure Exit_Task is
 889    begin
 890       Specific.Set (null);
 891    end Exit_Task;
 892
 893    ----------------
 894    -- Abort_Task --
 895    ----------------
 896
 897    procedure Abort_Task (T : Task_ID) is
 898    begin
 899       --  Interrupt Server_Tasks may be waiting on an event flag
 900
 901       if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
 902          Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag);
 903       end if;
 904    end Abort_Task;
 905
 906    ----------------
 907    -- Check_Exit --
 908    ----------------
 909
 910    --  Dummy version
 911
 912    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 913       pragma Unreferenced (Self_ID);
 914
 915    begin
 916       return True;
 917    end Check_Exit;
 918
 919    --------------------
 920    -- Check_No_Locks --
 921    --------------------
 922
 923    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 924       pragma Unreferenced (Self_ID);
 925
 926    begin
 927       return True;
 928    end Check_No_Locks;
 929
 930    ----------------------
 931    -- Environment_Task --
 932    ----------------------
 933
 934    function Environment_Task return Task_ID is
 935    begin
 936       return Environment_Task_ID;
 937    end Environment_Task;
 938
 939    --------------
 940    -- Lock_RTS --
 941    --------------
 942
 943    procedure Lock_RTS is
 944    begin
 945       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 946    end Lock_RTS;
 947
 948    ----------------
 949    -- Unlock_RTS --
 950    ----------------
 951
 952    procedure Unlock_RTS is
 953    begin
 954       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 955    end Unlock_RTS;
 956
 957    ------------------
 958    -- Suspend_Task --
 959    ------------------
 960
 961    function Suspend_Task
 962      (T           : ST.Task_ID;
 963       Thread_Self : Thread_Id)
 964       return        Boolean
 965    is
 966       pragma Unreferenced (T);
 967       pragma Unreferenced (Thread_Self);
 968
 969    begin
 970       return False;
 971    end Suspend_Task;
 972
 973    -----------------
 974    -- Resume_Task --
 975    -----------------
 976
 977    function Resume_Task
 978      (T           : ST.Task_ID;
 979       Thread_Self : Thread_Id)
 980       return        Boolean
 981    is
 982       pragma Unreferenced (T);
 983       pragma Unreferenced (Thread_Self);
 984
 985    begin
 986       return False;
 987    end Resume_Task;
 988
 989    ----------------
 990    -- Initialize --
 991    ----------------
 992
 993    procedure Initialize (Environment_Task : Task_ID) is
 994    begin
 995       Environment_Task_ID := Environment_Task;
 996
 997       --  Initialize the lock used to synchronize chain of all ATCBs.
 998
 999       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
1000
1001       Specific.Initialize (Environment_Task);
1002
1003       Enter_Task (Environment_Task);
1004    end Initialize;
1005
1006 end System.Task_Primitives.Operations;