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 --           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             --  Accept body is null, so rendezvous is over immediately.
 886
 887             if Parameters.Runtime_Traces then
 888                Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
 889             end if;
 890
 891             STPO.Unlock (Self_Id);
 892             Caller := Entry_Call.Self;
 893
 894             STPO.Write_Lock (Caller);
 895             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 896             STPO.Unlock (Caller);
 897
 898          when Accept_Alternative_Open =>
 899             --  Wait for caller.
 900
 901             Self_Id.Open_Accepts := Open_Accepts;
 902             pragma Debug
 903               (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
 904
 905             if Parameters.Runtime_Traces then
 906                Send_Trace_Info (W_Select, Self_Id,
 907                                 Integer (Open_Accepts'Length));
 908             end if;
 909
 910             Wait_For_Call (Self_Id);
 911
 912             pragma Assert (Self_Id.Open_Accepts = null);
 913
 914             --  Self_Id.Common.Call should already be updated by the Caller if
 915             --  not aborted. It might also be ready to do rendezvous even if
 916             --  this wakes up due to an abortion.
 917             --  Therefore, if the call is not empty we need to do the
 918             --  rendezvous if the accept body is not Null_Body.
 919
 920             --  Aren't the first two conditions below redundant???
 921
 922             if Self_Id.Chosen_Index /= No_Rendezvous
 923               and then Self_Id.Common.Call /= null
 924               and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
 925             then
 926                Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 927
 928                pragma Assert (Self_Id.Deferral_Level = 1);
 929
 930                Initialization.Defer_Abort_Nestable (Self_Id);
 931
 932                --  Leave abort deferred until the accept body
 933             end if;
 934
 935             STPO.Unlock (Self_Id);
 936
 937          when Else_Selected =>
 938             pragma Assert (Self_Id.Open_Accepts = null);
 939
 940             if Parameters.Runtime_Traces then
 941                Send_Trace_Info (M_Select_Else);
 942             end if;
 943
 944             STPO.Unlock (Self_Id);
 945
 946          when Terminate_Selected =>
 947             --  Terminate alternative is open
 948
 949             Self_Id.Open_Accepts := Open_Accepts;
 950             Self_Id.Common.State := Acceptor_Sleep;
 951
 952             --  Notify ancestors that this task is on a terminate alternative.
 953
 954             STPO.Unlock (Self_Id);
 955             Utilities.Make_Passive (Self_Id, Task_Completed => False);
 956             STPO.Write_Lock (Self_Id);
 957
 958             --  Wait for normal entry call or termination
 959
 960             Wait_For_Call (Self_Id);
 961
 962             pragma Assert (Self_Id.Open_Accepts = null);
 963
 964             if Self_Id.Terminate_Alternative then
 965                --  An entry call should have reset this to False,
 966                --  so we must be aborted.
 967                --  We cannot be in an async. select, since that
 968                --  is not legal, so the abort must be of the entire
 969                --  task.  Therefore, we do not need to cancel the
 970                --  terminate alternative.  The cleanup will be done
 971                --  in Complete_Master.
 972
 973                pragma Assert (Self_Id.Pending_ATC_Level = 0);
 974                pragma Assert (Self_Id.Awake_Count = 0);
 975
 976                STPO.Unlock (Self_Id);
 977
 978                if Single_Lock then
 979                   Unlock_RTS;
 980                end if;
 981
 982                Index := Self_Id.Chosen_Index;
 983                Initialization.Undefer_Abort_Nestable (Self_Id);
 984
 985                if Self_Id.Pending_Action then
 986                   Initialization.Do_Pending_Action (Self_Id);
 987                end if;
 988
 989                return;
 990
 991             else
 992                --  Self_Id.Common.Call and Self_Id.Chosen_Index
 993                --  should already be updated by the Caller.
 994
 995                if Self_Id.Chosen_Index /= No_Rendezvous
 996                  and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
 997                then
 998                   Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 999
1000                   pragma Assert (Self_Id.Deferral_Level = 1);
1001
1002                   --  We need an extra defer here, to keep abort
1003                   --  deferred until we get into the accept body
1004
1005                   Initialization.Defer_Abort_Nestable (Self_Id);
1006                end if;
1007             end if;
1008
1009             STPO.Unlock (Self_Id);
1010
1011          when No_Alternative_Open =>
1012             --  In this case, Index will be No_Rendezvous on return, which
1013             --  should cause a Program_Error if it is not a Delay_Mode.
1014
1015             --  If delay alternative exists (Delay_Mode) we should suspend
1016             --  until the delay expires.
1017
1018             Self_Id.Open_Accepts := null;
1019
1020             if Select_Mode = Delay_Mode then
1021                Self_Id.Common.State := Delay_Sleep;
1022
1023                loop
1024                   Initialization.Poll_Base_Priority_Change (Self_Id);
1025                   exit when
1026                     Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
1027                   Sleep (Self_Id, Delay_Sleep);
1028                end loop;
1029
1030                Self_Id.Common.State := Runnable;
1031                STPO.Unlock (Self_Id);
1032
1033             else
1034                STPO.Unlock (Self_Id);
1035
1036                if Single_Lock then
1037                   Unlock_RTS;
1038                end if;
1039
1040                Initialization.Undefer_Abort (Self_Id);
1041                Ada.Exceptions.Raise_Exception
1042                  (Program_Error'Identity, "Entry call not a delay mode");
1043             end if;
1044       end case;
1045
1046       if Single_Lock then
1047          Unlock_RTS;
1048       end if;
1049
1050       --  Caller has been chosen.
1051       --  Self_Id.Common.Call should already be updated by the Caller.
1052       --  Self_Id.Chosen_Index should either be updated by the Caller
1053       --  or by Test_Selective_Wait.
1054       --  On return, we sill start rendezvous unless the accept body is
1055       --  null. In the latter case, we will have already completed the RV.
1056
1057       Index := Self_Id.Chosen_Index;
1058       Initialization.Undefer_Abort_Nestable (Self_Id);
1059    end Selective_Wait;
1060
1061    ------------------------------------
1062    -- Setup_For_Rendezvous_With_Body --
1063    ------------------------------------
1064
1065    procedure Setup_For_Rendezvous_With_Body
1066      (Entry_Call : Entry_Call_Link;
1067       Acceptor   : Task_Id) is
1068    begin
1069       Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1070       Acceptor.Common.Call := Entry_Call;
1071
1072       if Entry_Call.State = Now_Abortable then
1073          Entry_Call.State := Was_Abortable;
1074       end if;
1075
1076       Boost_Priority (Entry_Call, Acceptor);
1077    end Setup_For_Rendezvous_With_Body;
1078
1079    ----------------
1080    -- Task_Count --
1081    ----------------
1082
1083    function Task_Count (E : Task_Entry_Index) return Natural is
1084       Self_Id      : constant Task_Id := STPO.Self;
1085       Return_Count : Natural;
1086
1087    begin
1088       Initialization.Defer_Abort (Self_Id);
1089
1090       if Single_Lock then
1091          Lock_RTS;
1092       end if;
1093
1094       STPO.Write_Lock (Self_Id);
1095       Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1096       STPO.Unlock (Self_Id);
1097
1098       if Single_Lock then
1099          Unlock_RTS;
1100       end if;
1101
1102       Initialization.Undefer_Abort (Self_Id);
1103       return Return_Count;
1104    end Task_Count;
1105
1106    ----------------------
1107    -- Task_Do_Or_Queue --
1108    ----------------------
1109
1110    function Task_Do_Or_Queue
1111      (Self_ID    : Task_Id;
1112       Entry_Call : Entry_Call_Link;
1113       With_Abort : Boolean) return Boolean
1114    is
1115       E             : constant Task_Entry_Index :=
1116         Task_Entry_Index (Entry_Call.E);
1117       Old_State     : constant Entry_Call_State := Entry_Call.State;
1118       Acceptor      : constant Task_Id := Entry_Call.Called_Task;
1119       Parent        : constant Task_Id := Acceptor.Common.Parent;
1120       Parent_Locked : Boolean := False;
1121       Null_Body     : Boolean;
1122
1123    begin
1124       --  Find out whether Entry_Call can be accepted immediately.
1125       --  If the Acceptor is not callable, return False.
1126       --  If the rendezvous can start, initiate it.
1127       --  If the accept-body is trivial, also complete the rendezvous.
1128       --  If the acceptor is not ready, enqueue the call.
1129
1130       --  This should have a special case for Accept_Call and Accept_Trivial,
1131       --  so that we don't have the loop setup overhead, below.
1132
1133       --  The call state Done is used here and elsewhere to include both the
1134       --  case of normal successful completion, and the case of an exception
1135       --  being raised. The difference is that if an exception is raised no one
1136       --  will pay attention to the fact that State = Done. Instead the
1137       --  exception will be raised in Undefer_Abort, and control will skip past
1138       --  the place where we normally would resume from an entry call.
1139
1140       pragma Assert (not Queuing.Onqueue (Entry_Call));
1141
1142       --  We rely that the call is off-queue for protection, that the caller
1143       --  will not exit the Entry_Caller_Sleep, and so will not reuse the call
1144       --  record for another call.
1145       --  We rely on the Caller's lock for call State mod's.
1146
1147       --  We can't lock Acceptor.Parent while holding Acceptor,
1148       --  so lock it in advance if we expect to need to lock it.
1149
1150       if Acceptor.Terminate_Alternative then
1151          STPO.Write_Lock (Parent);
1152          Parent_Locked := True;
1153       end if;
1154
1155       STPO.Write_Lock (Acceptor);
1156
1157       --  If the acceptor is not callable, abort the call and return False.
1158
1159       if not Acceptor.Callable then
1160          STPO.Unlock (Acceptor);
1161
1162          if Parent_Locked then
1163             STPO.Unlock (Parent);
1164          end if;
1165
1166          pragma Assert (Entry_Call.State < Done);
1167
1168          --  In case we are not the caller, set up the caller
1169          --  to raise Tasking_Error when it wakes up.
1170
1171          STPO.Write_Lock (Entry_Call.Self);
1172          Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1173          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1174          STPO.Unlock (Entry_Call.Self);
1175
1176          return False;
1177       end if;
1178
1179       --  Try to serve the call immediately.
1180
1181       if Acceptor.Open_Accepts /= null then
1182          for J in Acceptor.Open_Accepts'Range loop
1183             if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1184
1185                --  Commit acceptor to rendezvous with us.
1186
1187                Acceptor.Chosen_Index := J;
1188                Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1189                Acceptor.Open_Accepts := null;
1190
1191                --  Prevent abort while call is being served.
1192
1193                if Entry_Call.State = Now_Abortable then
1194                   Entry_Call.State := Was_Abortable;
1195                end if;
1196
1197                if Acceptor.Terminate_Alternative then
1198                   --  Cancel terminate alternative.
1199                   --  See matching code in Selective_Wait and
1200                   --  Vulnerable_Complete_Master.
1201
1202                   Acceptor.Terminate_Alternative := False;
1203                   Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1204
1205                   if Acceptor.Awake_Count = 1 then
1206
1207                      --  Notify parent that acceptor is awake.
1208
1209                      pragma Assert (Parent.Awake_Count > 0);
1210
1211                      Parent.Awake_Count := Parent.Awake_Count + 1;
1212
1213                      if Parent.Common.State = Master_Completion_Sleep
1214                        and then Acceptor.Master_of_Task = Parent.Master_Within
1215                      then
1216                         Parent.Common.Wait_Count :=
1217                           Parent.Common.Wait_Count + 1;
1218                      end if;
1219                   end if;
1220                end if;
1221
1222                if Null_Body then
1223                   --  Rendezvous is over immediately.
1224
1225                   STPO.Wakeup (Acceptor, Acceptor_Sleep);
1226                   STPO.Unlock (Acceptor);
1227
1228                   if Parent_Locked then
1229                      STPO.Unlock (Parent);
1230                   end if;
1231
1232                   STPO.Write_Lock (Entry_Call.Self);
1233                   Initialization.Wakeup_Entry_Caller
1234                     (Self_ID, Entry_Call, Done);
1235                   STPO.Unlock (Entry_Call.Self);
1236
1237                else
1238                   Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1239
1240                   --  For terminate_alternative, acceptor may not be
1241                   --  asleep yet, so we skip the wakeup
1242
1243                   if Acceptor.Common.State /= Runnable then
1244                      STPO.Wakeup (Acceptor, Acceptor_Sleep);
1245                   end if;
1246
1247                   STPO.Unlock (Acceptor);
1248
1249                   if Parent_Locked then
1250                      STPO.Unlock (Parent);
1251                   end if;
1252                end if;
1253
1254                return True;
1255             end if;
1256          end loop;
1257
1258          --  The acceptor is accepting, but not this entry.
1259       end if;
1260
1261       --  If the acceptor was ready to accept this call,
1262       --  we would not have gotten this far, so now we should
1263       --  (re)enqueue the call, if the mode permits that.
1264
1265       if Entry_Call.Mode /= Conditional_Call
1266         or else not With_Abort
1267       then
1268          --  Timed_Call, Simple_Call, or Asynchronous_Call
1269
1270          Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1271
1272          --  Update abortability of call
1273
1274          pragma Assert (Old_State < Done);
1275
1276          Entry_Call.State := New_State (With_Abort, Entry_Call.State);
1277
1278          STPO.Unlock (Acceptor);
1279
1280          if Parent_Locked then
1281             STPO.Unlock (Parent);
1282          end if;
1283
1284          if Old_State /= Entry_Call.State
1285            and then Entry_Call.State = Now_Abortable
1286            and then Entry_Call.Mode > Simple_Call
1287            and then Entry_Call.Self /= Self_ID
1288
1289          --  Asynchronous_Call or Conditional_Call
1290
1291          then
1292             --  Because of ATCB lock ordering rule
1293
1294             STPO.Write_Lock (Entry_Call.Self);
1295
1296             if Entry_Call.Self.Common.State = Async_Select_Sleep then
1297
1298                --  Caller may not yet have reached wait-point
1299
1300                STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1301             end if;
1302
1303             STPO.Unlock (Entry_Call.Self);
1304          end if;
1305
1306       else
1307          --  Conditional_Call and With_Abort
1308
1309          STPO.Unlock (Acceptor);
1310
1311          if Parent_Locked then
1312             STPO.Unlock (Parent);
1313          end if;
1314
1315          STPO.Write_Lock (Entry_Call.Self);
1316
1317          pragma Assert (Entry_Call.State >= Was_Abortable);
1318
1319          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1320          STPO.Unlock (Entry_Call.Self);
1321       end if;
1322
1323       return True;
1324    end Task_Do_Or_Queue;
1325
1326    ---------------------
1327    -- Task_Entry_Call --
1328    ---------------------
1329
1330    procedure Task_Entry_Call
1331      (Acceptor              : Task_Id;
1332       E                     : Task_Entry_Index;
1333       Uninterpreted_Data    : System.Address;
1334       Mode                  : Call_Modes;
1335       Rendezvous_Successful : out Boolean)
1336    is
1337       Self_Id    : constant Task_Id := STPO.Self;
1338       Entry_Call : Entry_Call_Link;
1339
1340    begin
1341       --  If pragma Detect_Blocking is active then Program_Error must be
1342       --  raised if this potentially blocking operation is called from a
1343       --  protected action.
1344
1345       if System.Tasking.Detect_Blocking
1346         and then Self_Id.Common.Protected_Action_Nesting > 0
1347       then
1348          Ada.Exceptions.Raise_Exception
1349            (Program_Error'Identity, "potentially blocking operation");
1350       end if;
1351
1352       if Parameters.Runtime_Traces then
1353          Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1354       end if;
1355
1356       if Mode = Simple_Call or else Mode = Conditional_Call then
1357          Call_Synchronous
1358            (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1359
1360       else
1361          --  This is an asynchronous call
1362
1363          --  Abortion must already be deferred by the compiler-generated
1364          --  code.  Without this, an abortion that occurs between the time
1365          --  that this call is made and the time that the abortable part's
1366          --  cleanup handler is set up might miss the cleanup handler and
1367          --  leave the call pending.
1368
1369          Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1370          pragma Debug
1371            (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1372             ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1373          Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1374          Entry_Call.Next := null;
1375          Entry_Call.Mode := Mode;
1376          Entry_Call.Cancellation_Attempted := False;
1377          Entry_Call.State := Not_Yet_Abortable;
1378          Entry_Call.E := Entry_Index (E);
1379          Entry_Call.Prio := Get_Priority (Self_Id);
1380          Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1381          Entry_Call.Called_Task := Acceptor;
1382          Entry_Call.Called_PO := Null_Address;
1383          Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1384
1385          if Single_Lock then
1386             Lock_RTS;
1387          end if;
1388
1389          if not Task_Do_Or_Queue
1390            (Self_Id, Entry_Call, With_Abort => True)
1391          then
1392             STPO.Write_Lock (Self_Id);
1393             Utilities.Exit_One_ATC_Level (Self_Id);
1394             STPO.Unlock (Self_Id);
1395
1396             if Single_Lock then
1397                Unlock_RTS;
1398             end if;
1399
1400             Initialization.Undefer_Abort (Self_Id);
1401
1402             if Parameters.Runtime_Traces then
1403                Send_Trace_Info (E_Missed, Acceptor);
1404             end if;
1405
1406             raise Tasking_Error;
1407          end if;
1408
1409          --  The following is special for async. entry calls.
1410          --  If the call was not queued abortably, we need to wait until
1411          --  it is before proceeding with the abortable part.
1412
1413          --  Wait_Until_Abortable can be called unconditionally here,
1414          --  but it is expensive.
1415
1416          if Entry_Call.State < Was_Abortable then
1417             Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1418          end if;
1419
1420          if Single_Lock then
1421             Unlock_RTS;
1422          end if;
1423
1424          --  Note: following assignment needs to be atomic.
1425
1426          Rendezvous_Successful := Entry_Call.State = Done;
1427       end if;
1428    end Task_Entry_Call;
1429
1430    -----------------------
1431    -- Task_Entry_Caller --
1432    -----------------------
1433
1434    function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1435       Self_Id    : constant Task_Id := STPO.Self;
1436       Entry_Call : Entry_Call_Link;
1437
1438    begin
1439       Entry_Call := Self_Id.Common.Call;
1440
1441       for Depth in 1 .. D loop
1442          Entry_Call := Entry_Call.Acceptor_Prev_Call;
1443          pragma Assert (Entry_Call /= null);
1444       end loop;
1445
1446       return Entry_Call.Self;
1447    end Task_Entry_Caller;
1448
1449    --------------------------
1450    -- Timed_Selective_Wait --
1451    --------------------------
1452
1453    procedure Timed_Selective_Wait
1454      (Open_Accepts       : Accept_List_Access;
1455       Select_Mode        : Select_Modes;
1456       Uninterpreted_Data : out System.Address;
1457       Timeout            : Duration;
1458       Mode               : Delay_Modes;
1459       Index              : out Select_Index)
1460    is
1461       Self_Id          : constant Task_Id := STPO.Self;
1462       Treatment        : Select_Treatment;
1463       Entry_Call       : Entry_Call_Link;
1464       Caller           : Task_Id;
1465       Selection        : Select_Index;
1466       Open_Alternative : Boolean;
1467       Timedout         : Boolean := False;
1468       Yielded          : Boolean := True;
1469
1470    begin
1471       pragma Assert (Select_Mode = Delay_Mode);
1472
1473       Initialization.Defer_Abort (Self_Id);
1474
1475       --  If we are aborted here, the effect will be pending
1476
1477       if Single_Lock then
1478          Lock_RTS;
1479       end if;
1480
1481       STPO.Write_Lock (Self_Id);
1482
1483       if not Self_Id.Callable then
1484          pragma Assert (Self_Id.Pending_ATC_Level = 0);
1485
1486          pragma Assert (Self_Id.Pending_Action);
1487
1488          STPO.Unlock (Self_Id);
1489
1490          if Single_Lock then
1491             Unlock_RTS;
1492          end if;
1493
1494          Initialization.Undefer_Abort (Self_Id);
1495
1496          --  Should never get here ???
1497
1498          pragma Assert (False);
1499          raise Standard'Abort_Signal;
1500       end if;
1501
1502       Uninterpreted_Data := Null_Address;
1503
1504       pragma Assert (Open_Accepts /= null);
1505
1506       Queuing.Select_Task_Entry_Call
1507         (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1508
1509       --  Determine the kind and disposition of the select.
1510
1511       Treatment := Default_Treatment (Select_Mode);
1512       Self_Id.Chosen_Index := No_Rendezvous;
1513
1514       if Open_Alternative then
1515          if Entry_Call /= null then
1516             if Open_Accepts (Selection).Null_Body then
1517                Treatment := Accept_Alternative_Completed;
1518
1519             else
1520                Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1521                Treatment := Accept_Alternative_Selected;
1522             end if;
1523
1524             Self_Id.Chosen_Index := Selection;
1525
1526          elsif Treatment = No_Alternative_Open then
1527             Treatment := Accept_Alternative_Open;
1528          end if;
1529       end if;
1530
1531       --  Handle the select according to the disposition selected above.
1532
1533       case Treatment is
1534          when Accept_Alternative_Selected =>
1535             --  Ready to rendezvous
1536             --  In this case the accept body is not Null_Body. Defer abort
1537             --  until it gets into the accept body.
1538
1539             Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1540             Initialization.Defer_Abort (Self_Id);
1541             STPO.Unlock (Self_Id);
1542
1543          when Accept_Alternative_Completed =>
1544             --  Rendezvous is over
1545
1546             if Parameters.Runtime_Traces then
1547                Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1548             end if;
1549
1550             STPO.Unlock (Self_Id);
1551             Caller := Entry_Call.Self;
1552
1553             STPO.Write_Lock (Caller);
1554             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1555             STPO.Unlock (Caller);
1556
1557          when Accept_Alternative_Open =>
1558             --  Wait for caller.
1559
1560             Self_Id.Open_Accepts := Open_Accepts;
1561
1562             --  Wait for a normal call and a pending action until the
1563             --  Wakeup_Time is reached.
1564
1565             --  Try to remove calls to Sleep in the loop below by letting the
1566             --  caller a chance of getting ready immediately, using Unlock &
1567             --  Yield.
1568             --  See similar action in Wait_For_Completion & Wait_For_Call.
1569
1570             if Single_Lock then
1571                Unlock_RTS;
1572             else
1573                Unlock (Self_Id);
1574             end if;
1575
1576             if Self_Id.Open_Accepts /= null then
1577                Yield;
1578             end if;
1579
1580             if Single_Lock then
1581                Lock_RTS;
1582             else
1583                Write_Lock (Self_Id);
1584             end if;
1585
1586             --  Check if this task has been aborted while the lock was released
1587
1588             if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1589                Self_Id.Open_Accepts := null;
1590             end if;
1591
1592             Self_Id.Common.State := Acceptor_Sleep;
1593
1594             loop
1595                Initialization.Poll_Base_Priority_Change (Self_Id);
1596                exit when Self_Id.Open_Accepts = null;
1597
1598                if Timedout then
1599                   Sleep (Self_Id, Acceptor_Sleep);
1600                else
1601                   if Parameters.Runtime_Traces then
1602                      Send_Trace_Info (WT_Select,
1603                                       Self_Id,
1604                                       Integer (Open_Accepts'Length),
1605                                       Timeout);
1606                   end if;
1607
1608                   STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1609                     Acceptor_Sleep, Timedout, Yielded);
1610                end if;
1611
1612                if Timedout then
1613                   Self_Id.Open_Accepts := null;
1614
1615                   if Parameters.Runtime_Traces then
1616                      Send_Trace_Info (E_Timeout);
1617                   end if;
1618                end if;
1619             end loop;
1620
1621             Self_Id.Common.State := Runnable;
1622
1623             --  Self_Id.Common.Call should already be updated by the Caller if
1624             --  not aborted. It might also be ready to do rendezvous even if
1625             --  this wakes up due to an abortion.
1626             --  Therefore, if the call is not empty we need to do the
1627             --  rendezvous if the accept body is not Null_Body.
1628
1629             if Self_Id.Chosen_Index /= No_Rendezvous
1630               and then Self_Id.Common.Call /= null
1631               and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1632             then
1633                Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1634
1635                pragma Assert (Self_Id.Deferral_Level = 1);
1636
1637                Initialization.Defer_Abort_Nestable (Self_Id);
1638
1639                --  Leave abort deferred until the accept body
1640             end if;
1641
1642             STPO.Unlock (Self_Id);
1643
1644          when No_Alternative_Open =>
1645             --  In this case, Index will be No_Rendezvous on return. We sleep
1646             --  for the time we need to.
1647             --  Wait for a signal or timeout. A wakeup can be made
1648             --  for several reasons:
1649             --  1) Delay is expired
1650             --  2) Pending_Action needs to be checked
1651             --     (Abortion, Priority change)
1652             --  3) Spurious wakeup
1653
1654             Self_Id.Open_Accepts := null;
1655             Self_Id.Common.State := Acceptor_Sleep;
1656
1657             Initialization.Poll_Base_Priority_Change (Self_Id);
1658
1659             STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Sleep,
1660               Timedout, Yielded);
1661
1662             Self_Id.Common.State := Runnable;
1663
1664             STPO.Unlock (Self_Id);
1665
1666          when others =>
1667             --  Should never get here
1668             pragma Assert (False);
1669             null;
1670       end case;
1671
1672       if Single_Lock then
1673          Unlock_RTS;
1674       end if;
1675
1676       if not Yielded then
1677          Yield;
1678       end if;
1679
1680       --  Caller has been chosen
1681
1682       --  Self_Id.Common.Call should already be updated by the Caller
1683
1684       --  Self_Id.Chosen_Index should either be updated by the Caller
1685       --  or by Test_Selective_Wait
1686
1687       Index := Self_Id.Chosen_Index;
1688       Initialization.Undefer_Abort_Nestable (Self_Id);
1689
1690       --  Start rendezvous, if not already completed
1691    end Timed_Selective_Wait;
1692
1693    ---------------------------
1694    -- Timed_Task_Entry_Call --
1695    ---------------------------
1696
1697    procedure Timed_Task_Entry_Call
1698      (Acceptor              : Task_Id;
1699       E                     : Task_Entry_Index;
1700       Uninterpreted_Data    : System.Address;
1701       Timeout               : Duration;
1702       Mode                  : Delay_Modes;
1703       Rendezvous_Successful : out Boolean)
1704    is
1705       Self_Id    : constant Task_Id := STPO.Self;
1706       Level      : ATC_Level;
1707       Entry_Call : Entry_Call_Link;
1708       Yielded    : Boolean;
1709
1710    begin
1711       --  If pragma Detect_Blocking is active then Program_Error must be
1712       --  raised if this potentially blocking operation is called from a
1713       --  protected action.
1714
1715       if System.Tasking.Detect_Blocking
1716         and then Self_Id.Common.Protected_Action_Nesting > 0
1717       then
1718          Ada.Exceptions.Raise_Exception
1719            (Program_Error'Identity, "potentially blocking operation");
1720       end if;
1721
1722       Initialization.Defer_Abort (Self_Id);
1723       Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1724
1725       pragma Debug
1726         (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1727          ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1728
1729       if Parameters.Runtime_Traces then
1730          Send_Trace_Info (WT_Call, Acceptor,
1731                           Entry_Index (E), Timeout);
1732       end if;
1733
1734       Level := Self_Id.ATC_Nesting_Level;
1735       Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1736       Entry_Call.Next := null;
1737       Entry_Call.Mode := Timed_Call;
1738       Entry_Call.Cancellation_Attempted := False;
1739
1740       --  If this is a call made inside of an abort deferred region,
1741       --  the call should be never abortable.
1742
1743       if Self_Id.Deferral_Level > 1 then
1744          Entry_Call.State := Never_Abortable;
1745       else
1746          Entry_Call.State := Now_Abortable;
1747       end if;
1748
1749       Entry_Call.E := Entry_Index (E);
1750       Entry_Call.Prio := Get_Priority (Self_Id);
1751       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1752       Entry_Call.Called_Task := Acceptor;
1753       Entry_Call.Called_PO := Null_Address;
1754       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1755
1756       --  Note: the caller will undefer abortion on return (see WARNING above)
1757
1758       if Single_Lock then
1759          Lock_RTS;
1760       end if;
1761
1762       if not Task_Do_Or_Queue
1763        (Self_Id, Entry_Call, With_Abort => True)
1764       then
1765          STPO.Write_Lock (Self_Id);
1766          Utilities.Exit_One_ATC_Level (Self_Id);
1767          STPO.Unlock (Self_Id);
1768
1769          if Single_Lock then
1770             Unlock_RTS;
1771          end if;
1772
1773          Initialization.Undefer_Abort (Self_Id);
1774
1775          if Parameters.Runtime_Traces then
1776             Send_Trace_Info (E_Missed, Acceptor);
1777          end if;
1778          raise Tasking_Error;
1779       end if;
1780
1781       Write_Lock (Self_Id);
1782       Entry_Calls.Wait_For_Completion_With_Timeout
1783         (Entry_Call, Timeout, Mode, Yielded);
1784       Unlock (Self_Id);
1785
1786       if Single_Lock then
1787          Unlock_RTS;
1788       end if;
1789
1790       --  ??? Do we need to yield in case Yielded is False
1791
1792       Rendezvous_Successful := Entry_Call.State = Done;
1793       Initialization.Undefer_Abort (Self_Id);
1794       Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1795    end Timed_Task_Entry_Call;
1796
1797    -------------------
1798    -- Wait_For_Call --
1799    -------------------
1800
1801    procedure Wait_For_Call (Self_Id : Task_Id) is
1802    begin
1803       --  Try to remove calls to Sleep in the loop below by letting the caller
1804       --  a chance of getting ready immediately, using Unlock & Yield.
1805       --  See similar action in Wait_For_Completion & Selective_Wait.
1806
1807       if Single_Lock then
1808          Unlock_RTS;
1809       else
1810          Unlock (Self_Id);
1811       end if;
1812
1813       if Self_Id.Open_Accepts /= null then
1814          Yield;
1815       end if;
1816
1817       if Single_Lock then
1818          Lock_RTS;
1819       else
1820          Write_Lock (Self_Id);
1821       end if;
1822
1823       --  Check if this task has been aborted while the lock was released.
1824
1825       if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1826          Self_Id.Open_Accepts := null;
1827       end if;
1828
1829       Self_Id.Common.State := Acceptor_Sleep;
1830
1831       loop
1832          Initialization.Poll_Base_Priority_Change (Self_Id);
1833
1834          exit when Self_Id.Open_Accepts = null;
1835
1836          Sleep (Self_Id, Acceptor_Sleep);
1837       end loop;
1838
1839       Self_Id.Common.State := Runnable;
1840    end Wait_For_Call;
1841
1842 end System.Tasking.Rendezvous;