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