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