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