gcc/ada/s-tasren.adb

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