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