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