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 --                                                                          --
  10 --         Copyright (C) 1992-2001, Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNARL was developed by the GNARL team at Florida State University. It is --
  31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com).     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This is a OpenVMS/Alpha version of this package
  36
  37 --  This package contains all the GNULL primitives that interface directly
  38 --  with the underlying OS.
  39
  40 pragma Polling (Off);
  41 --  Turn off polling, we do not want ATC polling to take place during
  42 --  tasking operations. It causes infinite loops and other problems.
  43
  44 with System.Tasking.Debug;
  45 --  used for Known_Tasks
  46
  47 with Interfaces.C;
  48 --  used for int
  49 --           size_t
  50
  51 with System.Parameters;
  52 --  used for Size_Type
  53
  54 with System.Tasking;
  55 --  used for Ada_Task_Control_Block
  56 --           Task_ID
  57
  58 with System.Soft_Links;
  59 --  used for Defer/Undefer_Abort
  60 --           Set_Exc_Stack_Addr
  61
  62 --  Note that we do not use System.Tasking.Initialization directly since
  63 --  this is a higher level package that we shouldn't depend on. For example
  64 --  when using the restricted run time, it is replaced by
  65 --  System.Tasking.Restricted.Initialization
  66
  67 with System.OS_Primitives;
  68 --  used for Delay_Modes
  69
  70 with Unchecked_Conversion;
  71 with Unchecked_Deallocation;
  72
  73 package body System.Task_Primitives.Operations is
  74
  75    use System.Tasking.Debug;
  76    use System.Tasking;
  77    use Interfaces.C;
  78    use System.OS_Interface;
  79    use System.Parameters;
  80    use System.OS_Primitives;
  81    use type System.OS_Primitives.OS_Time;
  82
  83    package SSL renames System.Soft_Links;
  84
  85    ------------------
  86    --  Local Data  --
  87    ------------------
  88
  89    --  The followings are logically constants, but need to be initialized
  90    --  at run time.
  91
  92    ATCB_Key : aliased pthread_key_t;
  93    --  Key used to find the Ada Task_ID associated with a thread
  94
  95    Single_RTS_Lock : aliased RTS_Lock;
  96    --  This is a lock to allow only one thread of control in the RTS at
  97    --  a time; it is used to execute in mutual exclusion from all other tasks.
  98    --  Used mainly in Single_Lock mode, but also to protect All_Tasks_List
  99
 100    Environment_Task_ID : Task_ID;
 101    --  A variable to hold Task_ID for the environment task.
 102
 103    Time_Slice_Val : Integer;
 104    pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
 105
 106    Dispatching_Policy : Character;
 107    pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
 108
 109    FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
 110    --  Indicates whether FIFO_Within_Priorities is set.
 111
 112    -----------------------
 113    -- Local Subprograms --
 114    -----------------------
 115
 116    function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
 117
 118    function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
 119
 120    procedure Timer_Sleep_AST (ID : Address);
 121    --  Signal the condition variable when AST fires.
 122
 123    procedure Timer_Sleep_AST (ID : Address) is
 124       Result     : Interfaces.C.int;
 125       Self_ID    : Task_ID := To_Task_ID (ID);
 126
 127    begin
 128       Self_ID.Common.LL.AST_Pending := False;
 129       Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access);
 130    end Timer_Sleep_AST;
 131
 132    -------------------
 133    --  Stack_Guard  --
 134    -------------------
 135
 136    --  The underlying thread system sets a guard page at the
 137    --  bottom of a thread stack, so nothing is needed.
 138    --  ??? Check the comment above
 139
 140    procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
 141    begin
 142       null;
 143    end Stack_Guard;
 144
 145    --------------------
 146    -- Get_Thread_Id  --
 147    --------------------
 148
 149    function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
 150    begin
 151       return T.Common.LL.Thread;
 152    end Get_Thread_Id;
 153
 154    ----------
 155    -- Self --
 156    ----------
 157
 158    function Self return Task_ID is
 159       Result : System.Address;
 160
 161    begin
 162       Result := pthread_getspecific (ATCB_Key);
 163       pragma Assert (Result /= System.Null_Address);
 164       return To_Task_ID (Result);
 165    end Self;
 166
 167    ---------------------
 168    -- Initialize_Lock --
 169    ---------------------
 170
 171    --  Note: mutexes and cond_variables needed per-task basis are
 172    --        initialized in Initialize_TCB and the Storage_Error is
 173    --        handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
 174    --        used in RTS is initialized before any status change of RTS.
 175    --        Therefore rasing Storage_Error in the following routines
 176    --        should be able to be handled safely.
 177
 178    procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
 179       Attributes : aliased pthread_mutexattr_t;
 180       Result     : Interfaces.C.int;
 181
 182    begin
 183       Result := pthread_mutexattr_init (Attributes'Access);
 184       pragma Assert (Result = 0 or else Result = ENOMEM);
 185
 186       if Result = ENOMEM then
 187          raise Storage_Error;
 188       end if;
 189
 190       L.Prio_Save := 0;
 191       L.Prio := Interfaces.C.int (Prio);
 192
 193       Result := pthread_mutex_init (L.L'Access, Attributes'Access);
 194       pragma Assert (Result = 0 or else Result = ENOMEM);
 195
 196       if Result = ENOMEM then
 197          raise Storage_Error;
 198       end if;
 199
 200       Result := pthread_mutexattr_destroy (Attributes'Access);
 201       pragma Assert (Result = 0);
 202    end Initialize_Lock;
 203
 204    procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
 205       Attributes : aliased pthread_mutexattr_t;
 206       Result : Interfaces.C.int;
 207
 208    begin
 209       Result := pthread_mutexattr_init (Attributes'Access);
 210       pragma Assert (Result = 0 or else Result = ENOMEM);
 211
 212       if Result = ENOMEM then
 213          raise Storage_Error;
 214       end if;
 215
 216 --      Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes.
 217 --      Result := pthread_mutexattr_settype_np
 218 --        (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP);
 219 --      pragma Assert (Result = 0);
 220
 221 --      Result := pthread_mutexattr_setprotocol
 222 --        (Attributes'Access, PTHREAD_PRIO_PROTECT);
 223 --      pragma Assert (Result = 0);
 224
 225 --      Result := pthread_mutexattr_setprioceiling
 226 --         (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
 227 --      pragma Assert (Result = 0);
 228
 229       Result := pthread_mutex_init (L, Attributes'Access);
 230
 231       pragma Assert (Result = 0 or else Result = ENOMEM);
 232
 233       if Result = ENOMEM then
 234          raise Storage_Error;
 235       end if;
 236
 237       Result := pthread_mutexattr_destroy (Attributes'Access);
 238       pragma Assert (Result = 0);
 239    end Initialize_Lock;
 240
 241    -------------------
 242    -- Finalize_Lock --
 243    -------------------
 244
 245    procedure Finalize_Lock (L : access Lock) is
 246       Result : Interfaces.C.int;
 247    begin
 248       Result := pthread_mutex_destroy (L.L'Access);
 249       pragma Assert (Result = 0);
 250    end Finalize_Lock;
 251
 252    procedure Finalize_Lock (L : access RTS_Lock) is
 253       Result : Interfaces.C.int;
 254    begin
 255       Result := pthread_mutex_destroy (L);
 256       pragma Assert (Result = 0);
 257    end Finalize_Lock;
 258
 259    ----------------
 260    -- Write_Lock --
 261    ----------------
 262
 263    procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 264       Self_ID        : constant Task_ID := Self;
 265       All_Tasks_Link : constant Task_ID := Self.Common.All_Tasks_Link;
 266       Current_Prio   : System.Any_Priority;
 267       Result         : Interfaces.C.int;
 268
 269    begin
 270       Current_Prio := Get_Priority (Self_ID);
 271
 272       --  If there is no other tasks, no need to check priorities.
 273
 274       if All_Tasks_Link /= Null_Task
 275         and then L.Prio < Interfaces.C.int (Current_Prio)
 276       then
 277          Ceiling_Violation := True;
 278          return;
 279       end if;
 280
 281       Result := pthread_mutex_lock (L.L'Access);
 282       pragma Assert (Result = 0);
 283
 284       Ceiling_Violation := False;
 285 --  Why is this commented out ???
 286 --      L.Prio_Save := Interfaces.C.int (Current_Prio);
 287 --      Set_Priority (Self_ID, System.Any_Priority (L.Prio));
 288    end Write_Lock;
 289
 290    procedure Write_Lock
 291      (L : access RTS_Lock; Global_Lock : Boolean := False)
 292    is
 293       Result : Interfaces.C.int;
 294    begin
 295       if not Single_Lock or else Global_Lock then
 296          Result := pthread_mutex_lock (L);
 297          pragma Assert (Result = 0);
 298       end if;
 299    end Write_Lock;
 300
 301    procedure Write_Lock (T : Task_ID) is
 302       Result : Interfaces.C.int;
 303    begin
 304       if not Single_Lock then
 305          Result := pthread_mutex_lock (T.Common.LL.L'Access);
 306          pragma Assert (Result = 0);
 307       end if;
 308    end Write_Lock;
 309
 310    ---------------
 311    -- Read_Lock --
 312    ---------------
 313
 314    procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
 315    begin
 316       Write_Lock (L, Ceiling_Violation);
 317    end Read_Lock;
 318
 319    ------------
 320    -- Unlock --
 321    ------------
 322
 323    procedure Unlock (L : access Lock) is
 324       Result : Interfaces.C.int;
 325    begin
 326       Result := pthread_mutex_unlock (L.L'Access);
 327       pragma Assert (Result = 0);
 328    end Unlock;
 329
 330    procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
 331       Result : Interfaces.C.int;
 332    begin
 333       if not Single_Lock or else Global_Lock then
 334          Result := pthread_mutex_unlock (L);
 335          pragma Assert (Result = 0);
 336       end if;
 337    end Unlock;
 338
 339    procedure Unlock (T : Task_ID) is
 340       Result : Interfaces.C.int;
 341    begin
 342       if not Single_Lock then
 343          Result := pthread_mutex_unlock (T.Common.LL.L'Access);
 344          pragma Assert (Result = 0);
 345       end if;
 346    end Unlock;
 347
 348    -----------
 349    -- Sleep --
 350    -----------
 351
 352    procedure Sleep
 353      (Self_ID : Task_ID;
 354       Reason  : System.Tasking.Task_States)
 355    is
 356       Result : Interfaces.C.int;
 357    begin
 358       if Single_Lock then
 359          Result := pthread_cond_wait
 360            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 361       else
 362          Result := pthread_cond_wait
 363            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 364       end if;
 365
 366       --  EINTR is not considered a failure.
 367       pragma Assert (Result = 0 or else Result = EINTR);
 368
 369       if Self_ID.Deferral_Level = 0
 370         and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 371       then
 372          Unlock (Self_ID);
 373          raise Standard'Abort_Signal;
 374       end if;
 375    end Sleep;
 376
 377    -----------------
 378    -- Timed_Sleep --
 379    -----------------
 380
 381    procedure Timed_Sleep
 382      (Self_ID  : Task_ID;
 383       Time     : Duration;
 384       Mode     : ST.Delay_Modes;
 385       Reason   : System.Tasking.Task_States;
 386       Timedout : out Boolean;
 387       Yielded  : out Boolean)
 388    is
 389       Sleep_Time : OS_Time;
 390       Result     : Interfaces.C.int;
 391       Status     : Cond_Value_Type;
 392
 393    begin
 394       Timedout := False;
 395       Yielded := False;
 396
 397       Sleep_Time := To_OS_Time (Time, Mode);
 398
 399       if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 400         or else Self_ID.Pending_Priority_Change
 401       then
 402          return;
 403       end if;
 404
 405       Self_ID.Common.LL.AST_Pending := True;
 406
 407       Sys_Setimr
 408        (Status, 0, Sleep_Time,
 409         Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
 410
 411       if (Status and 1) /= 1 then
 412          raise Storage_Error;
 413       end if;
 414
 415       if Single_Lock then
 416          Result := pthread_cond_wait
 417            (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 418
 419       else
 420          Result := pthread_cond_wait
 421            (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 422       end if;
 423
 424       Yielded := True;
 425
 426       if not Self_ID.Common.LL.AST_Pending then
 427          Timedout := True;
 428       else
 429          Sys_Cantim (Status, To_Address (Self_ID), 0);
 430          pragma Assert ((Status and 1) = 1);
 431       end if;
 432    end Timed_Sleep;
 433
 434    -----------------
 435    -- Timed_Delay --
 436    -----------------
 437
 438    procedure Timed_Delay
 439      (Self_ID : Task_ID;
 440       Time    : Duration;
 441       Mode    : ST.Delay_Modes)
 442    is
 443       Sleep_Time : OS_Time;
 444       Result     : Interfaces.C.int;
 445       Status     : Cond_Value_Type;
 446       Yielded    : Boolean := False;
 447
 448    begin
 449       --  Only the little window between deferring abort and
 450       --  locking Self_ID is the reason we need to
 451       --  check for pending abort and priority change below!
 452
 453       if Single_Lock then
 454          Lock_RTS;
 455       end if;
 456
 457       SSL.Abort_Defer.all;
 458       Write_Lock (Self_ID);
 459
 460       if Time /= 0.0 or else Mode /= Relative then
 461          Sleep_Time := To_OS_Time (Time, Mode);
 462
 463          if Mode = Relative or else OS_Clock < Sleep_Time then
 464             Self_ID.Common.State := Delay_Sleep;
 465             Self_ID.Common.LL.AST_Pending := True;
 466
 467             Sys_Setimr
 468              (Status, 0, Sleep_Time,
 469               Timer_Sleep_AST'Access, To_Address (Self_ID), 0);
 470
 471             if (Status and 1) /= 1 then
 472                raise Storage_Error;
 473             end if;
 474
 475             loop
 476                if Self_ID.Pending_Priority_Change then
 477                   Self_ID.Pending_Priority_Change := False;
 478                   Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 479                   Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 480                end if;
 481
 482                if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then
 483                   Sys_Cantim (Status, To_Address (Self_ID), 0);
 484                   pragma Assert ((Status and 1) = 1);
 485                   exit;
 486                end if;
 487
 488                if Single_Lock then
 489                   Result := pthread_cond_wait
 490                     (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
 491                else
 492                   Result := pthread_cond_wait
 493                     (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
 494                end if;
 495
 496                Yielded := True;
 497
 498                exit when not Self_ID.Common.LL.AST_Pending;
 499             end loop;
 500
 501             Self_ID.Common.State := Runnable;
 502          end if;
 503       end if;
 504
 505       Unlock (Self_ID);
 506
 507       if Single_Lock then
 508          Unlock_RTS;
 509       end if;
 510
 511       if not Yielded then
 512          Result := sched_yield;
 513       end if;
 514
 515       SSL.Abort_Undefer.all;
 516    end Timed_Delay;
 517
 518    ---------------------
 519    -- Monotonic_Clock --
 520    ---------------------
 521
 522    function Monotonic_Clock return Duration
 523      renames System.OS_Primitives.Monotonic_Clock;
 524
 525    -------------------
 526    -- RT_Resolution --
 527    -------------------
 528
 529    function RT_Resolution return Duration is
 530    begin
 531       return 10#1.0#E-3;
 532    end RT_Resolution;
 533
 534    ------------
 535    -- Wakeup --
 536    ------------
 537
 538    procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
 539       Result : Interfaces.C.int;
 540    begin
 541       Result := pthread_cond_signal (T.Common.LL.CV'Access);
 542       pragma Assert (Result = 0);
 543    end Wakeup;
 544
 545    -----------
 546    -- Yield --
 547    -----------
 548
 549    procedure Yield (Do_Yield : Boolean := True) is
 550       Result : Interfaces.C.int;
 551    begin
 552       if Do_Yield then
 553          Result := sched_yield;
 554       end if;
 555    end Yield;
 556
 557    ------------------
 558    -- Set_Priority --
 559    ------------------
 560
 561    procedure Set_Priority
 562      (T                   : Task_ID;
 563       Prio                : System.Any_Priority;
 564       Loss_Of_Inheritance : Boolean := False)
 565    is
 566       Result : Interfaces.C.int;
 567       Param  : aliased struct_sched_param;
 568    begin
 569       T.Common.Current_Priority := Prio;
 570       Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
 571
 572       if Time_Slice_Val > 0 then
 573          Result := pthread_setschedparam
 574            (T.Common.LL.Thread, SCHED_RR, Param'Access);
 575
 576       elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
 577          Result := pthread_setschedparam
 578            (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
 579
 580       else
 581          Result := pthread_setschedparam
 582            (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
 583       end if;
 584
 585       pragma Assert (Result = 0);
 586    end Set_Priority;
 587
 588    ------------------
 589    -- Get_Priority --
 590    ------------------
 591
 592    function Get_Priority (T : Task_ID) return System.Any_Priority is
 593    begin
 594       return T.Common.Current_Priority;
 595    end Get_Priority;
 596
 597    ----------------
 598    -- Enter_Task --
 599    ----------------
 600
 601    procedure Enter_Task (Self_ID : Task_ID) is
 602       Result  : Interfaces.C.int;
 603    begin
 604       Self_ID.Common.LL.Thread := pthread_self;
 605
 606       --  It is not safe for the new task accept signals until it
 607       --  has bound its TCB pointer to the thread with pthread_setspecific (),
 608       --  since the handler wrappers use the TCB pointer
 609       --  to restore the stack limit.
 610
 611       Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
 612       pragma Assert (Result = 0);
 613
 614       Lock_RTS;
 615
 616       for J in Known_Tasks'Range loop
 617          if Known_Tasks (J) = null then
 618             Known_Tasks (J) := Self_ID;
 619             Self_ID.Known_Tasks_Index := J;
 620             exit;
 621          end if;
 622       end loop;
 623
 624       Unlock_RTS;
 625    end Enter_Task;
 626
 627    --------------
 628    -- New_ATCB --
 629    --------------
 630
 631    function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
 632    begin
 633       return new Ada_Task_Control_Block (Entry_Num);
 634    end New_ATCB;
 635
 636    ----------------------
 637    --  Initialize_TCB  --
 638    ----------------------
 639
 640    procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
 641       Mutex_Attr   : aliased pthread_mutexattr_t;
 642       Result       : Interfaces.C.int;
 643       Cond_Attr    : aliased pthread_condattr_t;
 644
 645    begin
 646       if not Single_Lock then
 647          Result := pthread_mutexattr_init (Mutex_Attr'Access);
 648          pragma Assert (Result = 0 or else Result = ENOMEM);
 649
 650          if Result = 0 then
 651             Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
 652               Mutex_Attr'Access);
 653             pragma Assert (Result = 0 or else Result = ENOMEM);
 654          end if;
 655
 656          if Result /= 0 then
 657             Succeeded := False;
 658             return;
 659          end if;
 660
 661          Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
 662          pragma Assert (Result = 0);
 663       end if;
 664
 665       Result := pthread_condattr_init (Cond_Attr'Access);
 666       pragma Assert (Result = 0 or else Result = ENOMEM);
 667
 668       if Result = 0 then
 669          Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
 670            Cond_Attr'Access);
 671          pragma Assert (Result = 0 or else Result = ENOMEM);
 672       end if;
 673
 674       if Result = 0 then
 675          Succeeded := True;
 676          Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T;
 677          SSL.Set_Exc_Stack_Addr
 678            (To_Address (Self_ID),
 679             Self_ID.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address);
 680
 681       else
 682          if not Single_Lock then
 683             Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
 684             pragma Assert (Result = 0);
 685          end if;
 686
 687          Succeeded := False;
 688       end if;
 689
 690       Result := pthread_condattr_destroy (Cond_Attr'Access);
 691       pragma Assert (Result = 0);
 692    end Initialize_TCB;
 693
 694    -----------------
 695    -- Create_Task --
 696    -----------------
 697
 698    procedure Create_Task
 699      (T          : Task_ID;
 700       Wrapper    : System.Address;
 701       Stack_Size : System.Parameters.Size_Type;
 702       Priority   : System.Any_Priority;
 703       Succeeded  : out Boolean)
 704    is
 705       Attributes          : aliased pthread_attr_t;
 706       Adjusted_Stack_Size : Interfaces.C.size_t;
 707       Result              : Interfaces.C.int;
 708
 709       function Thread_Body_Access is new
 710         Unchecked_Conversion (System.Address, Thread_Body);
 711
 712    begin
 713       if Stack_Size = Unspecified_Size then
 714          Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
 715
 716       elsif Stack_Size < Minimum_Stack_Size then
 717          Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
 718
 719       else
 720          Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
 721       end if;
 722
 723       --  Since the initial signal mask of a thread is inherited from the
 724       --  creator, we need to set our local signal mask mask all signals
 725       --  during the creation operation, to make sure the new thread is
 726       --  not disturbed by signals before it has set its own Task_ID.
 727
 728       Result := pthread_attr_init (Attributes'Access);
 729       pragma Assert (Result = 0 or else Result = ENOMEM);
 730
 731       if Result /= 0 then
 732          Succeeded := False;
 733          return;
 734       end if;
 735
 736       Result := pthread_attr_setdetachstate
 737         (Attributes'Access, PTHREAD_CREATE_DETACHED);
 738       pragma Assert (Result = 0);
 739
 740       Result := pthread_attr_setstacksize
 741         (Attributes'Access, Adjusted_Stack_Size);
 742       pragma Assert (Result = 0);
 743
 744       --  This call may be unnecessary, not sure. ???
 745
 746       Result := pthread_attr_setinheritsched
 747         (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
 748       pragma Assert (Result = 0);
 749
 750       Result := pthread_create
 751         (T.Common.LL.Thread'Access,
 752          Attributes'Access,
 753          Thread_Body_Access (Wrapper),
 754          To_Address (T));
 755
 756       --  ENOMEM is a valid run-time error.  Don't shut down.
 757
 758       pragma Assert (Result = 0
 759         or else Result = EAGAIN or else Result = ENOMEM);
 760
 761       Succeeded := Result = 0;
 762
 763       Result := pthread_attr_destroy (Attributes'Access);
 764       pragma Assert (Result = 0);
 765
 766       if Succeeded then
 767          Set_Priority (T, Priority);
 768       end if;
 769    end Create_Task;
 770
 771    ------------------
 772    -- Finalize_TCB --
 773    ------------------
 774
 775    procedure Finalize_TCB (T : Task_ID) is
 776       Result : Interfaces.C.int;
 777       Tmp    : Task_ID := T;
 778
 779       procedure Free is new
 780         Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
 781
 782       procedure Free is new Unchecked_Deallocation
 783        (Exc_Stack_T, Exc_Stack_Ptr_T);
 784
 785    begin
 786       if not Single_Lock then
 787          Result := pthread_mutex_destroy (T.Common.LL.L'Access);
 788          pragma Assert (Result = 0);
 789       end if;
 790
 791       Result := pthread_cond_destroy (T.Common.LL.CV'Access);
 792       pragma Assert (Result = 0);
 793
 794       if T.Known_Tasks_Index /= -1 then
 795          Known_Tasks (T.Known_Tasks_Index) := null;
 796       end if;
 797
 798       Free (T.Common.LL.Exc_Stack_Ptr);
 799       Free (Tmp);
 800    end Finalize_TCB;
 801
 802    ---------------
 803    -- Exit_Task --
 804    ---------------
 805
 806    procedure Exit_Task is
 807    begin
 808       pthread_exit (System.Null_Address);
 809    end Exit_Task;
 810
 811    ----------------
 812    -- Abort_Task --
 813    ----------------
 814
 815    procedure Abort_Task (T : Task_ID) is
 816
 817    begin
 818
 819       --  Why is this commented out ???
 820 --      if T = Self and then T.Deferral_Level = 0
 821 --           and then T.Pending_ATC_Level < T.ATC_Nesting_Level
 822 --      then
 823 --         raise Standard'Abort_Signal;
 824 --      end if;
 825
 826       --
 827       --  Interrupt Server_Tasks may be waiting on an event flag
 828       --
 829       if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
 830          Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag);
 831       end if;
 832
 833    end Abort_Task;
 834
 835    ----------------
 836    -- Check_Exit --
 837    ----------------
 838
 839    --  Dummy versions.  The only currently working versions is for solaris
 840    --  (native).
 841
 842    function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
 843    begin
 844       return True;
 845    end Check_Exit;
 846
 847    --------------------
 848    -- Check_No_Locks --
 849    --------------------
 850
 851    function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
 852    begin
 853       return True;
 854    end Check_No_Locks;
 855
 856    ----------------------
 857    -- Environment_Task --
 858    ----------------------
 859
 860    function Environment_Task return Task_ID is
 861    begin
 862       return Environment_Task_ID;
 863    end Environment_Task;
 864
 865    --------------
 866    -- Lock_RTS --
 867    --------------
 868
 869    procedure Lock_RTS is
 870    begin
 871       Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
 872    end Lock_RTS;
 873
 874    ----------------
 875    -- Unlock_RTS --
 876    ----------------
 877
 878    procedure Unlock_RTS is
 879    begin
 880       Unlock (Single_RTS_Lock'Access, Global_Lock => True);
 881    end Unlock_RTS;
 882
 883    ------------------
 884    -- Suspend_Task --
 885    ------------------
 886
 887    function Suspend_Task
 888      (T           : ST.Task_ID;
 889       Thread_Self : Thread_Id) return Boolean is
 890    begin
 891       return False;
 892    end Suspend_Task;
 893
 894    -----------------
 895    -- Resume_Task --
 896    -----------------
 897
 898    function Resume_Task
 899      (T           : ST.Task_ID;
 900       Thread_Self : Thread_Id) return Boolean is
 901    begin
 902       return False;
 903    end Resume_Task;
 904
 905    ----------------
 906    -- Initialize --
 907    ----------------
 908
 909    procedure Initialize (Environment_Task : Task_ID) is
 910    begin
 911       Environment_Task_ID := Environment_Task;
 912
 913       Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
 914       --  Initialize the lock used to synchronize chain of all ATCBs.
 915
 916       Enter_Task (Environment_Task);
 917    end Initialize;
 918
 919 begin
 920    declare
 921       Result   : Interfaces.C.int;
 922    begin
 923       Result := pthread_key_create (ATCB_Key'Access, null);
 924       pragma Assert (Result = 0);
 925    end;
 926 end System.Task_Primitives.Operations;