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