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