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