gcc/ada/s-tasren.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                  --
   4 --                                                                          --
   5 --            S Y S T E M . T A S K I N G . R E N D E Z V O U S             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2007, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System.Task_Primitives.Operations;
  35 --  used for Get_Priority
  36 --           Set_Priority
  37 --           Write_Lock
  38 --           Unlock
  39 --           Sleep
  40 --           Wakeup
  41 --           Timed_Sleep
  42
  43 with System.Tasking.Entry_Calls;
  44 --  Used for Wait_For_Completion
  45 --           Wait_For_Completion_With_Timeout
  46 --           Wait_Until_Abortable
  47
  48 with System.Tasking.Initialization;
  49 --  used for Defer_Abort
  50 --           Undefer_Abort
  51 --           Do_Pending_Action
  52
  53 with System.Tasking.Queuing;
  54 --  used for Enqueue
  55 --           Dequeue_Head
  56 --           Select_Task_Entry_Call
  57 --           Count_Waiting
  58
  59 with System.Tasking.Utilities;
  60 --  used for Check_Exception
  61 --           Make_Passive
  62 --           Wakeup_Entry_Caller
  63 --           Exit_One_ATC_Level
  64
  65 with System.Tasking.Protected_Objects.Operations;
  66 --  used for PO_Do_Or_Queue
  67 --           PO_Service_Entries
  68 --           Lock_Entries
  69
  70 with System.Tasking.Debug;
  71 --  used for Trace
  72
  73 with System.Restrictions;
  74 --  used for Abort_Allowed
  75
  76 with System.Parameters;
  77 --  used for Single_Lock
  78 --           Runtime_Traces
  79
  80 with System.Traces.Tasking;
  81 --  used for Send_Trace_Info
  82
  83 package body System.Tasking.Rendezvous is
  84
  85    package STPO renames System.Task_Primitives.Operations;
  86    package POO renames Protected_Objects.Operations;
  87    package POE renames Protected_Objects.Entries;
  88
  89    use Parameters;
  90    use Task_Primitives.Operations;
  91    use System.Traces;
  92    use System.Traces.Tasking;
  93
  94    type Select_Treatment is (
  95      Accept_Alternative_Selected,   --  alternative with non-null body
  96      Accept_Alternative_Completed,  --  alternative with null body
  97      Else_Selected,
  98      Terminate_Selected,
  99      Accept_Alternative_Open,
 100      No_Alternative_Open);
 101
 102    ----------------
 103    -- Local Data --
 104    ----------------
 105
 106    Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
 107      (Simple_Mode         => No_Alternative_Open,
 108       Else_Mode           => Else_Selected,
 109       Terminate_Mode      => Terminate_Selected,
 110       Delay_Mode          => No_Alternative_Open);
 111
 112    New_State : constant array (Boolean, Entry_Call_State)
 113      of Entry_Call_State :=
 114        (True =>
 115          (Never_Abortable   => Never_Abortable,
 116           Not_Yet_Abortable => Now_Abortable,
 117           Was_Abortable     => Now_Abortable,
 118           Now_Abortable     => Now_Abortable,
 119           Done              => Done,
 120           Cancelled         => Cancelled),
 121         False =>
 122          (Never_Abortable   => Never_Abortable,
 123           Not_Yet_Abortable => Not_Yet_Abortable,
 124           Was_Abortable     => Was_Abortable,
 125           Now_Abortable     => Now_Abortable,
 126           Done              => Done,
 127           Cancelled         => Cancelled)
 128        );
 129
 130    -----------------------
 131    -- Local Subprograms --
 132    -----------------------
 133
 134    procedure Local_Defer_Abort (Self_Id : Task_Id) renames
 135      System.Tasking.Initialization.Defer_Abort_Nestable;
 136
 137    procedure Local_Undefer_Abort (Self_Id : Task_Id) renames
 138      System.Tasking.Initialization.Undefer_Abort_Nestable;
 139
 140    --  Florist defers abort around critical sections that
 141    --  make entry calls to the Interrupt_Manager task, which
 142    --  violates the general rule about top-level runtime system
 143    --  calls from abort-deferred regions.  It is not that this is
 144    --  unsafe, but when it occurs in "normal" programs it usually
 145    --  means either the user is trying to do a potentially blocking
 146    --  operation from within a protected object, or there is a
 147    --  runtime system/compiler error that has failed to undefer
 148    --  an earlier abort deferral. Thus, for debugging it may be
 149    --  wise to modify the above renamings to the non-nestable forms.
 150
 151    procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
 152    pragma Inline (Boost_Priority);
 153    --  Call this only with abort deferred and holding lock of Acceptor
 154
 155    procedure Call_Synchronous
 156      (Acceptor              : Task_Id;
 157       E                     : Task_Entry_Index;
 158       Uninterpreted_Data    : System.Address;
 159       Mode                  : Call_Modes;
 160       Rendezvous_Successful : out Boolean);
 161    pragma Inline (Call_Synchronous);
 162    --  This call is used to make a simple or conditional entry call.
 163    --  Called from Call_Simple and Task_Entry_Call.
 164
 165    procedure Setup_For_Rendezvous_With_Body
 166      (Entry_Call : Entry_Call_Link;
 167       Acceptor   : Task_Id);
 168    pragma Inline (Setup_For_Rendezvous_With_Body);
 169    --  Call this only with abort deferred and holding lock of Acceptor.
 170    --  When a rendezvous selected (ready for rendezvous) we need to save
 171    --  previous caller and adjust the priority. Also we need to make
 172    --  this call not Abortable (Cancellable) since the rendezvous has
 173    --  already been started.
 174
 175    procedure Wait_For_Call (Self_Id : Task_Id);
 176    pragma Inline (Wait_For_Call);
 177    --  Call this only with abort deferred and holding lock of Self_Id.
 178    --  An accepting task goes into Sleep by calling this routine
 179    --  waiting for a call from the caller or waiting for an abort.
 180    --  Make sure Self_Id is locked before calling this routine.
 181
 182    -----------------
 183    -- Accept_Call --
 184    -----------------
 185
 186    procedure Accept_Call
 187      (E                  : Task_Entry_Index;
 188       Uninterpreted_Data : out System.Address)
 189    is
 190       Self_Id      : constant Task_Id := STPO.Self;
 191       Caller       : Task_Id := null;
 192       Open_Accepts : aliased Accept_List (1 .. 1);
 193       Entry_Call   : Entry_Call_Link;
 194
 195    begin
 196       Initialization.Defer_Abort (Self_Id);
 197
 198       if Single_Lock then
 199          Lock_RTS;
 200       end if;
 201
 202       STPO.Write_Lock (Self_Id);
 203
 204       if not Self_Id.Callable then
 205          pragma Assert (Self_Id.Pending_ATC_Level = 0);
 206
 207          pragma Assert (Self_Id.Pending_Action);
 208
 209          STPO.Unlock (Self_Id);
 210
 211          if Single_Lock then
 212             Unlock_RTS;
 213          end if;
 214
 215          Initialization.Undefer_Abort (Self_Id);
 216
 217          --  Should never get here ???
 218
 219          pragma Assert (False);
 220          raise Standard'Abort_Signal;
 221       end if;
 222
 223       Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
 224
 225       if Entry_Call /= null then
 226          Caller := Entry_Call.Self;
 227          Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
 228          Uninterpreted_Data := Entry_Call.Uninterpreted_Data;
 229
 230       else
 231          --  Wait for a caller
 232
 233          Open_Accepts (1).Null_Body := False;
 234          Open_Accepts (1).S := E;
 235          Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
 236
 237          --  Wait for normal call
 238
 239          if Parameters.Runtime_Traces then
 240             Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
 241          end if;
 242
 243          pragma Debug
 244            (Debug.Trace (Self_Id, "Accept_Call: wait", 'R'));
 245          Wait_For_Call (Self_Id);
 246
 247          pragma Assert (Self_Id.Open_Accepts = null);
 248
 249          if Self_Id.Common.Call /= null then
 250             Caller := Self_Id.Common.Call.Self;
 251             Uninterpreted_Data :=
 252               Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
 253          else
 254             --  Case of an aborted task
 255
 256             Uninterpreted_Data := System.Null_Address;
 257          end if;
 258       end if;
 259
 260       --  Self_Id.Common.Call should already be updated by the Caller
 261       --  On return, we will start the rendezvous.
 262
 263       STPO.Unlock (Self_Id);
 264
 265       if Single_Lock then
 266          Unlock_RTS;
 267       end if;
 268
 269       Initialization.Undefer_Abort (Self_Id);
 270
 271       if Parameters.Runtime_Traces then
 272          Send_Trace_Info (M_Accept_Complete, Caller, Entry_Index (E));
 273       end if;
 274    end Accept_Call;
 275
 276    --------------------
 277    -- Accept_Trivial --
 278    --------------------
 279
 280    procedure Accept_Trivial (E : Task_Entry_Index) is
 281       Self_Id      : constant Task_Id := STPO.Self;
 282       Caller       : Task_Id := null;
 283       Open_Accepts : aliased Accept_List (1 .. 1);
 284       Entry_Call   : Entry_Call_Link;
 285
 286    begin
 287       Initialization.Defer_Abort_Nestable (Self_Id);
 288
 289       if Single_Lock then
 290          Lock_RTS;
 291       end if;
 292
 293       STPO.Write_Lock (Self_Id);
 294
 295       if not Self_Id.Callable then
 296          pragma Assert (Self_Id.Pending_ATC_Level = 0);
 297
 298          pragma Assert (Self_Id.Pending_Action);
 299
 300          STPO.Unlock (Self_Id);
 301
 302          if Single_Lock then
 303             Unlock_RTS;
 304          end if;
 305
 306          Initialization.Undefer_Abort_Nestable (Self_Id);
 307
 308          --  Should never get here ???
 309
 310          pragma Assert (False);
 311          raise Standard'Abort_Signal;
 312       end if;
 313
 314       Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call);
 315
 316       if Entry_Call = null then
 317          --  Need to wait for entry call
 318
 319          Open_Accepts (1).Null_Body := True;
 320          Open_Accepts (1).S := E;
 321          Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access;
 322
 323          if Parameters.Runtime_Traces then
 324             Send_Trace_Info (W_Accept, Self_Id, Integer (Open_Accepts'Length));
 325          end if;
 326
 327          pragma Debug
 328           (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R'));
 329
 330          Wait_For_Call (Self_Id);
 331
 332          pragma Assert (Self_Id.Open_Accepts = null);
 333
 334          --  No need to do anything special here for pending abort.
 335          --  Abort_Signal will be raised by Undefer on exit.
 336
 337          STPO.Unlock (Self_Id);
 338
 339       else  --  found caller already waiting
 340          pragma Assert (Entry_Call.State < Done);
 341
 342          STPO.Unlock (Self_Id);
 343          Caller := Entry_Call.Self;
 344
 345          STPO.Write_Lock (Caller);
 346          Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 347          STPO.Unlock (Caller);
 348       end if;
 349
 350       if Parameters.Runtime_Traces then
 351          Send_Trace_Info (M_Accept_Complete);
 352
 353          --  Fake one, since there is (???) no way
 354          --  to know that the rendezvous is over
 355
 356          Send_Trace_Info (M_RDV_Complete);
 357       end if;
 358
 359       if Single_Lock then
 360          Unlock_RTS;
 361       end if;
 362
 363       Initialization.Undefer_Abort_Nestable (Self_Id);
 364    end Accept_Trivial;
 365
 366    --------------------
 367    -- Boost_Priority --
 368    --------------------
 369
 370    procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is
 371       Caller        : constant Task_Id := Call.Self;
 372       Caller_Prio   : constant System.Any_Priority := Get_Priority (Caller);
 373       Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor);
 374
 375    begin
 376       if Caller_Prio > Acceptor_Prio then
 377          Call.Acceptor_Prev_Priority := Acceptor_Prio;
 378          Set_Priority (Acceptor, Caller_Prio);
 379
 380       else
 381          Call.Acceptor_Prev_Priority := Priority_Not_Boosted;
 382       end if;
 383    end Boost_Priority;
 384
 385    -----------------
 386    -- Call_Simple --
 387    -----------------
 388
 389    procedure Call_Simple
 390      (Acceptor           : Task_Id;
 391       E                  : Task_Entry_Index;
 392       Uninterpreted_Data : System.Address)
 393    is
 394       Rendezvous_Successful : Boolean;
 395
 396    begin
 397       --  If pragma Detect_Blocking is active then Program_Error must be
 398       --  raised if this potentially blocking operation is called from a
 399       --  protected action.
 400
 401       if System.Tasking.Detect_Blocking
 402         and then STPO.Self.Common.Protected_Action_Nesting > 0
 403       then
 404          Ada.Exceptions.Raise_Exception
 405            (Program_Error'Identity, "potentially blocking operation");
 406       end if;
 407
 408       Call_Synchronous
 409         (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
 410    end Call_Simple;
 411
 412    ----------------------
 413    -- Call_Synchronous --
 414    ----------------------
 415
 416    procedure Call_Synchronous
 417      (Acceptor              : Task_Id;
 418       E                     : Task_Entry_Index;
 419       Uninterpreted_Data    : System.Address;
 420       Mode                  : Call_Modes;
 421       Rendezvous_Successful : out Boolean)
 422    is
 423       Self_Id    : constant Task_Id := STPO.Self;
 424       Level      : ATC_Level;
 425       Entry_Call : Entry_Call_Link;
 426
 427    begin
 428       pragma Assert (Mode /= Asynchronous_Call);
 429
 430       Local_Defer_Abort (Self_Id);
 431       Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
 432       pragma Debug
 433         (Debug.Trace (Self_Id, "CS: entered ATC level: " &
 434          ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
 435       Level := Self_Id.ATC_Nesting_Level;
 436       Entry_Call := Self_Id.Entry_Calls (Level)'Access;
 437       Entry_Call.Next := null;
 438       Entry_Call.Mode := Mode;
 439       Entry_Call.Cancellation_Attempted := False;
 440
 441       if Parameters.Runtime_Traces then
 442          Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
 443       end if;
 444
 445       --  If this is a call made inside of an abort deferred region,
 446       --  the call should be never abortable.
 447
 448       if Self_Id.Deferral_Level > 1 then
 449          Entry_Call.State := Never_Abortable;
 450       else
 451          Entry_Call.State := Now_Abortable;
 452       end if;
 453
 454       Entry_Call.E := Entry_Index (E);
 455       Entry_Call.Prio := Get_Priority (Self_Id);
 456       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
 457       Entry_Call.Called_Task := Acceptor;
 458       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
 459
 460       --  Note: the caller will undefer abort on return (see WARNING above)
 461
 462       if Single_Lock then
 463          Lock_RTS;
 464       end if;
 465
 466       if not Task_Do_Or_Queue
 467         (Self_Id, Entry_Call, With_Abort => True)
 468       then
 469          STPO.Write_Lock (Self_Id);
 470          Utilities.Exit_One_ATC_Level (Self_Id);
 471          STPO.Unlock (Self_Id);
 472
 473          if Single_Lock then
 474             Unlock_RTS;
 475          end if;
 476
 477          if Parameters.Runtime_Traces then
 478             Send_Trace_Info (E_Missed, Acceptor);
 479          end if;
 480
 481          Local_Undefer_Abort (Self_Id);
 482          raise Tasking_Error;
 483       end if;
 484
 485       STPO.Write_Lock (Self_Id);
 486       pragma Debug
 487         (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R'));
 488       Entry_Calls.Wait_For_Completion (Entry_Call);
 489       pragma Debug
 490         (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R'));
 491       Rendezvous_Successful := Entry_Call.State = Done;
 492       STPO.Unlock (Self_Id);
 493
 494       if Single_Lock then
 495          Unlock_RTS;
 496       end if;
 497
 498       Local_Undefer_Abort (Self_Id);
 499       Entry_Calls.Check_Exception (Self_Id, Entry_Call);
 500    end Call_Synchronous;
 501
 502    --------------
 503    -- Callable --
 504    --------------
 505
 506    function Callable (T : Task_Id) return Boolean is
 507       Result  : Boolean;
 508       Self_Id : constant Task_Id := STPO.Self;
 509
 510    begin
 511       Initialization.Defer_Abort_Nestable (Self_Id);
 512
 513       if Single_Lock then
 514          Lock_RTS;
 515       end if;
 516
 517       STPO.Write_Lock (T);
 518       Result := T.Callable;
 519       STPO.Unlock (T);
 520
 521       if Single_Lock then
 522          Unlock_RTS;
 523       end if;
 524
 525       Initialization.Undefer_Abort_Nestable (Self_Id);
 526       return Result;
 527    end Callable;
 528
 529    ----------------------------
 530    -- Cancel_Task_Entry_Call --
 531    ----------------------------
 532
 533    procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
 534    begin
 535       Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled);
 536    end Cancel_Task_Entry_Call;
 537
 538    -------------------------
 539    -- Complete_Rendezvous --
 540    -------------------------
 541
 542    procedure Complete_Rendezvous is
 543    begin
 544       Exceptional_Complete_Rendezvous (Ada.Exceptions.Null_Id);
 545    end Complete_Rendezvous;
 546
 547    -------------------------------------
 548    -- Exceptional_Complete_Rendezvous --
 549    -------------------------------------
 550
 551    procedure Exceptional_Complete_Rendezvous
 552      (Ex : Ada.Exceptions.Exception_Id)
 553    is
 554       Self_Id                : constant Task_Id := STPO.Self;
 555       Entry_Call             : Entry_Call_Link := Self_Id.Common.Call;
 556       Caller                 : Task_Id;
 557       Called_PO              : STPE.Protection_Entries_Access;
 558       Acceptor_Prev_Priority : Integer;
 559
 560       Exception_To_Raise : Ada.Exceptions.Exception_Id := Ex;
 561       Ceiling_Violation  : Boolean;
 562
 563       use type Ada.Exceptions.Exception_Id;
 564       procedure Internal_Reraise;
 565       pragma Import (C, Internal_Reraise, "__gnat_reraise");
 566
 567       procedure Transfer_Occurrence
 568         (Target : Ada.Exceptions.Exception_Occurrence_Access;
 569          Source : Ada.Exceptions.Exception_Occurrence);
 570       pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
 571
 572       use type STPE.Protection_Entries_Access;
 573
 574    begin
 575       --  Consider phasing out Complete_Rendezvous in favor
 576       --  of direct call to this with Ada.Exceptions.Null_ID.
 577       --  See code expansion examples for Accept_Call and Selective_Wait.
 578       --  Also consider putting an explicit re-raise after this call, in
 579       --  the generated code. That way we could eliminate the
 580       --  code here that reraises the exception.
 581
 582       --  The deferral level is critical here,
 583       --  since we want to raise an exception or allow abort to take
 584       --  place, if there is an exception or abort pending.
 585
 586       pragma Debug
 587        (Debug.Trace (Self_Id, "Exceptional_Complete_Rendezvous", 'R'));
 588
 589       if Ex = Ada.Exceptions.Null_Id then
 590          --  The call came from normal end-of-rendezvous,
 591          --  so abort is not yet deferred.
 592
 593          if Parameters.Runtime_Traces then
 594             Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
 595          end if;
 596
 597          Initialization.Defer_Abort_Nestable (Self_Id);
 598       end if;
 599
 600       --  We need to clean up any accepts which Self may have
 601       --  been serving when it was aborted.
 602
 603       if Ex = Standard'Abort_Signal'Identity then
 604          if Single_Lock then
 605             Lock_RTS;
 606          end if;
 607
 608          while Entry_Call /= null loop
 609             Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
 610
 611             --  All forms of accept make sure that the acceptor is not
 612             --  completed, before accepting further calls, so that we
 613             --  can be sure that no further calls are made after the
 614             --  current calls are purged.
 615
 616             Caller := Entry_Call.Self;
 617
 618             --  Take write lock. This follows the lock precedence rule that
 619             --  Caller may be locked while holding lock of Acceptor.
 620             --  Complete the call abnormally, with exception.
 621
 622             STPO.Write_Lock (Caller);
 623             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 624             STPO.Unlock (Caller);
 625             Entry_Call := Entry_Call.Acceptor_Prev_Call;
 626          end loop;
 627
 628          if Single_Lock then
 629             Unlock_RTS;
 630          end if;
 631
 632       else
 633          Caller := Entry_Call.Self;
 634
 635          if Entry_Call.Needs_Requeue then
 636             --  We dare not lock Self_Id at the same time as Caller,
 637             --  for fear of deadlock.
 638
 639             Entry_Call.Needs_Requeue := False;
 640             Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
 641
 642             if Entry_Call.Called_Task /= null then
 643                --  Requeue to another task entry
 644
 645                if Single_Lock then
 646                   Lock_RTS;
 647                end if;
 648
 649                if not Task_Do_Or_Queue
 650                  (Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)
 651                then
 652                   if Single_Lock then
 653                      Unlock_RTS;
 654                   end if;
 655
 656                   Initialization.Undefer_Abort (Self_Id);
 657                   raise Tasking_Error;
 658                end if;
 659
 660                if Single_Lock then
 661                   Unlock_RTS;
 662                end if;
 663
 664             else
 665                --  Requeue to a protected entry
 666
 667                Called_PO := POE.To_Protection (Entry_Call.Called_PO);
 668                STPE.Lock_Entries (Called_PO, Ceiling_Violation);
 669
 670                if Ceiling_Violation then
 671                   pragma Assert (Ex = Ada.Exceptions.Null_Id);
 672
 673                   Exception_To_Raise := Program_Error'Identity;
 674                   Entry_Call.Exception_To_Raise := Exception_To_Raise;
 675
 676                   if Single_Lock then
 677                      Lock_RTS;
 678                   end if;
 679
 680                   STPO.Write_Lock (Caller);
 681                   Initialization.Wakeup_Entry_Caller
 682                     (Self_Id, Entry_Call, Done);
 683                   STPO.Unlock (Caller);
 684
 685                   if Single_Lock then
 686                      Unlock_RTS;
 687                   end if;
 688
 689                else
 690                   POO.PO_Do_Or_Queue
 691                     (Self_Id, Called_PO, Entry_Call,
 692                      Entry_Call.Requeue_With_Abort);
 693                   POO.PO_Service_Entries (Self_Id, Called_PO);
 694                end if;
 695             end if;
 696
 697             Entry_Calls.Reset_Priority
 698               (Self_Id, Entry_Call.Acceptor_Prev_Priority);
 699
 700          else
 701             --  The call does not need to be requeued
 702
 703             Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
 704             Entry_Call.Exception_To_Raise := Ex;
 705
 706             if Single_Lock then
 707                Lock_RTS;
 708             end if;
 709
 710             STPO.Write_Lock (Caller);
 711
 712             --  Done with Caller locked to make sure that Wakeup is not lost
 713
 714             if Ex /= Ada.Exceptions.Null_Id then
 715                Transfer_Occurrence
 716                  (Caller.Common.Compiler_Data.Current_Excep'Access,
 717                   Self_Id.Common.Compiler_Data.Current_Excep);
 718             end if;
 719
 720             Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
 721             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 722
 723             STPO.Unlock (Caller);
 724
 725             if Single_Lock then
 726                Unlock_RTS;
 727             end if;
 728
 729             Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
 730          end if;
 731       end if;
 732
 733       Initialization.Undefer_Abort (Self_Id);
 734
 735       if Exception_To_Raise /= Ada.Exceptions.Null_Id then
 736          Internal_Reraise;
 737       end if;
 738
 739       --  ??? Do we need to give precedence to Program_Error that might be
 740       --  raised due to failure of finalization, over Tasking_Error from
 741       --  failure of requeue?
 742    end Exceptional_Complete_Rendezvous;
 743
 744    -------------------------------------
 745    -- Requeue_Protected_To_Task_Entry --
 746    -------------------------------------
 747
 748    procedure Requeue_Protected_To_Task_Entry
 749      (Object     : STPE.Protection_Entries_Access;
 750       Acceptor   : Task_Id;
 751       E          : Task_Entry_Index;
 752       With_Abort : Boolean)
 753    is
 754       Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
 755    begin
 756       pragma Assert (STPO.Self.Deferral_Level > 0);
 757
 758       Entry_Call.E := Entry_Index (E);
 759       Entry_Call.Called_Task := Acceptor;
 760       Entry_Call.Called_PO := Null_Address;
 761       Entry_Call.Requeue_With_Abort := With_Abort;
 762       Object.Call_In_Progress := null;
 763    end Requeue_Protected_To_Task_Entry;
 764
 765    ------------------------
 766    -- Requeue_Task_Entry --
 767    ------------------------
 768
 769    procedure Requeue_Task_Entry
 770      (Acceptor   : Task_Id;
 771       E          : Task_Entry_Index;
 772       With_Abort : Boolean)
 773    is
 774       Self_Id    : constant Task_Id := STPO.Self;
 775       Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
 776
 777    begin
 778       Initialization.Defer_Abort (Self_Id);
 779       Entry_Call.Needs_Requeue := True;
 780       Entry_Call.Requeue_With_Abort := With_Abort;
 781       Entry_Call.E := Entry_Index (E);
 782       Entry_Call.Called_Task := Acceptor;
 783       Initialization.Undefer_Abort (Self_Id);
 784    end Requeue_Task_Entry;
 785
 786    --------------------
 787    -- Selective_Wait --
 788    --------------------
 789
 790    procedure Selective_Wait
 791      (Open_Accepts       : Accept_List_Access;
 792       Select_Mode        : Select_Modes;
 793       Uninterpreted_Data : out System.Address;
 794       Index              : out Select_Index)
 795    is
 796       Self_Id          : constant Task_Id := STPO.Self;
 797       Entry_Call       : Entry_Call_Link;
 798       Treatment        : Select_Treatment;
 799       Caller           : Task_Id;
 800       Selection        : Select_Index;
 801       Open_Alternative : Boolean;
 802
 803    begin
 804       Initialization.Defer_Abort (Self_Id);
 805
 806       if Single_Lock then
 807          Lock_RTS;
 808       end if;
 809
 810       STPO.Write_Lock (Self_Id);
 811
 812       if not Self_Id.Callable then
 813          pragma Assert (Self_Id.Pending_ATC_Level = 0);
 814
 815          pragma Assert (Self_Id.Pending_Action);
 816
 817          STPO.Unlock (Self_Id);
 818
 819          if Single_Lock then
 820             Unlock_RTS;
 821          end if;
 822
 823          --  ??? In some cases abort is deferred more than once. Need to
 824          --  figure out why this happens.
 825
 826          if Self_Id.Deferral_Level > 1 then
 827             Self_Id.Deferral_Level := 1;
 828          end if;
 829
 830          Initialization.Undefer_Abort (Self_Id);
 831
 832          --  Should never get here ???
 833
 834          pragma Assert (False);
 835          raise Standard'Abort_Signal;
 836       end if;
 837
 838       pragma Assert (Open_Accepts /= null);
 839
 840       Uninterpreted_Data := Null_Address;
 841
 842       Queuing.Select_Task_Entry_Call
 843         (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
 844
 845       --  Determine the kind and disposition of the select
 846
 847       Treatment := Default_Treatment (Select_Mode);
 848       Self_Id.Chosen_Index := No_Rendezvous;
 849
 850       if Open_Alternative then
 851          if Entry_Call /= null then
 852             if Open_Accepts (Selection).Null_Body then
 853                Treatment := Accept_Alternative_Completed;
 854             else
 855                Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
 856                Treatment := Accept_Alternative_Selected;
 857             end if;
 858
 859             Self_Id.Chosen_Index := Selection;
 860
 861          elsif Treatment = No_Alternative_Open then
 862             Treatment := Accept_Alternative_Open;
 863          end if;
 864       end if;
 865
 866       --  Handle the select according to the disposition selected above
 867
 868       case Treatment is
 869          when Accept_Alternative_Selected =>
 870             --  Ready to rendezvous
 871
 872             Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 873
 874             --  In this case the accept body is not Null_Body. Defer abort
 875             --  until it gets into the accept body.
 876
 877             pragma Assert (Self_Id.Deferral_Level = 1);
 878
 879             Initialization.Defer_Abort_Nestable (Self_Id);
 880             STPO.Unlock (Self_Id);
 881
 882          when Accept_Alternative_Completed =>
 883
 884             --  Accept body is null, so rendezvous is over immediately
 885
 886             if Parameters.Runtime_Traces then
 887                Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
 888             end if;
 889
 890             STPO.Unlock (Self_Id);
 891             Caller := Entry_Call.Self;
 892
 893             STPO.Write_Lock (Caller);
 894             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 895             STPO.Unlock (Caller);
 896
 897          when Accept_Alternative_Open =>
 898
 899             --  Wait for caller
 900
 901             Self_Id.Open_Accepts := Open_Accepts;
 902             pragma Debug
 903               (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
 904
 905             if Parameters.Runtime_Traces then
 906                Send_Trace_Info (W_Select, Self_Id,
 907                                 Integer (Open_Accepts'Length));
 908             end if;
 909
 910             Wait_For_Call (Self_Id);
 911
 912             pragma Assert (Self_Id.Open_Accepts = null);
 913
 914             --  Self_Id.Common.Call should already be updated by the Caller if
 915             --  not aborted. It might also be ready to do rendezvous even if
 916             --  this wakes up due to an abort. Therefore, if the call is not
 917             --  empty we need to do the rendezvous if the accept body is not
 918             --  Null_Body.
 919
 920             --  Aren't the first two conditions below redundant???
 921
 922             if Self_Id.Chosen_Index /= No_Rendezvous
 923               and then Self_Id.Common.Call /= null
 924               and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
 925             then
 926                Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 927
 928                pragma Assert
 929                  (Self_Id.Deferral_Level = 1
 930                    or else
 931                      (Self_Id.Deferral_Level = 0
 932                        and then not Restrictions.Abort_Allowed));
 933
 934                Initialization.Defer_Abort_Nestable (Self_Id);
 935
 936                --  Leave abort deferred until the accept body
 937             end if;
 938
 939             STPO.Unlock (Self_Id);
 940
 941          when Else_Selected =>
 942             pragma Assert (Self_Id.Open_Accepts = null);
 943
 944             if Parameters.Runtime_Traces then
 945                Send_Trace_Info (M_Select_Else);
 946             end if;
 947
 948             STPO.Unlock (Self_Id);
 949
 950          when Terminate_Selected =>
 951             --  Terminate alternative is open
 952
 953             Self_Id.Open_Accepts := Open_Accepts;
 954             Self_Id.Common.State := Acceptor_Sleep;
 955
 956             --  Notify ancestors that this task is on a terminate alternative
 957
 958             STPO.Unlock (Self_Id);
 959             Utilities.Make_Passive (Self_Id, Task_Completed => False);
 960             STPO.Write_Lock (Self_Id);
 961
 962             --  Wait for normal entry call or termination
 963
 964             Wait_For_Call (Self_Id);
 965
 966             pragma Assert (Self_Id.Open_Accepts = null);
 967
 968             if Self_Id.Terminate_Alternative then
 969                --  An entry call should have reset this to False,
 970                --  so we must be aborted.
 971                --  We cannot be in an async. select, since that
 972                --  is not legal, so the abort must be of the entire
 973                --  task.  Therefore, we do not need to cancel the
 974                --  terminate alternative.  The cleanup will be done
 975                --  in Complete_Master.
 976
 977                pragma Assert (Self_Id.Pending_ATC_Level = 0);
 978                pragma Assert (Self_Id.Awake_Count = 0);
 979
 980                STPO.Unlock (Self_Id);
 981
 982                if Single_Lock then
 983                   Unlock_RTS;
 984                end if;
 985
 986                Index := Self_Id.Chosen_Index;
 987                Initialization.Undefer_Abort_Nestable (Self_Id);
 988
 989                if Self_Id.Pending_Action then
 990                   Initialization.Do_Pending_Action (Self_Id);
 991                end if;
 992
 993                return;
 994
 995             else
 996                --  Self_Id.Common.Call and Self_Id.Chosen_Index
 997                --  should already be updated by the Caller.
 998
 999                if Self_Id.Chosen_Index /= No_Rendezvous
1000                  and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1001                then
1002                   Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1003
1004                   pragma Assert (Self_Id.Deferral_Level = 1);
1005
1006                   --  We need an extra defer here, to keep abort
1007                   --  deferred until we get into the accept body
1008
1009                   Initialization.Defer_Abort_Nestable (Self_Id);
1010                end if;
1011             end if;
1012
1013             STPO.Unlock (Self_Id);
1014
1015          when No_Alternative_Open =>
1016             --  In this case, Index will be No_Rendezvous on return, which
1017             --  should cause a Program_Error if it is not a Delay_Mode.
1018
1019             --  If delay alternative exists (Delay_Mode) we should suspend
1020             --  until the delay expires.
1021
1022             Self_Id.Open_Accepts := null;
1023
1024             if Select_Mode = Delay_Mode then
1025                Self_Id.Common.State := Delay_Sleep;
1026
1027                loop
1028                   exit when
1029                     Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
1030                   Sleep (Self_Id, Delay_Sleep);
1031                end loop;
1032
1033                Self_Id.Common.State := Runnable;
1034                STPO.Unlock (Self_Id);
1035
1036             else
1037                STPO.Unlock (Self_Id);
1038
1039                if Single_Lock then
1040                   Unlock_RTS;
1041                end if;
1042
1043                Initialization.Undefer_Abort (Self_Id);
1044                Ada.Exceptions.Raise_Exception
1045                  (Program_Error'Identity, "Entry call not a delay mode");
1046             end if;
1047       end case;
1048
1049       if Single_Lock then
1050          Unlock_RTS;
1051       end if;
1052
1053       --  Caller has been chosen.
1054       --  Self_Id.Common.Call should already be updated by the Caller.
1055       --  Self_Id.Chosen_Index should either be updated by the Caller
1056       --  or by Test_Selective_Wait.
1057       --  On return, we sill start rendezvous unless the accept body is
1058       --  null. In the latter case, we will have already completed the RV.
1059
1060       Index := Self_Id.Chosen_Index;
1061       Initialization.Undefer_Abort_Nestable (Self_Id);
1062    end Selective_Wait;
1063
1064    ------------------------------------
1065    -- Setup_For_Rendezvous_With_Body --
1066    ------------------------------------
1067
1068    procedure Setup_For_Rendezvous_With_Body
1069      (Entry_Call : Entry_Call_Link;
1070       Acceptor   : Task_Id) is
1071    begin
1072       Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1073       Acceptor.Common.Call := Entry_Call;
1074
1075       if Entry_Call.State = Now_Abortable then
1076          Entry_Call.State := Was_Abortable;
1077       end if;
1078
1079       Boost_Priority (Entry_Call, Acceptor);
1080    end Setup_For_Rendezvous_With_Body;
1081
1082    ----------------
1083    -- Task_Count --
1084    ----------------
1085
1086    function Task_Count (E : Task_Entry_Index) return Natural is
1087       Self_Id      : constant Task_Id := STPO.Self;
1088       Return_Count : Natural;
1089
1090    begin
1091       Initialization.Defer_Abort (Self_Id);
1092
1093       if Single_Lock then
1094          Lock_RTS;
1095       end if;
1096
1097       STPO.Write_Lock (Self_Id);
1098       Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1099       STPO.Unlock (Self_Id);
1100
1101       if Single_Lock then
1102          Unlock_RTS;
1103       end if;
1104
1105       --  Call Yield to let other tasks get a chance to run as this is a
1106       --  potential dispatching point.
1107
1108       Yield (Do_Yield => False);
1109
1110       Initialization.Undefer_Abort (Self_Id);
1111       return Return_Count;
1112    end Task_Count;
1113
1114    ----------------------
1115    -- Task_Do_Or_Queue --
1116    ----------------------
1117
1118    function Task_Do_Or_Queue
1119      (Self_ID    : Task_Id;
1120       Entry_Call : Entry_Call_Link;
1121       With_Abort : Boolean) return Boolean
1122    is
1123       E             : constant Task_Entry_Index :=
1124                         Task_Entry_Index (Entry_Call.E);
1125       Old_State     : constant Entry_Call_State := Entry_Call.State;
1126       Acceptor      : constant Task_Id := Entry_Call.Called_Task;
1127       Parent        : constant Task_Id := Acceptor.Common.Parent;
1128       Parent_Locked : Boolean := False;
1129       Null_Body     : Boolean;
1130
1131    begin
1132       --  Find out whether Entry_Call can be accepted immediately
1133
1134       --  If the Acceptor is not callable, return False.
1135       --  If the rendezvous can start, initiate it.
1136       --  If the accept-body is trivial, also complete the rendezvous.
1137       --  If the acceptor is not ready, enqueue the call.
1138
1139       --  This should have a special case for Accept_Call and Accept_Trivial,
1140       --  so that we don't have the loop setup overhead, below.
1141
1142       --  The call state Done is used here and elsewhere to include both the
1143       --  case of normal successful completion, and the case of an exception
1144       --  being raised. The difference is that if an exception is raised no one
1145       --  will pay attention to the fact that State = Done. Instead the
1146       --  exception will be raised in Undefer_Abort, and control will skip past
1147       --  the place where we normally would resume from an entry call.
1148
1149       pragma Assert (not Queuing.Onqueue (Entry_Call));
1150
1151       --  We rely that the call is off-queue for protection, that the caller
1152       --  will not exit the Entry_Caller_Sleep, and so will not reuse the call
1153       --  record for another call.
1154       --  We rely on the Caller's lock for call State mod's.
1155
1156       --  We can't lock Acceptor.Parent while holding Acceptor,
1157       --  so lock it in advance if we expect to need to lock it.
1158
1159       if Acceptor.Terminate_Alternative then
1160          STPO.Write_Lock (Parent);
1161          Parent_Locked := True;
1162       end if;
1163
1164       STPO.Write_Lock (Acceptor);
1165
1166       --  If the acceptor is not callable, abort the call and return False
1167
1168       if not Acceptor.Callable then
1169          STPO.Unlock (Acceptor);
1170
1171          if Parent_Locked then
1172             STPO.Unlock (Parent);
1173          end if;
1174
1175          pragma Assert (Entry_Call.State < Done);
1176
1177          --  In case we are not the caller, set up the caller
1178          --  to raise Tasking_Error when it wakes up.
1179
1180          STPO.Write_Lock (Entry_Call.Self);
1181          Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1182          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1183          STPO.Unlock (Entry_Call.Self);
1184
1185          return False;
1186       end if;
1187
1188       --  Try to serve the call immediately
1189
1190       if Acceptor.Open_Accepts /= null then
1191          for J in Acceptor.Open_Accepts'Range loop
1192             if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1193
1194                --  Commit acceptor to rendezvous with us
1195
1196                Acceptor.Chosen_Index := J;
1197                Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1198                Acceptor.Open_Accepts := null;
1199
1200                --  Prevent abort while call is being served
1201
1202                if Entry_Call.State = Now_Abortable then
1203                   Entry_Call.State := Was_Abortable;
1204                end if;
1205
1206                if Acceptor.Terminate_Alternative then
1207
1208                   --  Cancel terminate alternative. See matching code in
1209                   --  Selective_Wait and Vulnerable_Complete_Master.
1210
1211                   Acceptor.Terminate_Alternative := False;
1212                   Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1213
1214                   if Acceptor.Awake_Count = 1 then
1215
1216                      --  Notify parent that acceptor is awake
1217
1218                      pragma Assert (Parent.Awake_Count > 0);
1219
1220                      Parent.Awake_Count := Parent.Awake_Count + 1;
1221
1222                      if Parent.Common.State = Master_Completion_Sleep
1223                        and then Acceptor.Master_of_Task = Parent.Master_Within
1224                      then
1225                         Parent.Common.Wait_Count :=
1226                           Parent.Common.Wait_Count + 1;
1227                      end if;
1228                   end if;
1229                end if;
1230
1231                if Null_Body then
1232
1233                   --  Rendezvous is over immediately
1234
1235                   STPO.Wakeup (Acceptor, Acceptor_Sleep);
1236                   STPO.Unlock (Acceptor);
1237
1238                   if Parent_Locked then
1239                      STPO.Unlock (Parent);
1240                   end if;
1241
1242                   STPO.Write_Lock (Entry_Call.Self);
1243                   Initialization.Wakeup_Entry_Caller
1244                     (Self_ID, Entry_Call, Done);
1245                   STPO.Unlock (Entry_Call.Self);
1246
1247                else
1248                   Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1249
1250                   --  For terminate_alternative, acceptor may not be asleep
1251                   --  yet, so we skip the wakeup
1252
1253                   if Acceptor.Common.State /= Runnable then
1254                      STPO.Wakeup (Acceptor, Acceptor_Sleep);
1255                   end if;
1256
1257                   STPO.Unlock (Acceptor);
1258
1259                   if Parent_Locked then
1260                      STPO.Unlock (Parent);
1261                   end if;
1262                end if;
1263
1264                return True;
1265             end if;
1266          end loop;
1267
1268          --  The acceptor is accepting, but not this entry
1269       end if;
1270
1271       --  If the acceptor was ready to accept this call,
1272       --  we would not have gotten this far, so now we should
1273       --  (re)enqueue the call, if the mode permits that.
1274
1275       if Entry_Call.Mode /= Conditional_Call
1276         or else not With_Abort
1277       then
1278          --  Timed_Call, Simple_Call, or Asynchronous_Call
1279
1280          Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1281
1282          --  Update abortability of call
1283
1284          pragma Assert (Old_State < Done);
1285
1286          Entry_Call.State := New_State (With_Abort, Entry_Call.State);
1287
1288          STPO.Unlock (Acceptor);
1289
1290          if Parent_Locked then
1291             STPO.Unlock (Parent);
1292          end if;
1293
1294          if Old_State /= Entry_Call.State
1295            and then Entry_Call.State = Now_Abortable
1296            and then Entry_Call.Mode > Simple_Call
1297            and then Entry_Call.Self /= Self_ID
1298
1299          --  Asynchronous_Call or Conditional_Call
1300
1301          then
1302             --  Because of ATCB lock ordering rule
1303
1304             STPO.Write_Lock (Entry_Call.Self);
1305
1306             if Entry_Call.Self.Common.State = Async_Select_Sleep then
1307
1308                --  Caller may not yet have reached wait-point
1309
1310                STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1311             end if;
1312
1313             STPO.Unlock (Entry_Call.Self);
1314          end if;
1315
1316       else
1317          --  Conditional_Call and With_Abort
1318
1319          STPO.Unlock (Acceptor);
1320
1321          if Parent_Locked then
1322             STPO.Unlock (Parent);
1323          end if;
1324
1325          STPO.Write_Lock (Entry_Call.Self);
1326
1327          pragma Assert (Entry_Call.State >= Was_Abortable);
1328
1329          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1330          STPO.Unlock (Entry_Call.Self);
1331       end if;
1332
1333       return True;
1334    end Task_Do_Or_Queue;
1335
1336    ---------------------
1337    -- Task_Entry_Call --
1338    ---------------------
1339
1340    procedure Task_Entry_Call
1341      (Acceptor              : Task_Id;
1342       E                     : Task_Entry_Index;
1343       Uninterpreted_Data    : System.Address;
1344       Mode                  : Call_Modes;
1345       Rendezvous_Successful : out Boolean)
1346    is
1347       Self_Id    : constant Task_Id := STPO.Self;
1348       Entry_Call : Entry_Call_Link;
1349
1350    begin
1351       --  If pragma Detect_Blocking is active then Program_Error must be
1352       --  raised if this potentially blocking operation is called from a
1353       --  protected action.
1354
1355       if System.Tasking.Detect_Blocking
1356         and then Self_Id.Common.Protected_Action_Nesting > 0
1357       then
1358          Ada.Exceptions.Raise_Exception
1359            (Program_Error'Identity, "potentially blocking operation");
1360       end if;
1361
1362       if Parameters.Runtime_Traces then
1363          Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1364       end if;
1365
1366       if Mode = Simple_Call or else Mode = Conditional_Call then
1367          Call_Synchronous
1368            (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1369
1370       else
1371          --  This is an asynchronous call
1372
1373          --  Abort must already be deferred by the compiler-generated code.
1374          --  Without this, an abort that occurs between the time that this
1375          --  call is made and the time that the abortable part's cleanup
1376          --  handler is set up might miss the cleanup handler and leave the
1377          --  call pending.
1378
1379          Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1380          pragma Debug
1381            (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1382             ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1383          Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1384          Entry_Call.Next := null;
1385          Entry_Call.Mode := Mode;
1386          Entry_Call.Cancellation_Attempted := False;
1387          Entry_Call.State := Not_Yet_Abortable;
1388          Entry_Call.E := Entry_Index (E);
1389          Entry_Call.Prio := Get_Priority (Self_Id);
1390          Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1391          Entry_Call.Called_Task := Acceptor;
1392          Entry_Call.Called_PO := Null_Address;
1393          Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1394
1395          if Single_Lock then
1396             Lock_RTS;
1397          end if;
1398
1399          if not Task_Do_Or_Queue
1400            (Self_Id, Entry_Call, With_Abort => True)
1401          then
1402             STPO.Write_Lock (Self_Id);
1403             Utilities.Exit_One_ATC_Level (Self_Id);
1404             STPO.Unlock (Self_Id);
1405
1406             if Single_Lock then
1407                Unlock_RTS;
1408             end if;
1409
1410             Initialization.Undefer_Abort (Self_Id);
1411
1412             if Parameters.Runtime_Traces then
1413                Send_Trace_Info (E_Missed, Acceptor);
1414             end if;
1415
1416             raise Tasking_Error;
1417          end if;
1418
1419          --  The following is special for async. entry calls.
1420          --  If the call was not queued abortably, we need to wait until
1421          --  it is before proceeding with the abortable part.
1422
1423          --  Wait_Until_Abortable can be called unconditionally here,
1424          --  but it is expensive.
1425
1426          if Entry_Call.State < Was_Abortable then
1427             Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1428          end if;
1429
1430          if Single_Lock then
1431             Unlock_RTS;
1432          end if;
1433
1434          --  Note: following assignment needs to be atomic
1435
1436          Rendezvous_Successful := Entry_Call.State = Done;
1437       end if;
1438    end Task_Entry_Call;
1439
1440    -----------------------
1441    -- Task_Entry_Caller --
1442    -----------------------
1443
1444    function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1445       Self_Id    : constant Task_Id := STPO.Self;
1446       Entry_Call : Entry_Call_Link;
1447
1448    begin
1449       Entry_Call := Self_Id.Common.Call;
1450
1451       for Depth in 1 .. D loop
1452          Entry_Call := Entry_Call.Acceptor_Prev_Call;
1453          pragma Assert (Entry_Call /= null);
1454       end loop;
1455
1456       return Entry_Call.Self;
1457    end Task_Entry_Caller;
1458
1459    --------------------------
1460    -- Timed_Selective_Wait --
1461    --------------------------
1462
1463    procedure Timed_Selective_Wait
1464      (Open_Accepts       : Accept_List_Access;
1465       Select_Mode        : Select_Modes;
1466       Uninterpreted_Data : out System.Address;
1467       Timeout            : Duration;
1468       Mode               : Delay_Modes;
1469       Index              : out Select_Index)
1470    is
1471       Self_Id          : constant Task_Id := STPO.Self;
1472       Treatment        : Select_Treatment;
1473       Entry_Call       : Entry_Call_Link;
1474       Caller           : Task_Id;
1475       Selection        : Select_Index;
1476       Open_Alternative : Boolean;
1477       Timedout         : Boolean := False;
1478       Yielded          : Boolean := True;
1479
1480    begin
1481       pragma Assert (Select_Mode = Delay_Mode);
1482
1483       Initialization.Defer_Abort (Self_Id);
1484
1485       --  If we are aborted here, the effect will be pending
1486
1487       if Single_Lock then
1488          Lock_RTS;
1489       end if;
1490
1491       STPO.Write_Lock (Self_Id);
1492
1493       if not Self_Id.Callable then
1494          pragma Assert (Self_Id.Pending_ATC_Level = 0);
1495
1496          pragma Assert (Self_Id.Pending_Action);
1497
1498          STPO.Unlock (Self_Id);
1499
1500          if Single_Lock then
1501             Unlock_RTS;
1502          end if;
1503
1504          Initialization.Undefer_Abort (Self_Id);
1505
1506          --  Should never get here ???
1507
1508          pragma Assert (False);
1509          raise Standard'Abort_Signal;
1510       end if;
1511
1512       Uninterpreted_Data := Null_Address;
1513
1514       pragma Assert (Open_Accepts /= null);
1515
1516       Queuing.Select_Task_Entry_Call
1517         (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1518
1519       --  Determine the kind and disposition of the select
1520
1521       Treatment := Default_Treatment (Select_Mode);
1522       Self_Id.Chosen_Index := No_Rendezvous;
1523
1524       if Open_Alternative then
1525          if Entry_Call /= null then
1526             if Open_Accepts (Selection).Null_Body then
1527                Treatment := Accept_Alternative_Completed;
1528
1529             else
1530                Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1531                Treatment := Accept_Alternative_Selected;
1532             end if;
1533
1534             Self_Id.Chosen_Index := Selection;
1535
1536          elsif Treatment = No_Alternative_Open then
1537             Treatment := Accept_Alternative_Open;
1538          end if;
1539       end if;
1540
1541       --  Handle the select according to the disposition selected above
1542
1543       case Treatment is
1544          when Accept_Alternative_Selected =>
1545             --  Ready to rendezvous
1546             --  In this case the accept body is not Null_Body. Defer abort
1547             --  until it gets into the accept body.
1548
1549             Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1550             Initialization.Defer_Abort (Self_Id);
1551             STPO.Unlock (Self_Id);
1552
1553          when Accept_Alternative_Completed =>
1554             --  Rendezvous is over
1555
1556             if Parameters.Runtime_Traces then
1557                Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1558             end if;
1559
1560             STPO.Unlock (Self_Id);
1561             Caller := Entry_Call.Self;
1562
1563             STPO.Write_Lock (Caller);
1564             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1565             STPO.Unlock (Caller);
1566
1567          when Accept_Alternative_Open =>
1568
1569             --  Wait for caller
1570
1571             Self_Id.Open_Accepts := Open_Accepts;
1572
1573             --  Wait for a normal call and a pending action until the
1574             --  Wakeup_Time is reached.
1575
1576             Self_Id.Common.State := Acceptor_Sleep;
1577
1578             --  Try to remove calls to Sleep in the loop below by letting the
1579             --  caller a chance of getting ready immediately, using Unlock
1580             --  Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1581
1582             if Single_Lock then
1583                Unlock_RTS;
1584             else
1585                Unlock (Self_Id);
1586             end if;
1587
1588             if Self_Id.Open_Accepts /= null then
1589                Yield;
1590             end if;
1591
1592             if Single_Lock then
1593                Lock_RTS;
1594             else
1595                Write_Lock (Self_Id);
1596             end if;
1597
1598             --  Check if this task has been aborted while the lock was released
1599
1600             if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1601                Self_Id.Open_Accepts := null;
1602             end if;
1603
1604             loop
1605                exit when Self_Id.Open_Accepts = null;
1606
1607                if Timedout then
1608                   Sleep (Self_Id, Acceptor_Sleep);
1609                else
1610                   if Parameters.Runtime_Traces then
1611                      Send_Trace_Info (WT_Select,
1612                                       Self_Id,
1613                                       Integer (Open_Accepts'Length),
1614                                       Timeout);
1615                   end if;
1616
1617                   STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1618                     Acceptor_Sleep, Timedout, Yielded);
1619                end if;
1620
1621                if Timedout then
1622                   Self_Id.Open_Accepts := null;
1623
1624                   if Parameters.Runtime_Traces then
1625                      Send_Trace_Info (E_Timeout);
1626                   end if;
1627                end if;
1628             end loop;
1629
1630             Self_Id.Common.State := Runnable;
1631
1632             --  Self_Id.Common.Call should already be updated by the Caller if
1633             --  not aborted. It might also be ready to do rendezvous even if
1634             --  this wakes up due to an abort. Therefore, if the call is not
1635             --  empty we need to do the rendezvous if the accept body is not
1636             --  Null_Body.
1637
1638             if Self_Id.Chosen_Index /= No_Rendezvous
1639               and then Self_Id.Common.Call /= null
1640               and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1641             then
1642                Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1643
1644                pragma Assert (Self_Id.Deferral_Level = 1);
1645
1646                Initialization.Defer_Abort_Nestable (Self_Id);
1647
1648                --  Leave abort deferred until the accept body
1649             end if;
1650
1651             STPO.Unlock (Self_Id);
1652
1653          when No_Alternative_Open =>
1654             --  In this case, Index will be No_Rendezvous on return. We sleep
1655             --  for the time we need to.
1656             --  Wait for a signal or timeout. A wakeup can be made
1657             --  for several reasons:
1658             --  1) Delay is expired
1659             --  2) Pending_Action needs to be checked
1660             --     (Abort, Priority change)
1661             --  3) Spurious wakeup
1662
1663             Self_Id.Open_Accepts := null;
1664             Self_Id.Common.State := Acceptor_Sleep;
1665
1666             STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
1667               Timedout, Yielded);
1668
1669             Self_Id.Common.State := Runnable;
1670
1671             STPO.Unlock (Self_Id);
1672
1673          when others =>
1674             --  Should never get here
1675             pragma Assert (False);
1676             null;
1677       end case;
1678
1679       if Single_Lock then
1680          Unlock_RTS;
1681       end if;
1682
1683       if not Yielded then
1684          Yield;
1685       end if;
1686
1687       --  Caller has been chosen
1688
1689       --  Self_Id.Common.Call should already be updated by the Caller
1690
1691       --  Self_Id.Chosen_Index should either be updated by the Caller
1692       --  or by Test_Selective_Wait
1693
1694       Index := Self_Id.Chosen_Index;
1695       Initialization.Undefer_Abort_Nestable (Self_Id);
1696
1697       --  Start rendezvous, if not already completed
1698    end Timed_Selective_Wait;
1699
1700    ---------------------------
1701    -- Timed_Task_Entry_Call --
1702    ---------------------------
1703
1704    procedure Timed_Task_Entry_Call
1705      (Acceptor              : Task_Id;
1706       E                     : Task_Entry_Index;
1707       Uninterpreted_Data    : System.Address;
1708       Timeout               : Duration;
1709       Mode                  : Delay_Modes;
1710       Rendezvous_Successful : out Boolean)
1711    is
1712       Self_Id    : constant Task_Id := STPO.Self;
1713       Level      : ATC_Level;
1714       Entry_Call : Entry_Call_Link;
1715       Yielded    : Boolean;
1716
1717    begin
1718       --  If pragma Detect_Blocking is active then Program_Error must be
1719       --  raised if this potentially blocking operation is called from a
1720       --  protected action.
1721
1722       if System.Tasking.Detect_Blocking
1723         and then Self_Id.Common.Protected_Action_Nesting > 0
1724       then
1725          Ada.Exceptions.Raise_Exception
1726            (Program_Error'Identity, "potentially blocking operation");
1727       end if;
1728
1729       Initialization.Defer_Abort (Self_Id);
1730       Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1731
1732       pragma Debug
1733         (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1734          ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1735
1736       if Parameters.Runtime_Traces then
1737          Send_Trace_Info (WT_Call, Acceptor,
1738                           Entry_Index (E), Timeout);
1739       end if;
1740
1741       Level := Self_Id.ATC_Nesting_Level;
1742       Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1743       Entry_Call.Next := null;
1744       Entry_Call.Mode := Timed_Call;
1745       Entry_Call.Cancellation_Attempted := False;
1746
1747       --  If this is a call made inside of an abort deferred region,
1748       --  the call should be never abortable.
1749
1750       if Self_Id.Deferral_Level > 1 then
1751          Entry_Call.State := Never_Abortable;
1752       else
1753          Entry_Call.State := Now_Abortable;
1754       end if;
1755
1756       Entry_Call.E := Entry_Index (E);
1757       Entry_Call.Prio := Get_Priority (Self_Id);
1758       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1759       Entry_Call.Called_Task := Acceptor;
1760       Entry_Call.Called_PO := Null_Address;
1761       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1762
1763       --  Note: the caller will undefer abort on return (see WARNING above)
1764
1765       if Single_Lock then
1766          Lock_RTS;
1767       end if;
1768
1769       if not Task_Do_Or_Queue
1770        (Self_Id, Entry_Call, With_Abort => True)
1771       then
1772          STPO.Write_Lock (Self_Id);
1773          Utilities.Exit_One_ATC_Level (Self_Id);
1774          STPO.Unlock (Self_Id);
1775
1776          if Single_Lock then
1777             Unlock_RTS;
1778          end if;
1779
1780          Initialization.Undefer_Abort (Self_Id);
1781
1782          if Parameters.Runtime_Traces then
1783             Send_Trace_Info (E_Missed, Acceptor);
1784          end if;
1785          raise Tasking_Error;
1786       end if;
1787
1788       Write_Lock (Self_Id);
1789       Entry_Calls.Wait_For_Completion_With_Timeout
1790         (Entry_Call, Timeout, Mode, Yielded);
1791       Unlock (Self_Id);
1792
1793       if Single_Lock then
1794          Unlock_RTS;
1795       end if;
1796
1797       --  ??? Do we need to yield in case Yielded is False
1798
1799       Rendezvous_Successful := Entry_Call.State = Done;
1800       Initialization.Undefer_Abort (Self_Id);
1801       Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1802    end Timed_Task_Entry_Call;
1803
1804    -------------------
1805    -- Wait_For_Call --
1806    -------------------
1807
1808    procedure Wait_For_Call (Self_Id : Task_Id) is
1809    begin
1810       Self_Id.Common.State := Acceptor_Sleep;
1811
1812       --  Try to remove calls to Sleep in the loop below by letting the caller
1813       --  a chance of getting ready immediately, using Unlock & Yield.
1814       --  See similar action in Wait_For_Completion & Timed_Selective_Wait.
1815
1816       if Single_Lock then
1817          Unlock_RTS;
1818       else
1819          Unlock (Self_Id);
1820       end if;
1821
1822       if Self_Id.Open_Accepts /= null then
1823          Yield;
1824       end if;
1825
1826       if Single_Lock then
1827          Lock_RTS;
1828       else
1829          Write_Lock (Self_Id);
1830       end if;
1831
1832       --  Check if this task has been aborted while the lock was released
1833
1834       if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1835          Self_Id.Open_Accepts := null;
1836       end if;
1837
1838       loop
1839          exit when Self_Id.Open_Accepts = null;
1840          Sleep (Self_Id, Acceptor_Sleep);
1841       end loop;
1842
1843       Self_Id.Common.State := Runnable;
1844    end Wait_For_Call;
1845
1846 end System.Tasking.Rendezvous;