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