code.delx.au - gnu-emacs/blob - test/manual/etags/ada-src/2ataspri.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNU ADA RUNTIME 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               --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --                             $Revision: 1.1 $                             --
  10 --                                                                          --
  11 --     Copyright (C) 1991,1992,1993,1994,1996 Florida State University      --
  12 --                                                                          --
  13 -- GNARL is free software; you can redistribute it  and/or modify it  under --
  14 -- terms  of  the  GNU  Library General Public License  as published by the --
  15 -- Free Software  Foundation;  either version 2, or (at  your  option)  any --
  16 -- later  version.  GNARL is distributed  in the hope that  it will be use- --
  17 -- ful, but but WITHOUT ANY WARRANTY;  without even the implied warranty of --
  18 -- MERCHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19 -- eral Library Public License  for more details.  You should have received --
  20 -- a  copy of the GNU Library General Public License along with GNARL;  see --
  21 -- file COPYING.LIB.  If not,  write to the  Free Software Foundation,  675 --
  22 -- Mass Ave, Cambridge, MA 02139, USA.                                      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with GNAT.IO;
  27 with Interfaces.C.POSIX_timers;
  28
  29 with Interfaces.C.POSIX_Error;
  30 use  Interfaces.C.POSIX_Error;
  31
  32 with Interfaces.C.POSIX_RTE;
  33 use  Interfaces.C.POSIX_RTE;
  34
  35 with Interfaces.C.Pthreads;
  36 use  Interfaces.C.Pthreads;
  37
  38 with Interfaces.C;
  39 use  Interfaces.C;
  40
  41 with System.Tasking;
  42 use  System.Tasking;
  43
  44 with System.Storage_Elements;
  45 use  System.Storage_Elements;
  46
  47 with System.Compiler_Exceptions;
  48 use  System.Compiler_Exceptions;
  49
  50 with System.Task_Specific_Data;
  51 use  System.Task_Specific_Data;
  52
  53 with System.Secondary_Stack;
  54 use  System.Secondary_Stack;
  55
  56 with System.Tasking_Soft_Links;
  57
  58 with System.Task_Clock;
  59 use  System.Task_Clock;
  60
  61 with Unchecked_Conversion;
  62 with Interfaces.C.System_Constants;
  63
  64 package body System.Task_Primitives is
  65
  66    use Interfaces.C.Pthreads;
  67    use Interfaces.C.System_Constants;
  68
  69    package RTE renames Interfaces.C.POSIX_RTE;
  70    package TSL renames System.Tasking_Soft_Links;
  71
  72    Test_And_Set_Mutex : Lock;
  73
  74    Abort_Signal : constant := 6;
  75
  76    Abort_Handler : Abort_Handler_Pointer;
  77
  78    ATCB_Key : aliased pthread_key_t;
  79
  80    Unblocked_Signal_Mask : aliased RTE.Signal_Set;
  81    --  The set of signals that should be unblocked in a task.
  82    --  This is in general the signals that can be generated synchronously,
  83    --  and which should therefore be converted into Ada exceptions.
  84    --  It also includes the Abort_Signal, to allow asynchronous abortion.
  85
  86    function To_void_ptr is new
  87      Unchecked_Conversion (TCB_Ptr, void_ptr);
  88
  89    function To_TCB_Ptr is new
  90      Unchecked_Conversion (void_ptr, TCB_Ptr);
  91
  92    function pthread_mutexattr_setprotocol
  93      (attr : access pthread_attr_t; priority : integer) return int;
  94    pragma Import (C,
  95                   pthread_mutexattr_setprotocol,
  96                   "pthread_mutexattr_setprotocol",
  97                   "pthread_mutexattr_setprotocol");
  98
  99    function pthread_mutexattr_setprio_ceiling
 100      (attr : access pthread_attr_t; priority : int) return int;
 101    pragma Import (C,
 102                   pthread_mutexattr_setprio_ceiling,
 103                   "pthread_mutexattr_setprio_ceiling",
 104                   "pthread_mutexattr_setprio_ceiling");
 105
 106    pthread_mutexattr_default : pthread_mutexattr_t;
 107    pragma Import (C, pthread_mutexattr_default,
 108                   "pthread_mutexattr_default",
 109                   "pthread_mutexattr_default");
 110
 111    -----------------------
 112    -- Local Subprograms --
 113    -----------------------
 114
 115    procedure Abort_Wrapper
 116      (signo   : Integer;
 117       info    : RTE.siginfo_ptr;
 118       context : System.Address);
 119    --  This is a signal handler procedure which calls the user-specified
 120    --  abort handler procedure.
 121
 122    procedure LL_Wrapper (T : TCB_Ptr);
 123    --  A wrapper procedure that is called from a new low-level task.
 124    --  It performs initializations for the new task and calls the
 125    --  user-specified startup procedure.
 126
 127    -------------------------
 128    -- Initialize_LL_Tasks --
 129    -------------------------
 130
 131    procedure Initialize_LL_Tasks (T : TCB_Ptr) is
 132       Result : int;
 133    begin
 134       T.LL_Entry_Point := null;
 135       T.Thread := pthread_self;
 136
 137       Result := pthread_key_create (ATCB_Key'Access, null);
 138
 139       if Result = FUNC_ERR then
 140          raise Storage_Error;               --  Insufficient resources.
 141       end if;
 142
 143       T.Thread := pthread_self;
 144
 145       Result := pthread_setspecific (ATCB_Key, To_void_ptr (T));
 146
 147       if Result = FUNC_ERR then
 148          GNAT.IO.Put_Line ("Get specific failed");
 149          raise Storage_Error;               --  Insufficient resources.
 150       end if;
 151       pragma Assert (Result /= FUNC_ERR,
 152          "GNULLI failure---pthread_setspecific");
 153
 154    end Initialize_LL_Tasks;
 155
 156    ----------
 157    -- Self --
 158    ----------
 159
 160    function Self return TCB_Ptr is
 161       Temp   : aliased void_ptr;
 162       Result : int;
 163    begin
 164       Result := pthread_getspecific (ATCB_Key, Temp'Access);
 165       pragma Assert (Result /= FUNC_ERR,
 166           "GNULLI failure---pthread_getspecific");
 167       return To_TCB_Ptr (Temp);
 168    end Self;
 169
 170    ---------------------
 171    -- Initialize_Lock --
 172    ---------------------
 173
 174    procedure Initialize_Lock
 175      (Prio : System.Any_Priority;
 176       L    : in out Lock)
 177    is
 178
 179       Attributes : aliased pthread_mutexattr_t;
 180       Result     : int;
 181       MUTEX_NONRECURSIVE_NP : constant := 2;
 182
 183    begin
 184       Result := pthread_mutexattr_init (Attributes'Access);
 185       if Result = FUNC_ERR then
 186          raise STORAGE_ERROR;  --  should be ENOMEM
 187       end if;
 188
 189       Result := pthread_mutexattr_setkind
 190         (Attributes'Access, MUTEX_NONRECURSIVE_NP);
 191       if Result = FUNC_ERR then
 192          raise STORAGE_ERROR;  --  should be ENOMEM
 193       end if;
 194
 195       Result := pthread_mutex_init (L.mutex'Access, Attributes);
 196
 197       if Result = FUNC_ERR then
 198          Result := pthread_mutexattr_destroy (Attributes'Access);
 199          raise STORAGE_ERROR;  --  should be ENOMEM ???
 200       end if;
 201
 202       Result := pthread_mutexattr_destroy (Attributes'Access);
 203
 204    end Initialize_Lock;
 205
 206    -------------------
 207    -- Finalize_Lock --
 208    -------------------
 209
 210    procedure Finalize_Lock (L : in out Lock) is
 211       Result : int;
 212    begin
 213       Result := pthread_mutex_destroy (L.mutex'Access);
 214       pragma Assert
 215          (Result /= FUNC_ERR, "GNULLI failure---pthread_mutex_destroy");
 216    end Finalize_Lock;
 217
 218    ----------------
 219    -- Write_Lock --
 220    ----------------
 221
 222    --
 223    --  The current pthreads implementation does not check for Ceiling
 224    --  violations.
 225    --
 226    procedure Write_Lock (L : in out Lock; Ceiling_Violation : out Boolean) is
 227       Result : int;
 228    begin
 229       Ceiling_Violation := False;
 230       Result := pthread_mutex_lock (L.mutex'Access);
 231       pragma Assert
 232         (Result /= FUNC_ERR, "GNULLI FUNC_ERR---pthread_mutex_lock");
 233    end Write_Lock;
 234
 235    ---------------
 236    -- Read_Lock --
 237    ---------------
 238
 239    procedure Read_Lock (L : in out Lock; Ceiling_Violation : out Boolean)
 240       renames Write_Lock;
 241
 242    ------------
 243    -- Unlock --
 244    ------------
 245
 246    procedure Unlock (L : in out Lock) is
 247       Result : int;
 248    begin
 249       Result := pthread_mutex_unlock (L.mutex'Access);
 250       pragma Assert
 251          (Result /= FUNC_ERR, "GNULLI FUNC_ERR---pthread_mutex_unlock");
 252    end Unlock;
 253
 254    ---------------------
 255    -- Initialize_Cond --
 256    ---------------------
 257
 258    procedure Initialize_Cond (Cond : in out Condition_Variable) is
 259       Attributes : aliased Pthreads.pthread_condattr_t;
 260       Result     : int;
 261    begin
 262       Result := pthread_condattr_init (Attributes'Access);
 263
 264       if Result = FUNC_ERR then
 265          raise STORAGE_ERROR;  --  should be ENOMEM ???
 266       end if;
 267
 268       --  Result := pthread_cond_init (Cond.CV'Access, Attributes'Access);
 269       Result := pthread_cond_init (Cond.CV'Access, Attributes);
 270
 271
 272       if Result = FUNC_ERR then
 273          raise STORAGE_ERROR;  --  should be ENOMEM  ???
 274       end if;
 275
 276       Result := pthread_condattr_destroy (Attributes'Access);
 277       pragma Assert
 278          (Result /= FUNC_ERR, "GNULLI FUNC_ERR---pthread_condattr_destroy");
 279
 280    end Initialize_Cond;
 281
 282    -------------------
 283    -- Finalize_Cond --
 284    -------------------
 285
 286    procedure Finalize_Cond (Cond : in out Condition_Variable) is
 287       Result : int;
 288
 289    begin
 290       Result := pthread_cond_destroy (Cond.CV'Access);
 291       pragma Assert
 292          (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_destroy");
 293    end Finalize_Cond;
 294
 295
 296    ---------------
 297    -- Cond_Wait --
 298    ---------------
 299
 300    procedure Cond_Wait (Cond : in out Condition_Variable; L : in out Lock) is
 301       Result : int;
 302    begin
 303       Result := pthread_cond_wait (Cond.CV'Access, L.mutex'Access);
 304       pragma Assert
 305         (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_wait");
 306    end Cond_Wait;
 307
 308    ---------------------
 309    -- Cond_Timed_Wait --
 310    ---------------------
 311
 312    procedure Cond_Timed_Wait
 313      (Cond      : in out Condition_Variable;
 314       L         : in out Lock;
 315       Abs_Time  : System.Task_Clock.Stimespec;
 316       Timed_Out : out Boolean) is
 317
 318       Result : int;
 319       TV     : aliased timespec;
 320
 321       use POSIX_Error;
 322
 323    begin
 324       Timed_Out := False;  --  Assume success until we know otherwise
 325
 326       TV.tv_sec := int (Interfaces.C.POSIX_timers.time_t
 327         (Task_Clock.Stimespec_Seconds (Abs_Time)));
 328
 329       TV.tv_nsec := long (Interfaces.C.POSIX_timers.Nanoseconds
 330         (Task_Clock.Stimespec_NSeconds (Abs_Time)));
 331
 332       Result := pthread_cond_timedwait
 333         (Cond.CV'Access, L.mutex'Access, TV'Access);
 334       pragma Assert
 335          (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_timedwait");
 336
 337    end Cond_Timed_Wait;
 338
 339    -----------------
 340    -- Cond_Signal --
 341    -----------------
 342
 343    procedure Cond_Signal (Cond : in out Condition_Variable) is
 344       Result : int;
 345    begin
 346       Result :=  pthread_cond_signal (Cond.CV'Access);
 347       pragma Assert
 348          (Result /= FUNC_ERR, "GNULLI failure---pthread_cond_signal");
 349    end Cond_Signal;
 350
 351    ------------------
 352    -- Set_Priority --
 353    ------------------
 354
 355    procedure Set_Priority
 356      (T : TCB_Ptr;
 357       Prio : System.Any_Priority) is
 358
 359       Result : int;
 360       Thread : Pthreads.pthread_t renames T.Thread;
 361
 362    begin
 363       Result := pthread_setprio (Thread, int (Prio));
 364       pragma Assert
 365          (Result /= FUNC_ERR, "GNULLI failure---pthread_setprio");
 366    end Set_Priority;
 367
 368    ----------------------
 369    -- Set_Own_Priority --
 370    ----------------------
 371
 372    procedure Set_Own_Priority (Prio : System.Any_Priority) is
 373    begin
 374       null;
 375       --  ENOSYS Result :=
 376       --     pthread_setprio (pthread_self, int (Prio));
 377       --  pragma Assert
 378       --     (Result /= FUNC_ERR, "GNULLI failure---pthread_setprio");
 379    end Set_Own_Priority;
 380
 381    ------------------
 382    -- Get_Priority --
 383    ------------------
 384
 385    function Get_Priority (T : TCB_Ptr) return System.Any_Priority is
 386       Priority : aliased int := 0;
 387    begin
 388       --  ENOSYS Result := pthread_getprio (T.Thread, Priority'Access);
 389       --  pragma Assert
 390       --     (Result /= FUNC_ERR, "GNULLI failure---pthread_getprio");
 391       return System.Priority (Priority);
 392    end Get_Priority;
 393
 394    -----------------------
 395    --  Get_Own_Priority --
 396    -----------------------
 397
 398    function Get_Own_Priority return System.Any_Priority is
 399       Result : int;
 400       Priority : aliased int := 0;
 401    begin
 402       Result := pthread_getprio (pthread_self, Priority'Access);
 403       pragma Assert
 404          (Result /= FUNC_ERR, "GNULLI failure---pthread_getprio");
 405       return System.Priority (Priority);
 406    end Get_Own_Priority;
 407
 408    --------------------
 409    -- Create_LL_Task --
 410    --------------------
 411
 412    procedure Create_LL_Task
 413      (Priority       : System.Any_Priority;
 414       Stack_Size     : Task_Storage_Size;
 415       Task_Info      : System.Task_Info.Task_Info_Type;
 416       LL_Entry_Point : LL_Task_Procedure_Access;
 417       Arg            : System.Address;
 418       T              : TCB_Ptr) is
 419
 420       use Pthreads;
 421
 422       Attributes : aliased pthread_attr_t;
 423       Result     : int;
 424       L_Priority : System.Any_Priority := Priority;
 425
 426       function To_Start_Addr is new
 427         Unchecked_Conversion (System.Address, start_addr);
 428
 429    begin
 430       T.LL_Entry_Point := LL_Entry_Point;
 431       T.LL_Arg := Arg;
 432       T.Stack_Size := Stack_Size;
 433
 434       Result := pthread_attr_init (Attributes'Access);
 435       pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_attr_init");
 436
 437 --      Result := pthread_attr_setdetachstate (Attributes'Access, 1);
 438 --      pragma Assert
 439 --        (Result /= FUNC_ERR, "GNULLI failure---pthread_setdetachstate");
 440
 441       Result := pthread_attr_setstacksize
 442         (Attributes'Access, size_t (Stack_Size));
 443       pragma Assert
 444         (Result /= FUNC_ERR, "GNULLI failure---pthread_setstacksize");
 445
 446       Result := pthread_attr_setinheritsched
 447         (Attributes'Access, PTHREAD_DEFAULT_SCHED);
 448       pragma Assert
 449         (Result /= FUNC_ERR, "GNULLI failure---pthread_setinheritsched");
 450
 451       Result := pthread_attr_setsched
 452         (Attributes'Access, SCHED_FIFO);
 453       pragma Assert
 454         (Result /= FUNC_ERR, "GNULLI failure---pthread_setinheritsched");
 455
 456       --  The following priority adjustment is a kludge to get around needing
 457       --  root privileges to run at higher than 18 for FIFO or 19 for OTHER.
 458
 459       if (L_Priority > 18) then
 460          L_Priority := 18;
 461       elsif (L_Priority < 14) then
 462          L_Priority := 14;
 463       end if;
 464
 465       Result := pthread_attr_setprio
 466         (Attributes'Access, int (L_Priority));
 467       pragma Assert
 468         (Result /= FUNC_ERR, "GNULLI failure---pthread_attr_setprio");
 469
 470       Result := pthread_create
 471         (T.Thread'Access,
 472          Attributes,
 473          To_Start_Addr (LL_Wrapper'Address),
 474          T.all'Address);
 475       if Result = FUNC_ERR then
 476          GNAT.IO.Put_Line ("pthread create failed");
 477          raise Storage_Error;
 478       end if;
 479       pragma Assert (Result /= FUNC_ERR, "GNULLI failure---pthread_create");
 480
 481       Result := pthread_attr_destroy (Attributes'Access);
 482       pragma Assert
 483         (Result /= FUNC_ERR, "GNULLI failure---pthread_attr_destroy");
 484
 485    end Create_LL_Task;
 486
 487    -----------------
 488    -- Exit_LL_Task --
 489    ------------------
 490
 491    procedure Exit_LL_Task is
 492    begin
 493       pthread_exit (System.Null_Address);
 494    end Exit_LL_Task;
 495
 496    ----------------
 497    -- Abort_Task --
 498    ----------------
 499
 500    procedure Abort_Task (T : TCB_Ptr) is
 501       Result     : int;
 502    begin
 503 --      Result := pthread_kill (T.Thread);
 504 --      pragma Assert
 505 --         (Result /= FUNC_ERR, "GNULLI failure---pthread_kill");
 506       null;
 507    end Abort_Task;
 508
 509    ----------------
 510    -- Test_Abort --
 511    ----------------
 512
 513    --  This procedure does nothing.  It is intended for systems without
 514    --  asynchronous abortion, where the runtime system would have to
 515    --  synchronously poll for pending abortions.  This should be done
 516    --  at least at every synchronization point.
 517
 518    procedure Test_Abort is
 519    begin
 520       null;
 521    end Test_Abort;
 522
 523    ---------------------------
 524    -- Install_Abort_Handler --
 525    ---------------------------
 526
 527    procedure Install_Abort_Handler (Handler : Abort_Handler_Pointer) is
 528       act     : aliased RTE.struct_sigaction;
 529       old_act : aliased RTE.struct_sigaction;
 530       Result  : POSIX_Error.Return_Code;
 531       SA_SIGINFO : constant := 64;
 532
 533       use type POSIX_Error.Return_Code;
 534
 535    begin
 536       Abort_Handler := Handler;
 537
 538       act.sa_flags := SA_SIGINFO;
 539       act.sa_handler := Abort_Wrapper'Address;
 540       RTE.sigemptyset (act.sa_mask'Access, Result);
 541       pragma Assert (Result /= FUNC_ERR, "GNULLI failure---sigemptyset");
 542
 543       RTE.sigaction (Abort_Signal, act'Access, old_act'Access, Result);
 544       pragma Assert (Result /= FUNC_ERR, "GNULLI failure---sigaction");
 545    end Install_Abort_Handler;
 546
 547    -------------------
 548    -- Abort_Wrapper --
 549    -------------------
 550
 551    --  This is the handler called by the OS when an abort signal is
 552    --  received; it in turn calls the handler installed by the client.
 553    --  This procedure serves to isolate the client from the
 554    --  implementation-specific calling conventions of asynchronous
 555    --  handlers.
 556
 557    procedure Abort_Wrapper
 558      (signo   : Integer;
 559       info    : RTE.siginfo_ptr;
 560       context : System.Address)
 561    is
 562       function Address_To_Call_State is new
 563         Unchecked_Conversion (System.Address, Pre_Call_State);
 564
 565    begin
 566       Abort_Handler (Address_To_Call_State (context));
 567    end Abort_Wrapper;
 568
 569    ---------------------------
 570    -- Install_Error_Handler --
 571    ---------------------------
 572
 573    procedure Install_Error_Handler (Handler : System.Address) is
 574
 575       Temp : Address;
 576
 577       use Pthreads;
 578
 579    begin
 580       --  Set up the soft links to tasking services used in the absence of
 581       --  tasking.  These replace tasking-free defaults.
 582
 583       Temp := TSL.Get_Jmpbuf_Address.all;
 584       --  pthread_set_jumpbuf_address (Temp);
 585
 586       Temp := TSL.Get_Sec_Stack_Addr.all;
 587       --  pthread_set_sec_stack_addr  (Temp);
 588
 589       --  TSL.Get_Jmpbuf_Address := pthread_get_jumpbuf_address'Access;
 590       --  TSL.Set_Jmpbuf_Address := pthread_set_jumpbuf_address'Access;
 591       --  TSL.Get_Gnat_Exception := pthread_get_exception'Access;
 592       --  TSL.Set_Gnat_Exception := pthread_set_exception'Access;
 593    end Install_Error_Handler;
 594
 595    ---------------
 596    -- LL_Assert --
 597    ---------------
 598
 599    procedure LL_Assert (B : Boolean; M : String) is
 600    begin
 601       null;
 602    end LL_Assert;
 603
 604    ----------------
 605    -- LL_Wrapper --
 606    ----------------
 607
 608    procedure LL_Wrapper (T : TCB_Ptr) is
 609       Result  : POSIX_Error.Return_Code;
 610       Result1 : int;
 611       Exc_Stack : String (1 .. 256);
 612       Exc_Base  : Address := Exc_Stack (Exc_Stack'Last)'Address + 1;
 613       Old_Set : aliased RTE.Signal_Set;
 614    begin
 615       Result1 := pthread_setspecific (ATCB_Key, T.all'Address);
 616
 617       RTE.sigprocmask (
 618         RTE.SIG_UNBLOCK, Unblocked_Signal_Mask'Access, Old_Set'Access, Result);
 619       pragma Assert (
 620         Result /= Failure, "GNULLI failure---sigprocmask");
 621
 622       --  Note that the following call may not return!
 623       T.LL_Entry_Point (T.LL_Arg);
 624    end LL_Wrapper;
 625
 626    --------------------------
 627    -- Test and Set support --
 628    --------------------------
 629
 630    procedure Initialize_TAS_Cell (Cell : out TAS_Cell) is
 631    begin
 632       Cell.Value := 0;
 633    end Initialize_TAS_Cell;
 634
 635    procedure Finalize_TAS_Cell (Cell : in out TAS_Cell) is
 636    begin
 637       null;
 638    end Finalize_TAS_Cell;
 639
 640    procedure Clear (Cell : in out TAS_Cell) is
 641    begin
 642       Cell.Value := 1;
 643    end Clear;
 644
 645    procedure Test_And_Set (Cell : in out TAS_Cell; Result : out Boolean) is
 646       Error   : Boolean;
 647    begin
 648       Write_Lock (Test_And_Set_Mutex, Error);
 649
 650       if Cell.Value = 1 then
 651          Result := False;
 652       else
 653          Result :=  True;
 654          Cell.Value := 1;
 655       end if;
 656       Unlock (Test_And_Set_Mutex);
 657    end Test_And_Set;
 658
 659    function  Is_Set (Cell : in TAS_Cell) return Boolean is
 660    begin
 661       return Cell.Value = 1;
 662    end Is_Set;
 663 begin
 664    Initialize_Lock (System.Any_Priority'Last, Test_And_Set_Mutex);
 665 end System.Task_Primitives;