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