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-2014, 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       use type STPE.Protection_Entries_Access;
 551
 552    begin
 553       --  The deferral level is critical here, since we want to raise an
 554       --  exception or allow abort to take place, if there is an exception or
 555       --  abort pending.
 556
 557       pragma Debug
 558         (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R'));
 559
 560       if Ex = Ada.Exceptions.Null_Id then
 561
 562          --  The call came from normal end-of-rendezvous, so abort is not yet
 563          --  deferred.
 564
 565          if Parameters.Runtime_Traces then
 566             Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
 567          end if;
 568
 569          Initialization.Defer_Abort (Self_Id);
 570
 571       elsif ZCX_By_Default then
 572
 573          --  With ZCX, aborts are not automatically deferred in handlers
 574
 575          Initialization.Defer_Abort (Self_Id);
 576       end if;
 577
 578       --  We need to clean up any accepts which Self may have been serving when
 579       --  it was aborted.
 580
 581       if Ex = Standard'Abort_Signal'Identity then
 582          if Single_Lock then
 583             Lock_RTS;
 584          end if;
 585
 586          while Entry_Call /= null loop
 587             Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
 588
 589             --  All forms of accept make sure that the acceptor is not
 590             --  completed, before accepting further calls, so that we
 591             --  can be sure that no further calls are made after the
 592             --  current calls are purged.
 593
 594             Caller := Entry_Call.Self;
 595
 596             --  Take write lock. This follows the lock precedence rule that
 597             --  Caller may be locked while holding lock of Acceptor. Complete
 598             --  the call abnormally, with exception.
 599
 600             STPO.Write_Lock (Caller);
 601             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 602             STPO.Unlock (Caller);
 603             Entry_Call := Entry_Call.Acceptor_Prev_Call;
 604          end loop;
 605
 606          if Single_Lock then
 607             Unlock_RTS;
 608          end if;
 609
 610       else
 611          Caller := Entry_Call.Self;
 612
 613          if Entry_Call.Needs_Requeue then
 614
 615             --  We dare not lock Self_Id at the same time as Caller, for fear
 616             --  of deadlock.
 617
 618             Entry_Call.Needs_Requeue := False;
 619             Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
 620
 621             if Entry_Call.Called_Task /= null then
 622
 623                --  Requeue to another task entry
 624
 625                if Single_Lock then
 626                   Lock_RTS;
 627                end if;
 628
 629                if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
 630                   if Single_Lock then
 631                      Unlock_RTS;
 632                   end if;
 633
 634                   Initialization.Undefer_Abort (Self_Id);
 635                   raise Tasking_Error;
 636                end if;
 637
 638                if Single_Lock then
 639                   Unlock_RTS;
 640                end if;
 641
 642             else
 643                --  Requeue to a protected entry
 644
 645                Called_PO := POE.To_Protection (Entry_Call.Called_PO);
 646                STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation);
 647
 648                if Ceiling_Violation then
 649                   pragma Assert (Ex = Ada.Exceptions.Null_Id);
 650                   Entry_Call.Exception_To_Raise := Program_Error'Identity;
 651
 652                   if Single_Lock then
 653                      Lock_RTS;
 654                   end if;
 655
 656                   STPO.Write_Lock (Caller);
 657                   Initialization.Wakeup_Entry_Caller
 658                     (Self_Id, Entry_Call, Done);
 659                   STPO.Unlock (Caller);
 660
 661                   if Single_Lock then
 662                      Unlock_RTS;
 663                   end if;
 664
 665                else
 666                   POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call);
 667                   POO.PO_Service_Entries (Self_Id, Called_PO);
 668                end if;
 669             end if;
 670
 671             Entry_Calls.Reset_Priority
 672               (Self_Id, Entry_Call.Acceptor_Prev_Priority);
 673
 674          else
 675             --  The call does not need to be requeued
 676
 677             Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call;
 678             Entry_Call.Exception_To_Raise := Ex;
 679
 680             if Single_Lock then
 681                Lock_RTS;
 682             end if;
 683
 684             STPO.Write_Lock (Caller);
 685
 686             --  Done with Caller locked to make sure that Wakeup is not lost
 687
 688             if Ex /= Ada.Exceptions.Null_Id then
 689                Transfer_Occurrence
 690                  (Caller.Common.Compiler_Data.Current_Excep'Access,
 691                   Self_Id.Common.Compiler_Data.Current_Excep);
 692             end if;
 693
 694             Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority;
 695             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 696
 697             STPO.Unlock (Caller);
 698
 699             if Single_Lock then
 700                Unlock_RTS;
 701             end if;
 702
 703             Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority);
 704          end if;
 705       end if;
 706
 707       Initialization.Undefer_Abort (Self_Id);
 708    end Local_Complete_Rendezvous;
 709
 710    -------------------------------------
 711    -- Requeue_Protected_To_Task_Entry --
 712    -------------------------------------
 713
 714    procedure Requeue_Protected_To_Task_Entry
 715      (Object     : STPE.Protection_Entries_Access;
 716       Acceptor   : Task_Id;
 717       E          : Task_Entry_Index;
 718       With_Abort : Boolean)
 719    is
 720       Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
 721    begin
 722       pragma Assert (STPO.Self.Deferral_Level > 0);
 723
 724       Entry_Call.E := Entry_Index (E);
 725       Entry_Call.Called_Task := Acceptor;
 726       Entry_Call.Called_PO := Null_Address;
 727       Entry_Call.With_Abort := With_Abort;
 728       Object.Call_In_Progress := null;
 729    end Requeue_Protected_To_Task_Entry;
 730
 731    ------------------------
 732    -- Requeue_Task_Entry --
 733    ------------------------
 734
 735    procedure Requeue_Task_Entry
 736      (Acceptor   : Task_Id;
 737       E          : Task_Entry_Index;
 738       With_Abort : Boolean)
 739    is
 740       Self_Id    : constant Task_Id := STPO.Self;
 741       Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call;
 742    begin
 743       Initialization.Defer_Abort (Self_Id);
 744       Entry_Call.Needs_Requeue := True;
 745       Entry_Call.With_Abort := With_Abort;
 746       Entry_Call.E := Entry_Index (E);
 747       Entry_Call.Called_Task := Acceptor;
 748       Initialization.Undefer_Abort (Self_Id);
 749    end Requeue_Task_Entry;
 750
 751    --------------------
 752    -- Selective_Wait --
 753    --------------------
 754
 755    procedure Selective_Wait
 756      (Open_Accepts       : Accept_List_Access;
 757       Select_Mode        : Select_Modes;
 758       Uninterpreted_Data : out System.Address;
 759       Index              : out Select_Index)
 760    is
 761       Self_Id          : constant Task_Id := STPO.Self;
 762       Entry_Call       : Entry_Call_Link;
 763       Treatment        : Select_Treatment;
 764       Caller           : Task_Id;
 765       Selection        : Select_Index;
 766       Open_Alternative : Boolean;
 767
 768    begin
 769       Initialization.Defer_Abort (Self_Id);
 770
 771       if Single_Lock then
 772          Lock_RTS;
 773       end if;
 774
 775       STPO.Write_Lock (Self_Id);
 776
 777       if not Self_Id.Callable then
 778          pragma Assert (Self_Id.Pending_ATC_Level = 0);
 779
 780          pragma Assert (Self_Id.Pending_Action);
 781
 782          STPO.Unlock (Self_Id);
 783
 784          if Single_Lock then
 785             Unlock_RTS;
 786          end if;
 787
 788          --  ??? In some cases abort is deferred more than once. Need to
 789          --  figure out why this happens.
 790
 791          if Self_Id.Deferral_Level > 1 then
 792             Self_Id.Deferral_Level := 1;
 793          end if;
 794
 795          Initialization.Undefer_Abort (Self_Id);
 796
 797          --  Should never get here ???
 798
 799          pragma Assert (False);
 800          raise Standard'Abort_Signal;
 801       end if;
 802
 803       pragma Assert (Open_Accepts /= null);
 804
 805       Uninterpreted_Data := Null_Address;
 806
 807       Queuing.Select_Task_Entry_Call
 808         (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
 809
 810       --  Determine the kind and disposition of the select
 811
 812       Treatment := Default_Treatment (Select_Mode);
 813       Self_Id.Chosen_Index := No_Rendezvous;
 814
 815       if Open_Alternative then
 816          if Entry_Call /= null then
 817             if Open_Accepts (Selection).Null_Body then
 818                Treatment := Accept_Alternative_Completed;
 819             else
 820                Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
 821                Treatment := Accept_Alternative_Selected;
 822             end if;
 823
 824             Self_Id.Chosen_Index := Selection;
 825
 826          elsif Treatment = No_Alternative_Open then
 827             Treatment := Accept_Alternative_Open;
 828          end if;
 829       end if;
 830
 831       --  Handle the select according to the disposition selected above
 832
 833       case Treatment is
 834          when Accept_Alternative_Selected =>
 835
 836             --  Ready to rendezvous
 837
 838             Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 839
 840             --  In this case the accept body is not Null_Body. Defer abort
 841             --  until it gets into the accept body. The compiler has inserted
 842             --  a call to Abort_Undefer as part of the entry expansion.
 843
 844             pragma Assert (Self_Id.Deferral_Level = 1);
 845
 846             Initialization.Defer_Abort_Nestable (Self_Id);
 847             STPO.Unlock (Self_Id);
 848
 849          when Accept_Alternative_Completed =>
 850
 851             --  Accept body is null, so rendezvous is over immediately
 852
 853             if Parameters.Runtime_Traces then
 854                Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
 855             end if;
 856
 857             STPO.Unlock (Self_Id);
 858             Caller := Entry_Call.Self;
 859
 860             STPO.Write_Lock (Caller);
 861             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 862             STPO.Unlock (Caller);
 863
 864          when Accept_Alternative_Open =>
 865
 866             --  Wait for caller
 867
 868             Self_Id.Open_Accepts := Open_Accepts;
 869             pragma Debug
 870               (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
 871
 872             if Parameters.Runtime_Traces then
 873                Send_Trace_Info (W_Select, Self_Id,
 874                                 Integer (Open_Accepts'Length));
 875             end if;
 876
 877             Wait_For_Call (Self_Id);
 878
 879             pragma Assert (Self_Id.Open_Accepts = null);
 880
 881             --  Self_Id.Common.Call should already be updated by the Caller if
 882             --  not aborted. It might also be ready to do rendezvous even if
 883             --  this wakes up due to an abort. Therefore, if the call is not
 884             --  empty we need to do the rendezvous if the accept body is not
 885             --  Null_Body.
 886
 887             --  Aren't the first two conditions below redundant???
 888
 889             if Self_Id.Chosen_Index /= No_Rendezvous
 890               and then Self_Id.Common.Call /= null
 891               and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
 892             then
 893                Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 894
 895                pragma Assert
 896                  (Self_Id.Deferral_Level = 1
 897                    or else
 898                      (Self_Id.Deferral_Level = 0
 899                        and then not Restrictions.Abort_Allowed));
 900
 901                Initialization.Defer_Abort_Nestable (Self_Id);
 902
 903                --  Leave abort deferred until the accept body
 904                --  The compiler has inserted a call to Abort_Undefer as part of
 905                --  the entry expansion.
 906             end if;
 907
 908             STPO.Unlock (Self_Id);
 909
 910          when Else_Selected =>
 911             pragma Assert (Self_Id.Open_Accepts = null);
 912
 913             if Parameters.Runtime_Traces then
 914                Send_Trace_Info (M_Select_Else);
 915             end if;
 916
 917             STPO.Unlock (Self_Id);
 918
 919          when Terminate_Selected =>
 920
 921             --  Terminate alternative is open
 922
 923             Self_Id.Open_Accepts := Open_Accepts;
 924             Self_Id.Common.State := Acceptor_Sleep;
 925
 926             --  Notify ancestors that this task is on a terminate alternative
 927
 928             STPO.Unlock (Self_Id);
 929             Utilities.Make_Passive (Self_Id, Task_Completed => False);
 930             STPO.Write_Lock (Self_Id);
 931
 932             --  Wait for normal entry call or termination
 933
 934             Wait_For_Call (Self_Id);
 935
 936             pragma Assert (Self_Id.Open_Accepts = null);
 937
 938             if Self_Id.Terminate_Alternative then
 939
 940                --  An entry call should have reset this to False, so we must be
 941                --  aborted. We cannot be in an async. select, since that is not
 942                --  legal, so the abort must be of the entire task. Therefore,
 943                --  we do not need to cancel the terminate alternative. The
 944                --  cleanup will be done in Complete_Master.
 945
 946                pragma Assert (Self_Id.Pending_ATC_Level = 0);
 947                pragma Assert (Self_Id.Awake_Count = 0);
 948
 949                STPO.Unlock (Self_Id);
 950
 951                if Single_Lock then
 952                   Unlock_RTS;
 953                end if;
 954
 955                Index := Self_Id.Chosen_Index;
 956                Initialization.Undefer_Abort_Nestable (Self_Id);
 957
 958                if Self_Id.Pending_Action then
 959                   Initialization.Do_Pending_Action (Self_Id);
 960                end if;
 961
 962                return;
 963
 964             else
 965                --  Self_Id.Common.Call and Self_Id.Chosen_Index
 966                --  should already be updated by the Caller.
 967
 968                if Self_Id.Chosen_Index /= No_Rendezvous
 969                  and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
 970                then
 971                   Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 972
 973                   pragma Assert (Self_Id.Deferral_Level = 1);
 974
 975                   --  We need an extra defer here, to keep abort
 976                   --  deferred until we get into the accept body
 977                   --  The compiler has inserted a call to Abort_Undefer as part
 978                   --  of the entry expansion.
 979
 980                   Initialization.Defer_Abort_Nestable (Self_Id);
 981                end if;
 982             end if;
 983
 984             STPO.Unlock (Self_Id);
 985
 986          when No_Alternative_Open =>
 987
 988             --  In this case, Index will be No_Rendezvous on return, which
 989             --  should cause a Program_Error if it is not a Delay_Mode.
 990
 991             --  If delay alternative exists (Delay_Mode) we should suspend
 992             --  until the delay expires.
 993
 994             Self_Id.Open_Accepts := null;
 995
 996             if Select_Mode = Delay_Mode then
 997                Self_Id.Common.State := Delay_Sleep;
 998
 999                loop
1000                   exit when
1001                     Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
1002                   Sleep (Self_Id, Delay_Sleep);
1003                end loop;
1004
1005                Self_Id.Common.State := Runnable;
1006                STPO.Unlock (Self_Id);
1007
1008             else
1009                STPO.Unlock (Self_Id);
1010
1011                if Single_Lock then
1012                   Unlock_RTS;
1013                end if;
1014
1015                Initialization.Undefer_Abort (Self_Id);
1016                raise Program_Error with
1017                  "entry call not a delay mode";
1018             end if;
1019       end case;
1020
1021       if Single_Lock then
1022          Unlock_RTS;
1023       end if;
1024
1025       --  Caller has been chosen
1026
1027       --  Self_Id.Common.Call should already be updated by the Caller.
1028
1029       --  Self_Id.Chosen_Index should either be updated by the Caller
1030       --  or by Test_Selective_Wait.
1031
1032       --  On return, we sill start rendezvous unless the accept body is
1033       --  null. In the latter case, we will have already completed the RV.
1034
1035       Index := Self_Id.Chosen_Index;
1036       Initialization.Undefer_Abort_Nestable (Self_Id);
1037    end Selective_Wait;
1038
1039    ------------------------------------
1040    -- Setup_For_Rendezvous_With_Body --
1041    ------------------------------------
1042
1043    procedure Setup_For_Rendezvous_With_Body
1044      (Entry_Call : Entry_Call_Link;
1045       Acceptor   : Task_Id) is
1046    begin
1047       Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1048       Acceptor.Common.Call := Entry_Call;
1049
1050       if Entry_Call.State = Now_Abortable then
1051          Entry_Call.State := Was_Abortable;
1052       end if;
1053
1054       Boost_Priority (Entry_Call, Acceptor);
1055    end Setup_For_Rendezvous_With_Body;
1056
1057    ----------------
1058    -- Task_Count --
1059    ----------------
1060
1061    function Task_Count (E : Task_Entry_Index) return Natural is
1062       Self_Id      : constant Task_Id := STPO.Self;
1063       Return_Count : Natural;
1064
1065    begin
1066       Initialization.Defer_Abort (Self_Id);
1067
1068       if Single_Lock then
1069          Lock_RTS;
1070       end if;
1071
1072       STPO.Write_Lock (Self_Id);
1073       Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1074       STPO.Unlock (Self_Id);
1075
1076       if Single_Lock then
1077          Unlock_RTS;
1078       end if;
1079
1080       Initialization.Undefer_Abort (Self_Id);
1081
1082       return Return_Count;
1083    end Task_Count;
1084
1085    ----------------------
1086    -- Task_Do_Or_Queue --
1087    ----------------------
1088
1089    function Task_Do_Or_Queue
1090      (Self_ID    : Task_Id;
1091       Entry_Call : Entry_Call_Link) return Boolean
1092    is
1093       E             : constant Task_Entry_Index :=
1094                         Task_Entry_Index (Entry_Call.E);
1095       Old_State     : constant Entry_Call_State := Entry_Call.State;
1096       Acceptor      : constant Task_Id := Entry_Call.Called_Task;
1097       Parent        : constant Task_Id := Acceptor.Common.Parent;
1098       Null_Body     : Boolean;
1099
1100    begin
1101       --  Find out whether Entry_Call can be accepted immediately
1102
1103       --    If the Acceptor is not callable, return False.
1104       --    If the rendezvous can start, initiate it.
1105       --    If the accept-body is trivial, also complete the rendezvous.
1106       --    If the acceptor is not ready, enqueue the call.
1107
1108       --  This should have a special case for Accept_Call and Accept_Trivial,
1109       --  so that we don't have the loop setup overhead, below.
1110
1111       --  The call state Done is used here and elsewhere to include both the
1112       --  case of normal successful completion, and the case of an exception
1113       --  being raised. The difference is that if an exception is raised no one
1114       --  will pay attention to the fact that State = Done. Instead the
1115       --  exception will be raised in Undefer_Abort, and control will skip past
1116       --  the place where we normally would resume from an entry call.
1117
1118       pragma Assert (not Queuing.Onqueue (Entry_Call));
1119
1120       --  We rely that the call is off-queue for protection, that the caller
1121       --  will not exit the Entry_Caller_Sleep, and so will not reuse the call
1122       --  record for another call. We rely on the Caller's lock for call State
1123       --  mod's.
1124
1125       --  If Acceptor.Terminate_Alternative is True, we need to lock Parent and
1126       --  Acceptor, in that order; otherwise, we only need a lock on Acceptor.
1127       --  However, we can't check Acceptor.Terminate_Alternative until Acceptor
1128       --  is locked. Therefore, we need to lock both. Attempts to avoid locking
1129       --  Parent tend to result in race conditions. It would work to unlock
1130       --  Parent immediately upon finding Acceptor.Terminate_Alternative to be
1131       --  False, but that violates the rule of properly nested locking (see
1132       --  System.Tasking).
1133
1134       STPO.Write_Lock (Parent);
1135       STPO.Write_Lock (Acceptor);
1136
1137       --  If the acceptor is not callable, abort the call and return False
1138
1139       if not Acceptor.Callable then
1140          STPO.Unlock (Acceptor);
1141          STPO.Unlock (Parent);
1142
1143          pragma Assert (Entry_Call.State < Done);
1144
1145          --  In case we are not the caller, set up the caller
1146          --  to raise Tasking_Error when it wakes up.
1147
1148          STPO.Write_Lock (Entry_Call.Self);
1149          Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1150          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1151          STPO.Unlock (Entry_Call.Self);
1152
1153          return False;
1154       end if;
1155
1156       --  Try to serve the call immediately
1157
1158       if Acceptor.Open_Accepts /= null then
1159          for J in Acceptor.Open_Accepts'Range loop
1160             if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1161
1162                --  Commit acceptor to rendezvous with us
1163
1164                Acceptor.Chosen_Index := J;
1165                Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1166                Acceptor.Open_Accepts := null;
1167
1168                --  Prevent abort while call is being served
1169
1170                if Entry_Call.State = Now_Abortable then
1171                   Entry_Call.State := Was_Abortable;
1172                end if;
1173
1174                if Acceptor.Terminate_Alternative then
1175
1176                   --  Cancel terminate alternative. See matching code in
1177                   --  Selective_Wait and Vulnerable_Complete_Master.
1178
1179                   Acceptor.Terminate_Alternative := False;
1180                   Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1181
1182                   if Acceptor.Awake_Count = 1 then
1183
1184                      --  Notify parent that acceptor is awake
1185
1186                      pragma Assert (Parent.Awake_Count > 0);
1187
1188                      Parent.Awake_Count := Parent.Awake_Count + 1;
1189
1190                      if Parent.Common.State = Master_Completion_Sleep
1191                        and then Acceptor.Master_of_Task = Parent.Master_Within
1192                      then
1193                         Parent.Common.Wait_Count :=
1194                           Parent.Common.Wait_Count + 1;
1195                      end if;
1196                   end if;
1197                end if;
1198
1199                if Null_Body then
1200
1201                   --  Rendezvous is over immediately
1202
1203                   STPO.Wakeup (Acceptor, Acceptor_Sleep);
1204                   STPO.Unlock (Acceptor);
1205                   STPO.Unlock (Parent);
1206
1207                   STPO.Write_Lock (Entry_Call.Self);
1208                   Initialization.Wakeup_Entry_Caller
1209                     (Self_ID, Entry_Call, Done);
1210                   STPO.Unlock (Entry_Call.Self);
1211
1212                else
1213                   Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1214
1215                   --  For terminate_alternative, acceptor may not be asleep
1216                   --  yet, so we skip the wakeup
1217
1218                   if Acceptor.Common.State /= Runnable then
1219                      STPO.Wakeup (Acceptor, Acceptor_Sleep);
1220                   end if;
1221
1222                   STPO.Unlock (Acceptor);
1223                   STPO.Unlock (Parent);
1224                end if;
1225
1226                return True;
1227             end if;
1228          end loop;
1229
1230          --  The acceptor is accepting, but not this entry
1231       end if;
1232
1233       --  If the acceptor was ready to accept this call,
1234       --  we would not have gotten this far, so now we should
1235       --  (re)enqueue the call, if the mode permits that.
1236
1237       --  If the call is timed, it may have timed out before the requeue,
1238       --  in the unusual case where the current accept has taken longer than
1239       --  the given delay. In that case the requeue is cancelled, and the
1240       --  outer timed call will be aborted.
1241
1242       if Entry_Call.Mode = Conditional_Call
1243         or else
1244           (Entry_Call.Mode = Timed_Call
1245             and then Entry_Call.With_Abort
1246             and then Entry_Call.Cancellation_Attempted)
1247       then
1248          STPO.Unlock (Acceptor);
1249          STPO.Unlock (Parent);
1250
1251          STPO.Write_Lock (Entry_Call.Self);
1252
1253          pragma Assert (Entry_Call.State >= Was_Abortable);
1254
1255          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1256          STPO.Unlock (Entry_Call.Self);
1257
1258       else
1259          --  Timed_Call, Simple_Call, or Asynchronous_Call
1260
1261          Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1262
1263          --  Update abortability of call
1264
1265          pragma Assert (Old_State < Done);
1266
1267          Entry_Call.State :=
1268            New_State (Entry_Call.With_Abort, Entry_Call.State);
1269
1270          STPO.Unlock (Acceptor);
1271          STPO.Unlock (Parent);
1272
1273          if Old_State /= Entry_Call.State
1274            and then Entry_Call.State = Now_Abortable
1275            and then Entry_Call.Mode /= Simple_Call
1276            and then Entry_Call.Self /= Self_ID
1277
1278          --  Asynchronous_Call or Conditional_Call
1279
1280          then
1281             --  Because of ATCB lock ordering rule
1282
1283             STPO.Write_Lock (Entry_Call.Self);
1284
1285             if Entry_Call.Self.Common.State = Async_Select_Sleep then
1286
1287                --  Caller may not yet have reached wait-point
1288
1289                STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1290             end if;
1291
1292             STPO.Unlock (Entry_Call.Self);
1293          end if;
1294       end if;
1295
1296       return True;
1297    end Task_Do_Or_Queue;
1298
1299    ---------------------
1300    -- Task_Entry_Call --
1301    ---------------------
1302
1303    procedure Task_Entry_Call
1304      (Acceptor              : Task_Id;
1305       E                     : Task_Entry_Index;
1306       Uninterpreted_Data    : System.Address;
1307       Mode                  : Call_Modes;
1308       Rendezvous_Successful : out Boolean)
1309    is
1310       Self_Id    : constant Task_Id := STPO.Self;
1311       Entry_Call : Entry_Call_Link;
1312
1313    begin
1314       --  If pragma Detect_Blocking is active then Program_Error must be
1315       --  raised if this potentially blocking operation is called from a
1316       --  protected action.
1317
1318       if System.Tasking.Detect_Blocking
1319         and then Self_Id.Common.Protected_Action_Nesting > 0
1320       then
1321          raise Program_Error with
1322            "potentially blocking operation";
1323       end if;
1324
1325       if Parameters.Runtime_Traces then
1326          Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1327       end if;
1328
1329       if Mode = Simple_Call or else Mode = Conditional_Call then
1330          Call_Synchronous
1331            (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1332
1333       else
1334          --  This is an asynchronous call
1335
1336          --  Abort must already be deferred by the compiler-generated code.
1337          --  Without this, an abort that occurs between the time that this
1338          --  call is made and the time that the abortable part's cleanup
1339          --  handler is set up might miss the cleanup handler and leave the
1340          --  call pending.
1341
1342          Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1343          pragma Debug
1344            (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1345             ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1346          Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1347          Entry_Call.Next := null;
1348          Entry_Call.Mode := Mode;
1349          Entry_Call.Cancellation_Attempted := False;
1350          Entry_Call.State := Not_Yet_Abortable;
1351          Entry_Call.E := Entry_Index (E);
1352          Entry_Call.Prio := Get_Priority (Self_Id);
1353          Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1354          Entry_Call.Called_Task := Acceptor;
1355          Entry_Call.Called_PO := Null_Address;
1356          Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1357          Entry_Call.With_Abort := True;
1358
1359          if Single_Lock then
1360             Lock_RTS;
1361          end if;
1362
1363          if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1364             STPO.Write_Lock (Self_Id);
1365             Utilities.Exit_One_ATC_Level (Self_Id);
1366             STPO.Unlock (Self_Id);
1367
1368             if Single_Lock then
1369                Unlock_RTS;
1370             end if;
1371
1372             Initialization.Undefer_Abort (Self_Id);
1373
1374             if Parameters.Runtime_Traces then
1375                Send_Trace_Info (E_Missed, Acceptor);
1376             end if;
1377
1378             raise Tasking_Error;
1379          end if;
1380
1381          --  The following is special for async. entry calls. If the call was
1382          --  not queued abortably, we need to wait until it is before
1383          --  proceeding with the abortable part.
1384
1385          --  Wait_Until_Abortable can be called unconditionally here, but it is
1386          --  expensive.
1387
1388          if Entry_Call.State < Was_Abortable then
1389             Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1390          end if;
1391
1392          if Single_Lock then
1393             Unlock_RTS;
1394          end if;
1395
1396          --  Note: following assignment needs to be atomic
1397
1398          Rendezvous_Successful := Entry_Call.State = Done;
1399       end if;
1400    end Task_Entry_Call;
1401
1402    -----------------------
1403    -- Task_Entry_Caller --
1404    -----------------------
1405
1406    function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1407       Self_Id    : constant Task_Id := STPO.Self;
1408       Entry_Call : Entry_Call_Link;
1409
1410    begin
1411       Entry_Call := Self_Id.Common.Call;
1412
1413       for Depth in 1 .. D loop
1414          Entry_Call := Entry_Call.Acceptor_Prev_Call;
1415          pragma Assert (Entry_Call /= null);
1416       end loop;
1417
1418       return Entry_Call.Self;
1419    end Task_Entry_Caller;
1420
1421    --------------------------
1422    -- Timed_Selective_Wait --
1423    --------------------------
1424
1425    procedure Timed_Selective_Wait
1426      (Open_Accepts       : Accept_List_Access;
1427       Select_Mode        : Select_Modes;
1428       Uninterpreted_Data : out System.Address;
1429       Timeout            : Duration;
1430       Mode               : Delay_Modes;
1431       Index              : out Select_Index)
1432    is
1433       Self_Id          : constant Task_Id := STPO.Self;
1434       Treatment        : Select_Treatment;
1435       Entry_Call       : Entry_Call_Link;
1436       Caller           : Task_Id;
1437       Selection        : Select_Index;
1438       Open_Alternative : Boolean;
1439       Timedout         : Boolean := False;
1440       Yielded          : Boolean := True;
1441
1442    begin
1443       pragma Assert (Select_Mode = Delay_Mode);
1444
1445       Initialization.Defer_Abort (Self_Id);
1446
1447       --  If we are aborted here, the effect will be pending
1448
1449       if Single_Lock then
1450          Lock_RTS;
1451       end if;
1452
1453       STPO.Write_Lock (Self_Id);
1454
1455       if not Self_Id.Callable then
1456          pragma Assert (Self_Id.Pending_ATC_Level = 0);
1457
1458          pragma Assert (Self_Id.Pending_Action);
1459
1460          STPO.Unlock (Self_Id);
1461
1462          if Single_Lock then
1463             Unlock_RTS;
1464          end if;
1465
1466          Initialization.Undefer_Abort (Self_Id);
1467
1468          --  Should never get here ???
1469
1470          pragma Assert (False);
1471          raise Standard'Abort_Signal;
1472       end if;
1473
1474       Uninterpreted_Data := Null_Address;
1475
1476       pragma Assert (Open_Accepts /= null);
1477
1478       Queuing.Select_Task_Entry_Call
1479         (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1480
1481       --  Determine the kind and disposition of the select
1482
1483       Treatment := Default_Treatment (Select_Mode);
1484       Self_Id.Chosen_Index := No_Rendezvous;
1485
1486       if Open_Alternative then
1487          if Entry_Call /= null then
1488             if Open_Accepts (Selection).Null_Body then
1489                Treatment := Accept_Alternative_Completed;
1490
1491             else
1492                Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1493                Treatment := Accept_Alternative_Selected;
1494             end if;
1495
1496             Self_Id.Chosen_Index := Selection;
1497
1498          elsif Treatment = No_Alternative_Open then
1499             Treatment := Accept_Alternative_Open;
1500          end if;
1501       end if;
1502
1503       --  Handle the select according to the disposition selected above
1504
1505       case Treatment is
1506          when Accept_Alternative_Selected =>
1507
1508             --  Ready to rendezvous. In this case the accept body is not
1509             --  Null_Body. Defer abort until it gets into the accept body.
1510
1511             Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1512             Initialization.Defer_Abort_Nestable (Self_Id);
1513             STPO.Unlock (Self_Id);
1514
1515          when Accept_Alternative_Completed =>
1516
1517             --  Rendezvous is over
1518
1519             if Parameters.Runtime_Traces then
1520                Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1521             end if;
1522
1523             STPO.Unlock (Self_Id);
1524             Caller := Entry_Call.Self;
1525
1526             STPO.Write_Lock (Caller);
1527             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1528             STPO.Unlock (Caller);
1529
1530          when Accept_Alternative_Open =>
1531
1532             --  Wait for caller
1533
1534             Self_Id.Open_Accepts := Open_Accepts;
1535
1536             --  Wait for a normal call and a pending action until the
1537             --  Wakeup_Time is reached.
1538
1539             Self_Id.Common.State := Acceptor_Delay_Sleep;
1540
1541             --  Try to remove calls to Sleep in the loop below by letting the
1542             --  caller a chance of getting ready immediately, using Unlock
1543             --  Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1544
1545             if Single_Lock then
1546                Unlock_RTS;
1547             else
1548                Unlock (Self_Id);
1549             end if;
1550
1551             if Self_Id.Open_Accepts /= null then
1552                Yield;
1553             end if;
1554
1555             if Single_Lock then
1556                Lock_RTS;
1557             else
1558                Write_Lock (Self_Id);
1559             end if;
1560
1561             --  Check if this task has been aborted while the lock was released
1562
1563             if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1564                Self_Id.Open_Accepts := null;
1565             end if;
1566
1567             loop
1568                exit when Self_Id.Open_Accepts = null;
1569
1570                if Timedout then
1571                   Sleep (Self_Id, Acceptor_Delay_Sleep);
1572                else
1573                   if Parameters.Runtime_Traces then
1574                      Send_Trace_Info (WT_Select,
1575                                       Self_Id,
1576                                       Integer (Open_Accepts'Length),
1577                                       Timeout);
1578                   end if;
1579
1580                   STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1581                     Acceptor_Delay_Sleep, Timedout, Yielded);
1582                end if;
1583
1584                if Timedout then
1585                   Self_Id.Open_Accepts := null;
1586
1587                   if Parameters.Runtime_Traces then
1588                      Send_Trace_Info (E_Timeout);
1589                   end if;
1590                end if;
1591             end loop;
1592
1593             Self_Id.Common.State := Runnable;
1594
1595             --  Self_Id.Common.Call should already be updated by the Caller if
1596             --  not aborted. It might also be ready to do rendezvous even if
1597             --  this wakes up due to an abort. Therefore, if the call is not
1598             --  empty we need to do the rendezvous if the accept body is not
1599             --  Null_Body.
1600
1601             if Self_Id.Chosen_Index /= No_Rendezvous
1602               and then Self_Id.Common.Call /= null
1603               and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1604             then
1605                Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1606
1607                pragma Assert (Self_Id.Deferral_Level = 1);
1608
1609                Initialization.Defer_Abort_Nestable (Self_Id);
1610
1611                --  Leave abort deferred until the accept body
1612             end if;
1613
1614             STPO.Unlock (Self_Id);
1615
1616          when No_Alternative_Open =>
1617
1618             --  In this case, Index will be No_Rendezvous on return. We sleep
1619             --  for the time we need to.
1620
1621             --  Wait for a signal or timeout. A wakeup can be made
1622             --  for several reasons:
1623             --    1) Delay is expired
1624             --    2) Pending_Action needs to be checked
1625             --       (Abort, Priority change)
1626             --    3) Spurious wakeup
1627
1628             Self_Id.Open_Accepts := null;
1629             Self_Id.Common.State := Acceptor_Delay_Sleep;
1630
1631             STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep,
1632               Timedout, Yielded);
1633
1634             Self_Id.Common.State := Runnable;
1635
1636             STPO.Unlock (Self_Id);
1637
1638          when others =>
1639
1640             --  Should never get here
1641
1642             pragma Assert (False);
1643             null;
1644       end case;
1645
1646       if Single_Lock then
1647          Unlock_RTS;
1648       end if;
1649
1650       if not Yielded then
1651          Yield;
1652       end if;
1653
1654       --  Caller has been chosen
1655
1656       --  Self_Id.Common.Call should already be updated by the Caller
1657
1658       --  Self_Id.Chosen_Index should either be updated by the Caller
1659       --  or by Test_Selective_Wait
1660
1661       Index := Self_Id.Chosen_Index;
1662       Initialization.Undefer_Abort_Nestable (Self_Id);
1663
1664       --  Start rendezvous, if not already completed
1665    end Timed_Selective_Wait;
1666
1667    ---------------------------
1668    -- Timed_Task_Entry_Call --
1669    ---------------------------
1670
1671    procedure Timed_Task_Entry_Call
1672      (Acceptor              : Task_Id;
1673       E                     : Task_Entry_Index;
1674       Uninterpreted_Data    : System.Address;
1675       Timeout               : Duration;
1676       Mode                  : Delay_Modes;
1677       Rendezvous_Successful : out Boolean)
1678    is
1679       Self_Id    : constant Task_Id := STPO.Self;
1680       Level      : ATC_Level;
1681       Entry_Call : Entry_Call_Link;
1682
1683       Yielded : Boolean;
1684       pragma Unreferenced (Yielded);
1685
1686    begin
1687       --  If pragma Detect_Blocking is active then Program_Error must be
1688       --  raised if this potentially blocking operation is called from a
1689       --  protected action.
1690
1691       if System.Tasking.Detect_Blocking
1692         and then Self_Id.Common.Protected_Action_Nesting > 0
1693       then
1694          raise Program_Error with
1695            "potentially blocking operation";
1696       end if;
1697
1698       Initialization.Defer_Abort (Self_Id);
1699       Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1700
1701       pragma Debug
1702         (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1703          ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1704
1705       if Parameters.Runtime_Traces then
1706          Send_Trace_Info (WT_Call, Acceptor,
1707                           Entry_Index (E), Timeout);
1708       end if;
1709
1710       Level := Self_Id.ATC_Nesting_Level;
1711       Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1712       Entry_Call.Next := null;
1713       Entry_Call.Mode := Timed_Call;
1714       Entry_Call.Cancellation_Attempted := False;
1715
1716       --  If this is a call made inside of an abort deferred region,
1717       --  the call should be never abortable.
1718
1719       Entry_Call.State :=
1720         (if Self_Id.Deferral_Level > 1
1721          then Never_Abortable
1722          else Now_Abortable);
1723
1724       Entry_Call.E := Entry_Index (E);
1725       Entry_Call.Prio := Get_Priority (Self_Id);
1726       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1727       Entry_Call.Called_Task := Acceptor;
1728       Entry_Call.Called_PO := Null_Address;
1729       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1730       Entry_Call.With_Abort := True;
1731
1732       --  Note: the caller will undefer abort on return (see WARNING above)
1733
1734       if Single_Lock then
1735          Lock_RTS;
1736       end if;
1737
1738       if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1739          STPO.Write_Lock (Self_Id);
1740          Utilities.Exit_One_ATC_Level (Self_Id);
1741          STPO.Unlock (Self_Id);
1742
1743          if Single_Lock then
1744             Unlock_RTS;
1745          end if;
1746
1747          Initialization.Undefer_Abort (Self_Id);
1748
1749          if Parameters.Runtime_Traces then
1750             Send_Trace_Info (E_Missed, Acceptor);
1751          end if;
1752          raise Tasking_Error;
1753       end if;
1754
1755       Write_Lock (Self_Id);
1756       Entry_Calls.Wait_For_Completion_With_Timeout
1757         (Entry_Call, Timeout, Mode, Yielded);
1758       Unlock (Self_Id);
1759
1760       if Single_Lock then
1761          Unlock_RTS;
1762       end if;
1763
1764       --  ??? Do we need to yield in case Yielded is False
1765
1766       Rendezvous_Successful := Entry_Call.State = Done;
1767       Initialization.Undefer_Abort (Self_Id);
1768       Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1769    end Timed_Task_Entry_Call;
1770
1771    -------------------
1772    -- Wait_For_Call --
1773    -------------------
1774
1775    procedure Wait_For_Call (Self_Id : Task_Id) is
1776    begin
1777       Self_Id.Common.State := Acceptor_Sleep;
1778
1779       --  Try to remove calls to Sleep in the loop below by letting the caller
1780       --  a chance of getting ready immediately, using Unlock & Yield.
1781       --  See similar action in Wait_For_Completion & Timed_Selective_Wait.
1782
1783       if Single_Lock then
1784          Unlock_RTS;
1785       else
1786          Unlock (Self_Id);
1787       end if;
1788
1789       if Self_Id.Open_Accepts /= null then
1790          Yield;
1791       end if;
1792
1793       if Single_Lock then
1794          Lock_RTS;
1795       else
1796          Write_Lock (Self_Id);
1797       end if;
1798
1799       --  Check if this task has been aborted while the lock was released
1800
1801       if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1802          Self_Id.Open_Accepts := null;
1803       end if;
1804
1805       loop
1806          exit when Self_Id.Open_Accepts = null;
1807          Sleep (Self_Id, Acceptor_Sleep);
1808       end loop;
1809
1810       Self_Id.Common.State := Runnable;
1811    end Wait_For_Call;
1812
1813 end System.Tasking.Rendezvous;