gcc/ada/s-tasren.adb

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