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       --  Call Yield to let other tasks get a chance to run as this is a
1073       --  potential dispatching point.
1074
1075       Yield (Do_Yield => False);
1076       return Return_Count;
1077    end Task_Count;
1078
1079    ----------------------
1080    -- Task_Do_Or_Queue --
1081    ----------------------
1082
1083    function Task_Do_Or_Queue
1084      (Self_ID    : Task_Id;
1085       Entry_Call : Entry_Call_Link) return Boolean
1086    is
1087       E             : constant Task_Entry_Index :=
1088                         Task_Entry_Index (Entry_Call.E);
1089       Old_State     : constant Entry_Call_State := Entry_Call.State;
1090       Acceptor      : constant Task_Id := Entry_Call.Called_Task;
1091       Parent        : constant Task_Id := Acceptor.Common.Parent;
1092       Null_Body     : Boolean;
1093
1094    begin
1095       --  Find out whether Entry_Call can be accepted immediately
1096
1097       --    If the Acceptor is not callable, return False.
1098       --    If the rendezvous can start, initiate it.
1099       --    If the accept-body is trivial, also complete the rendezvous.
1100       --    If the acceptor is not ready, enqueue the call.
1101
1102       --  This should have a special case for Accept_Call and Accept_Trivial,
1103       --  so that we don't have the loop setup overhead, below.
1104
1105       --  The call state Done is used here and elsewhere to include both the
1106       --  case of normal successful completion, and the case of an exception
1107       --  being raised. The difference is that if an exception is raised no one
1108       --  will pay attention to the fact that State = Done. Instead the
1109       --  exception will be raised in Undefer_Abort, and control will skip past
1110       --  the place where we normally would resume from an entry call.
1111
1112       pragma Assert (not Queuing.Onqueue (Entry_Call));
1113
1114       --  We rely that the call is off-queue for protection, that the caller
1115       --  will not exit the Entry_Caller_Sleep, and so will not reuse the call
1116       --  record for another call. We rely on the Caller's lock for call State
1117       --  mod's.
1118
1119       --  If Acceptor.Terminate_Alternative is True, we need to lock Parent and
1120       --  Acceptor, in that order; otherwise, we only need a lock on Acceptor.
1121       --  However, we can't check Acceptor.Terminate_Alternative until Acceptor
1122       --  is locked. Therefore, we need to lock both. Attempts to avoid locking
1123       --  Parent tend to result in race conditions. It would work to unlock
1124       --  Parent immediately upon finding Acceptor.Terminate_Alternative to be
1125       --  False, but that violates the rule of properly nested locking (see
1126       --  System.Tasking).
1127
1128       STPO.Write_Lock (Parent);
1129       STPO.Write_Lock (Acceptor);
1130
1131       --  If the acceptor is not callable, abort the call and return False
1132
1133       if not Acceptor.Callable then
1134          STPO.Unlock (Acceptor);
1135          STPO.Unlock (Parent);
1136
1137          pragma Assert (Entry_Call.State < Done);
1138
1139          --  In case we are not the caller, set up the caller
1140          --  to raise Tasking_Error when it wakes up.
1141
1142          STPO.Write_Lock (Entry_Call.Self);
1143          Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1144          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1145          STPO.Unlock (Entry_Call.Self);
1146
1147          return False;
1148       end if;
1149
1150       --  Try to serve the call immediately
1151
1152       if Acceptor.Open_Accepts /= null then
1153          for J in Acceptor.Open_Accepts'Range loop
1154             if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1155
1156                --  Commit acceptor to rendezvous with us
1157
1158                Acceptor.Chosen_Index := J;
1159                Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1160                Acceptor.Open_Accepts := null;
1161
1162                --  Prevent abort while call is being served
1163
1164                if Entry_Call.State = Now_Abortable then
1165                   Entry_Call.State := Was_Abortable;
1166                end if;
1167
1168                if Acceptor.Terminate_Alternative then
1169
1170                   --  Cancel terminate alternative. See matching code in
1171                   --  Selective_Wait and Vulnerable_Complete_Master.
1172
1173                   Acceptor.Terminate_Alternative := False;
1174                   Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1175
1176                   if Acceptor.Awake_Count = 1 then
1177
1178                      --  Notify parent that acceptor is awake
1179
1180                      pragma Assert (Parent.Awake_Count > 0);
1181
1182                      Parent.Awake_Count := Parent.Awake_Count + 1;
1183
1184                      if Parent.Common.State = Master_Completion_Sleep
1185                        and then Acceptor.Master_of_Task = Parent.Master_Within
1186                      then
1187                         Parent.Common.Wait_Count :=
1188                           Parent.Common.Wait_Count + 1;
1189                      end if;
1190                   end if;
1191                end if;
1192
1193                if Null_Body then
1194
1195                   --  Rendezvous is over immediately
1196
1197                   STPO.Wakeup (Acceptor, Acceptor_Sleep);
1198                   STPO.Unlock (Acceptor);
1199                   STPO.Unlock (Parent);
1200
1201                   STPO.Write_Lock (Entry_Call.Self);
1202                   Initialization.Wakeup_Entry_Caller
1203                     (Self_ID, Entry_Call, Done);
1204                   STPO.Unlock (Entry_Call.Self);
1205
1206                else
1207                   Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1208
1209                   --  For terminate_alternative, acceptor may not be asleep
1210                   --  yet, so we skip the wakeup
1211
1212                   if Acceptor.Common.State /= Runnable then
1213                      STPO.Wakeup (Acceptor, Acceptor_Sleep);
1214                   end if;
1215
1216                   STPO.Unlock (Acceptor);
1217                   STPO.Unlock (Parent);
1218                end if;
1219
1220                return True;
1221             end if;
1222          end loop;
1223
1224          --  The acceptor is accepting, but not this entry
1225       end if;
1226
1227       --  If the acceptor was ready to accept this call,
1228       --  we would not have gotten this far, so now we should
1229       --  (re)enqueue the call, if the mode permits that.
1230
1231       --  If the call is timed, it may have timed out before the requeue,
1232       --  in the unusual case where the current accept has taken longer than
1233       --  the given delay. In that case the requeue is cancelled, and the
1234       --  outer timed call will be aborted.
1235
1236       if Entry_Call.Mode = Conditional_Call
1237         or else
1238           (Entry_Call.Mode = Timed_Call
1239             and then Entry_Call.With_Abort
1240             and then Entry_Call.Cancellation_Attempted)
1241       then
1242          STPO.Unlock (Acceptor);
1243          STPO.Unlock (Parent);
1244
1245          STPO.Write_Lock (Entry_Call.Self);
1246
1247          pragma Assert (Entry_Call.State >= Was_Abortable);
1248
1249          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1250          STPO.Unlock (Entry_Call.Self);
1251
1252       else
1253          --  Timed_Call, Simple_Call, or Asynchronous_Call
1254
1255          Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1256
1257          --  Update abortability of call
1258
1259          pragma Assert (Old_State < Done);
1260
1261          Entry_Call.State :=
1262            New_State (Entry_Call.With_Abort, Entry_Call.State);
1263
1264          STPO.Unlock (Acceptor);
1265          STPO.Unlock (Parent);
1266
1267          if Old_State /= Entry_Call.State
1268            and then Entry_Call.State = Now_Abortable
1269            and then Entry_Call.Mode /= Simple_Call
1270            and then Entry_Call.Self /= Self_ID
1271
1272          --  Asynchronous_Call or Conditional_Call
1273
1274          then
1275             --  Because of ATCB lock ordering rule
1276
1277             STPO.Write_Lock (Entry_Call.Self);
1278
1279             if Entry_Call.Self.Common.State = Async_Select_Sleep then
1280
1281                --  Caller may not yet have reached wait-point
1282
1283                STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1284             end if;
1285
1286             STPO.Unlock (Entry_Call.Self);
1287          end if;
1288       end if;
1289
1290       return True;
1291    end Task_Do_Or_Queue;
1292
1293    ---------------------
1294    -- Task_Entry_Call --
1295    ---------------------
1296
1297    procedure Task_Entry_Call
1298      (Acceptor              : Task_Id;
1299       E                     : Task_Entry_Index;
1300       Uninterpreted_Data    : System.Address;
1301       Mode                  : Call_Modes;
1302       Rendezvous_Successful : out Boolean)
1303    is
1304       Self_Id    : constant Task_Id := STPO.Self;
1305       Entry_Call : Entry_Call_Link;
1306
1307    begin
1308       --  If pragma Detect_Blocking is active then Program_Error must be
1309       --  raised if this potentially blocking operation is called from a
1310       --  protected action.
1311
1312       if System.Tasking.Detect_Blocking
1313         and then Self_Id.Common.Protected_Action_Nesting > 0
1314       then
1315          raise Program_Error with "potentially blocking operation";
1316       end if;
1317
1318       if Parameters.Runtime_Traces then
1319          Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1320       end if;
1321
1322       if Mode = Simple_Call or else Mode = Conditional_Call then
1323          Call_Synchronous
1324            (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1325
1326       else
1327          --  This is an asynchronous call
1328
1329          --  Abort must already be deferred by the compiler-generated code.
1330          --  Without this, an abort that occurs between the time that this
1331          --  call is made and the time that the abortable part's cleanup
1332          --  handler is set up might miss the cleanup handler and leave the
1333          --  call pending.
1334
1335          Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1336          pragma Debug
1337            (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1338             ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1339          Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1340          Entry_Call.Next := null;
1341          Entry_Call.Mode := Mode;
1342          Entry_Call.Cancellation_Attempted := False;
1343          Entry_Call.State := Not_Yet_Abortable;
1344          Entry_Call.E := Entry_Index (E);
1345          Entry_Call.Prio := Get_Priority (Self_Id);
1346          Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1347          Entry_Call.Called_Task := Acceptor;
1348          Entry_Call.Called_PO := Null_Address;
1349          Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1350          Entry_Call.With_Abort := True;
1351
1352          if Single_Lock then
1353             Lock_RTS;
1354          end if;
1355
1356          if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1357             STPO.Write_Lock (Self_Id);
1358             Utilities.Exit_One_ATC_Level (Self_Id);
1359             STPO.Unlock (Self_Id);
1360
1361             if Single_Lock then
1362                Unlock_RTS;
1363             end if;
1364
1365             Initialization.Undefer_Abort (Self_Id);
1366
1367             if Parameters.Runtime_Traces then
1368                Send_Trace_Info (E_Missed, Acceptor);
1369             end if;
1370
1371             raise Tasking_Error;
1372          end if;
1373
1374          --  The following is special for async. entry calls. If the call was
1375          --  not queued abortably, we need to wait until it is before
1376          --  proceeding with the abortable part.
1377
1378          --  Wait_Until_Abortable can be called unconditionally here, but it is
1379          --  expensive.
1380
1381          if Entry_Call.State < Was_Abortable then
1382             Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1383          end if;
1384
1385          if Single_Lock then
1386             Unlock_RTS;
1387          end if;
1388
1389          --  Note: following assignment needs to be atomic
1390
1391          Rendezvous_Successful := Entry_Call.State = Done;
1392       end if;
1393    end Task_Entry_Call;
1394
1395    -----------------------
1396    -- Task_Entry_Caller --
1397    -----------------------
1398
1399    function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1400       Self_Id    : constant Task_Id := STPO.Self;
1401       Entry_Call : Entry_Call_Link;
1402
1403    begin
1404       Entry_Call := Self_Id.Common.Call;
1405
1406       for Depth in 1 .. D loop
1407          Entry_Call := Entry_Call.Acceptor_Prev_Call;
1408          pragma Assert (Entry_Call /= null);
1409       end loop;
1410
1411       return Entry_Call.Self;
1412    end Task_Entry_Caller;
1413
1414    --------------------------
1415    -- Timed_Selective_Wait --
1416    --------------------------
1417
1418    procedure Timed_Selective_Wait
1419      (Open_Accepts       : Accept_List_Access;
1420       Select_Mode        : Select_Modes;
1421       Uninterpreted_Data : out System.Address;
1422       Timeout            : Duration;
1423       Mode               : Delay_Modes;
1424       Index              : out Select_Index)
1425    is
1426       Self_Id          : constant Task_Id := STPO.Self;
1427       Treatment        : Select_Treatment;
1428       Entry_Call       : Entry_Call_Link;
1429       Caller           : Task_Id;
1430       Selection        : Select_Index;
1431       Open_Alternative : Boolean;
1432       Timedout         : Boolean := False;
1433       Yielded          : Boolean := True;
1434
1435    begin
1436       pragma Assert (Select_Mode = Delay_Mode);
1437
1438       Initialization.Defer_Abort (Self_Id);
1439
1440       --  If we are aborted here, the effect will be pending
1441
1442       if Single_Lock then
1443          Lock_RTS;
1444       end if;
1445
1446       STPO.Write_Lock (Self_Id);
1447
1448       if not Self_Id.Callable then
1449          pragma Assert (Self_Id.Pending_ATC_Level = 0);
1450
1451          pragma Assert (Self_Id.Pending_Action);
1452
1453          STPO.Unlock (Self_Id);
1454
1455          if Single_Lock then
1456             Unlock_RTS;
1457          end if;
1458
1459          Initialization.Undefer_Abort (Self_Id);
1460
1461          --  Should never get here ???
1462
1463          pragma Assert (False);
1464          raise Standard'Abort_Signal;
1465       end if;
1466
1467       Uninterpreted_Data := Null_Address;
1468
1469       pragma Assert (Open_Accepts /= null);
1470
1471       Queuing.Select_Task_Entry_Call
1472         (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1473
1474       --  Determine the kind and disposition of the select
1475
1476       Treatment := Default_Treatment (Select_Mode);
1477       Self_Id.Chosen_Index := No_Rendezvous;
1478
1479       if Open_Alternative then
1480          if Entry_Call /= null then
1481             if Open_Accepts (Selection).Null_Body then
1482                Treatment := Accept_Alternative_Completed;
1483
1484             else
1485                Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1486                Treatment := Accept_Alternative_Selected;
1487             end if;
1488
1489             Self_Id.Chosen_Index := Selection;
1490
1491          elsif Treatment = No_Alternative_Open then
1492             Treatment := Accept_Alternative_Open;
1493          end if;
1494       end if;
1495
1496       --  Handle the select according to the disposition selected above
1497
1498       case Treatment is
1499          when Accept_Alternative_Selected =>
1500
1501             --  Ready to rendezvous. In this case the accept body is not
1502             --  Null_Body. Defer abort until it gets into the accept body.
1503
1504             Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1505             Initialization.Defer_Abort_Nestable (Self_Id);
1506             STPO.Unlock (Self_Id);
1507
1508          when Accept_Alternative_Completed =>
1509
1510             --  Rendezvous is over
1511
1512             if Parameters.Runtime_Traces then
1513                Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1514             end if;
1515
1516             STPO.Unlock (Self_Id);
1517             Caller := Entry_Call.Self;
1518
1519             STPO.Write_Lock (Caller);
1520             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1521             STPO.Unlock (Caller);
1522
1523          when Accept_Alternative_Open =>
1524
1525             --  Wait for caller
1526
1527             Self_Id.Open_Accepts := Open_Accepts;
1528
1529             --  Wait for a normal call and a pending action until the
1530             --  Wakeup_Time is reached.
1531
1532             Self_Id.Common.State := Acceptor_Delay_Sleep;
1533
1534             --  Try to remove calls to Sleep in the loop below by letting the
1535             --  caller a chance of getting ready immediately, using Unlock
1536             --  Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1537
1538             if Single_Lock then
1539                Unlock_RTS;
1540             else
1541                Unlock (Self_Id);
1542             end if;
1543
1544             if Self_Id.Open_Accepts /= null then
1545                Yield;
1546             end if;
1547
1548             if Single_Lock then
1549                Lock_RTS;
1550             else
1551                Write_Lock (Self_Id);
1552             end if;
1553
1554             --  Check if this task has been aborted while the lock was released
1555
1556             if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1557                Self_Id.Open_Accepts := null;
1558             end if;
1559
1560             loop
1561                exit when Self_Id.Open_Accepts = null;
1562
1563                if Timedout then
1564                   Sleep (Self_Id, Acceptor_Delay_Sleep);
1565                else
1566                   if Parameters.Runtime_Traces then
1567                      Send_Trace_Info (WT_Select,
1568                                       Self_Id,
1569                                       Integer (Open_Accepts'Length),
1570                                       Timeout);
1571                   end if;
1572
1573                   STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1574                     Acceptor_Delay_Sleep, Timedout, Yielded);
1575                end if;
1576
1577                if Timedout then
1578                   Self_Id.Open_Accepts := null;
1579
1580                   if Parameters.Runtime_Traces then
1581                      Send_Trace_Info (E_Timeout);
1582                   end if;
1583                end if;
1584             end loop;
1585
1586             Self_Id.Common.State := Runnable;
1587
1588             --  Self_Id.Common.Call should already be updated by the Caller if
1589             --  not aborted. It might also be ready to do rendezvous even if
1590             --  this wakes up due to an abort. Therefore, if the call is not
1591             --  empty we need to do the rendezvous if the accept body is not
1592             --  Null_Body.
1593
1594             if Self_Id.Chosen_Index /= No_Rendezvous
1595               and then Self_Id.Common.Call /= null
1596               and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1597             then
1598                Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1599
1600                pragma Assert (Self_Id.Deferral_Level = 1);
1601
1602                Initialization.Defer_Abort_Nestable (Self_Id);
1603
1604                --  Leave abort deferred until the accept body
1605             end if;
1606
1607             STPO.Unlock (Self_Id);
1608
1609          when No_Alternative_Open =>
1610
1611             --  In this case, Index will be No_Rendezvous on return. We sleep
1612             --  for the time we need to.
1613
1614             --  Wait for a signal or timeout. A wakeup can be made
1615             --  for several reasons:
1616             --    1) Delay is expired
1617             --    2) Pending_Action needs to be checked
1618             --       (Abort, Priority change)
1619             --    3) Spurious wakeup
1620
1621             Self_Id.Open_Accepts := null;
1622             Self_Id.Common.State := Acceptor_Delay_Sleep;
1623
1624             STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep,
1625               Timedout, Yielded);
1626
1627             Self_Id.Common.State := Runnable;
1628
1629             STPO.Unlock (Self_Id);
1630
1631          when others =>
1632
1633             --  Should never get here
1634
1635             pragma Assert (False);
1636             null;
1637       end case;
1638
1639       if Single_Lock then
1640          Unlock_RTS;
1641       end if;
1642
1643       if not Yielded then
1644          Yield;
1645       end if;
1646
1647       --  Caller has been chosen
1648
1649       --  Self_Id.Common.Call should already be updated by the Caller
1650
1651       --  Self_Id.Chosen_Index should either be updated by the Caller
1652       --  or by Test_Selective_Wait
1653
1654       Index := Self_Id.Chosen_Index;
1655       Initialization.Undefer_Abort_Nestable (Self_Id);
1656
1657       --  Start rendezvous, if not already completed
1658    end Timed_Selective_Wait;
1659
1660    ---------------------------
1661    -- Timed_Task_Entry_Call --
1662    ---------------------------
1663
1664    procedure Timed_Task_Entry_Call
1665      (Acceptor              : Task_Id;
1666       E                     : Task_Entry_Index;
1667       Uninterpreted_Data    : System.Address;
1668       Timeout               : Duration;
1669       Mode                  : Delay_Modes;
1670       Rendezvous_Successful : out Boolean)
1671    is
1672       Self_Id    : constant Task_Id := STPO.Self;
1673       Level      : ATC_Level;
1674       Entry_Call : Entry_Call_Link;
1675
1676       Yielded : Boolean;
1677       pragma Unreferenced (Yielded);
1678
1679    begin
1680       --  If pragma Detect_Blocking is active then Program_Error must be
1681       --  raised if this potentially blocking operation is called from a
1682       --  protected action.
1683
1684       if System.Tasking.Detect_Blocking
1685         and then Self_Id.Common.Protected_Action_Nesting > 0
1686       then
1687          raise Program_Error with "potentially blocking operation";
1688       end if;
1689
1690       Initialization.Defer_Abort (Self_Id);
1691       Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1692
1693       pragma Debug
1694         (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1695          ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1696
1697       if Parameters.Runtime_Traces then
1698          Send_Trace_Info (WT_Call, Acceptor,
1699                           Entry_Index (E), Timeout);
1700       end if;
1701
1702       Level := Self_Id.ATC_Nesting_Level;
1703       Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1704       Entry_Call.Next := null;
1705       Entry_Call.Mode := Timed_Call;
1706       Entry_Call.Cancellation_Attempted := False;
1707
1708       --  If this is a call made inside of an abort deferred region,
1709       --  the call should be never abortable.
1710
1711       Entry_Call.State :=
1712         (if Self_Id.Deferral_Level > 1
1713          then Never_Abortable
1714          else Now_Abortable);
1715
1716       Entry_Call.E := Entry_Index (E);
1717       Entry_Call.Prio := Get_Priority (Self_Id);
1718       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1719       Entry_Call.Called_Task := Acceptor;
1720       Entry_Call.Called_PO := Null_Address;
1721       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1722       Entry_Call.With_Abort := True;
1723
1724       --  Note: the caller will undefer abort on return (see WARNING above)
1725
1726       if Single_Lock then
1727          Lock_RTS;
1728       end if;
1729
1730       if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1731          STPO.Write_Lock (Self_Id);
1732          Utilities.Exit_One_ATC_Level (Self_Id);
1733          STPO.Unlock (Self_Id);
1734
1735          if Single_Lock then
1736             Unlock_RTS;
1737          end if;
1738
1739          Initialization.Undefer_Abort (Self_Id);
1740
1741          if Parameters.Runtime_Traces then
1742             Send_Trace_Info (E_Missed, Acceptor);
1743          end if;
1744          raise Tasking_Error;
1745       end if;
1746
1747       Write_Lock (Self_Id);
1748       Entry_Calls.Wait_For_Completion_With_Timeout
1749         (Entry_Call, Timeout, Mode, Yielded);
1750       Unlock (Self_Id);
1751
1752       if Single_Lock then
1753          Unlock_RTS;
1754       end if;
1755
1756       --  ??? Do we need to yield in case Yielded is False
1757
1758       Rendezvous_Successful := Entry_Call.State = Done;
1759       Initialization.Undefer_Abort (Self_Id);
1760       Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1761    end Timed_Task_Entry_Call;
1762
1763    -------------------
1764    -- Wait_For_Call --
1765    -------------------
1766
1767    procedure Wait_For_Call (Self_Id : Task_Id) is
1768    begin
1769       Self_Id.Common.State := Acceptor_Sleep;
1770
1771       --  Try to remove calls to Sleep in the loop below by letting the caller
1772       --  a chance of getting ready immediately, using Unlock & Yield.
1773       --  See similar action in Wait_For_Completion & Timed_Selective_Wait.
1774
1775       if Single_Lock then
1776          Unlock_RTS;
1777       else
1778          Unlock (Self_Id);
1779       end if;
1780
1781       if Self_Id.Open_Accepts /= null then
1782          Yield;
1783       end if;
1784
1785       if Single_Lock then
1786          Lock_RTS;
1787       else
1788          Write_Lock (Self_Id);
1789       end if;
1790
1791       --  Check if this task has been aborted while the lock was released
1792
1793       if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1794          Self_Id.Open_Accepts := null;
1795       end if;
1796
1797       loop
1798          exit when Self_Id.Open_Accepts = null;
1799          Sleep (Self_Id, Acceptor_Sleep);
1800       end loop;
1801
1802       Self_Id.Common.State := Runnable;
1803    end Wait_For_Call;
1804
1805 end System.Tasking.Rendezvous;