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