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