gcc/ada/s-tasren.adb

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