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-2012, 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 not yet
 114    --  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_Nestable (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_Nestable (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.
 841
 842             pragma Assert (Self_Id.Deferral_Level = 1);
 843
 844             Initialization.Defer_Abort_Nestable (Self_Id);
 845             STPO.Unlock (Self_Id);
 846
 847          when Accept_Alternative_Completed =>
 848
 849             --  Accept body is null, so rendezvous is over immediately
 850
 851             if Parameters.Runtime_Traces then
 852                Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
 853             end if;
 854
 855             STPO.Unlock (Self_Id);
 856             Caller := Entry_Call.Self;
 857
 858             STPO.Write_Lock (Caller);
 859             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
 860             STPO.Unlock (Caller);
 861
 862          when Accept_Alternative_Open =>
 863
 864             --  Wait for caller
 865
 866             Self_Id.Open_Accepts := Open_Accepts;
 867             pragma Debug
 868               (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R'));
 869
 870             if Parameters.Runtime_Traces then
 871                Send_Trace_Info (W_Select, Self_Id,
 872                                 Integer (Open_Accepts'Length));
 873             end if;
 874
 875             Wait_For_Call (Self_Id);
 876
 877             pragma Assert (Self_Id.Open_Accepts = null);
 878
 879             --  Self_Id.Common.Call should already be updated by the Caller if
 880             --  not aborted. It might also be ready to do rendezvous even if
 881             --  this wakes up due to an abort. Therefore, if the call is not
 882             --  empty we need to do the rendezvous if the accept body is not
 883             --  Null_Body.
 884
 885             --  Aren't the first two conditions below redundant???
 886
 887             if Self_Id.Chosen_Index /= No_Rendezvous
 888               and then Self_Id.Common.Call /= null
 889               and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
 890             then
 891                Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 892
 893                pragma Assert
 894                  (Self_Id.Deferral_Level = 1
 895                    or else
 896                      (Self_Id.Deferral_Level = 0
 897                        and then not Restrictions.Abort_Allowed));
 898
 899                Initialization.Defer_Abort_Nestable (Self_Id);
 900
 901                --  Leave abort deferred until the accept body
 902             end if;
 903
 904             STPO.Unlock (Self_Id);
 905
 906          when Else_Selected =>
 907             pragma Assert (Self_Id.Open_Accepts = null);
 908
 909             if Parameters.Runtime_Traces then
 910                Send_Trace_Info (M_Select_Else);
 911             end if;
 912
 913             STPO.Unlock (Self_Id);
 914
 915          when Terminate_Selected =>
 916
 917             --  Terminate alternative is open
 918
 919             Self_Id.Open_Accepts := Open_Accepts;
 920             Self_Id.Common.State := Acceptor_Sleep;
 921
 922             --  Notify ancestors that this task is on a terminate alternative
 923
 924             STPO.Unlock (Self_Id);
 925             Utilities.Make_Passive (Self_Id, Task_Completed => False);
 926             STPO.Write_Lock (Self_Id);
 927
 928             --  Wait for normal entry call or termination
 929
 930             Wait_For_Call (Self_Id);
 931
 932             pragma Assert (Self_Id.Open_Accepts = null);
 933
 934             if Self_Id.Terminate_Alternative then
 935
 936                --  An entry call should have reset this to False, so we must be
 937                --  aborted. We cannot be in an async. select, since that is not
 938                --  legal, so the abort must be of the entire task. Therefore,
 939                --  we do not need to cancel the terminate alternative. The
 940                --  cleanup will be done in Complete_Master.
 941
 942                pragma Assert (Self_Id.Pending_ATC_Level = 0);
 943                pragma Assert (Self_Id.Awake_Count = 0);
 944
 945                STPO.Unlock (Self_Id);
 946
 947                if Single_Lock then
 948                   Unlock_RTS;
 949                end if;
 950
 951                Index := Self_Id.Chosen_Index;
 952                Initialization.Undefer_Abort_Nestable (Self_Id);
 953
 954                if Self_Id.Pending_Action then
 955                   Initialization.Do_Pending_Action (Self_Id);
 956                end if;
 957
 958                return;
 959
 960             else
 961                --  Self_Id.Common.Call and Self_Id.Chosen_Index
 962                --  should already be updated by the Caller.
 963
 964                if Self_Id.Chosen_Index /= No_Rendezvous
 965                  and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
 966                then
 967                   Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
 968
 969                   pragma Assert (Self_Id.Deferral_Level = 1);
 970
 971                   --  We need an extra defer here, to keep abort
 972                   --  deferred until we get into the accept body
 973
 974                   Initialization.Defer_Abort_Nestable (Self_Id);
 975                end if;
 976             end if;
 977
 978             STPO.Unlock (Self_Id);
 979
 980          when No_Alternative_Open =>
 981
 982             --  In this case, Index will be No_Rendezvous on return, which
 983             --  should cause a Program_Error if it is not a Delay_Mode.
 984
 985             --  If delay alternative exists (Delay_Mode) we should suspend
 986             --  until the delay expires.
 987
 988             Self_Id.Open_Accepts := null;
 989
 990             if Select_Mode = Delay_Mode then
 991                Self_Id.Common.State := Delay_Sleep;
 992
 993                loop
 994                   exit when
 995                     Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level;
 996                   Sleep (Self_Id, Delay_Sleep);
 997                end loop;
 998
 999                Self_Id.Common.State := Runnable;
1000                STPO.Unlock (Self_Id);
1001
1002             else
1003                STPO.Unlock (Self_Id);
1004
1005                if Single_Lock then
1006                   Unlock_RTS;
1007                end if;
1008
1009                Initialization.Undefer_Abort (Self_Id);
1010                raise Program_Error with "Entry call not a delay mode";
1011             end if;
1012       end case;
1013
1014       if Single_Lock then
1015          Unlock_RTS;
1016       end if;
1017
1018       --  Caller has been chosen
1019
1020       --  Self_Id.Common.Call should already be updated by the Caller.
1021
1022       --  Self_Id.Chosen_Index should either be updated by the Caller
1023       --  or by Test_Selective_Wait.
1024
1025       --  On return, we sill start rendezvous unless the accept body is
1026       --  null. In the latter case, we will have already completed the RV.
1027
1028       Index := Self_Id.Chosen_Index;
1029       Initialization.Undefer_Abort_Nestable (Self_Id);
1030    end Selective_Wait;
1031
1032    ------------------------------------
1033    -- Setup_For_Rendezvous_With_Body --
1034    ------------------------------------
1035
1036    procedure Setup_For_Rendezvous_With_Body
1037      (Entry_Call : Entry_Call_Link;
1038       Acceptor   : Task_Id) is
1039    begin
1040       Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call;
1041       Acceptor.Common.Call := Entry_Call;
1042
1043       if Entry_Call.State = Now_Abortable then
1044          Entry_Call.State := Was_Abortable;
1045       end if;
1046
1047       Boost_Priority (Entry_Call, Acceptor);
1048    end Setup_For_Rendezvous_With_Body;
1049
1050    ----------------
1051    -- Task_Count --
1052    ----------------
1053
1054    function Task_Count (E : Task_Entry_Index) return Natural is
1055       Self_Id      : constant Task_Id := STPO.Self;
1056       Return_Count : Natural;
1057
1058    begin
1059       Initialization.Defer_Abort (Self_Id);
1060
1061       if Single_Lock then
1062          Lock_RTS;
1063       end if;
1064
1065       STPO.Write_Lock (Self_Id);
1066       Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E));
1067       STPO.Unlock (Self_Id);
1068
1069       if Single_Lock then
1070          Unlock_RTS;
1071       end if;
1072
1073       Initialization.Undefer_Abort (Self_Id);
1074
1075       return Return_Count;
1076    end Task_Count;
1077
1078    ----------------------
1079    -- Task_Do_Or_Queue --
1080    ----------------------
1081
1082    function Task_Do_Or_Queue
1083      (Self_ID    : Task_Id;
1084       Entry_Call : Entry_Call_Link) return Boolean
1085    is
1086       E             : constant Task_Entry_Index :=
1087                         Task_Entry_Index (Entry_Call.E);
1088       Old_State     : constant Entry_Call_State := Entry_Call.State;
1089       Acceptor      : constant Task_Id := Entry_Call.Called_Task;
1090       Parent        : constant Task_Id := Acceptor.Common.Parent;
1091       Null_Body     : Boolean;
1092
1093    begin
1094       --  Find out whether Entry_Call can be accepted immediately
1095
1096       --    If the Acceptor is not callable, return False.
1097       --    If the rendezvous can start, initiate it.
1098       --    If the accept-body is trivial, also complete the rendezvous.
1099       --    If the acceptor is not ready, enqueue the call.
1100
1101       --  This should have a special case for Accept_Call and Accept_Trivial,
1102       --  so that we don't have the loop setup overhead, below.
1103
1104       --  The call state Done is used here and elsewhere to include both the
1105       --  case of normal successful completion, and the case of an exception
1106       --  being raised. The difference is that if an exception is raised no one
1107       --  will pay attention to the fact that State = Done. Instead the
1108       --  exception will be raised in Undefer_Abort, and control will skip past
1109       --  the place where we normally would resume from an entry call.
1110
1111       pragma Assert (not Queuing.Onqueue (Entry_Call));
1112
1113       --  We rely that the call is off-queue for protection, that the caller
1114       --  will not exit the Entry_Caller_Sleep, and so will not reuse the call
1115       --  record for another call. We rely on the Caller's lock for call State
1116       --  mod's.
1117
1118       --  If Acceptor.Terminate_Alternative is True, we need to lock Parent and
1119       --  Acceptor, in that order; otherwise, we only need a lock on Acceptor.
1120       --  However, we can't check Acceptor.Terminate_Alternative until Acceptor
1121       --  is locked. Therefore, we need to lock both. Attempts to avoid locking
1122       --  Parent tend to result in race conditions. It would work to unlock
1123       --  Parent immediately upon finding Acceptor.Terminate_Alternative to be
1124       --  False, but that violates the rule of properly nested locking (see
1125       --  System.Tasking).
1126
1127       STPO.Write_Lock (Parent);
1128       STPO.Write_Lock (Acceptor);
1129
1130       --  If the acceptor is not callable, abort the call and return False
1131
1132       if not Acceptor.Callable then
1133          STPO.Unlock (Acceptor);
1134          STPO.Unlock (Parent);
1135
1136          pragma Assert (Entry_Call.State < Done);
1137
1138          --  In case we are not the caller, set up the caller
1139          --  to raise Tasking_Error when it wakes up.
1140
1141          STPO.Write_Lock (Entry_Call.Self);
1142          Entry_Call.Exception_To_Raise := Tasking_Error'Identity;
1143          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
1144          STPO.Unlock (Entry_Call.Self);
1145
1146          return False;
1147       end if;
1148
1149       --  Try to serve the call immediately
1150
1151       if Acceptor.Open_Accepts /= null then
1152          for J in Acceptor.Open_Accepts'Range loop
1153             if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
1154
1155                --  Commit acceptor to rendezvous with us
1156
1157                Acceptor.Chosen_Index := J;
1158                Null_Body := Acceptor.Open_Accepts (J).Null_Body;
1159                Acceptor.Open_Accepts := null;
1160
1161                --  Prevent abort while call is being served
1162
1163                if Entry_Call.State = Now_Abortable then
1164                   Entry_Call.State := Was_Abortable;
1165                end if;
1166
1167                if Acceptor.Terminate_Alternative then
1168
1169                   --  Cancel terminate alternative. See matching code in
1170                   --  Selective_Wait and Vulnerable_Complete_Master.
1171
1172                   Acceptor.Terminate_Alternative := False;
1173                   Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
1174
1175                   if Acceptor.Awake_Count = 1 then
1176
1177                      --  Notify parent that acceptor is awake
1178
1179                      pragma Assert (Parent.Awake_Count > 0);
1180
1181                      Parent.Awake_Count := Parent.Awake_Count + 1;
1182
1183                      if Parent.Common.State = Master_Completion_Sleep
1184                        and then Acceptor.Master_of_Task = Parent.Master_Within
1185                      then
1186                         Parent.Common.Wait_Count :=
1187                           Parent.Common.Wait_Count + 1;
1188                      end if;
1189                   end if;
1190                end if;
1191
1192                if Null_Body then
1193
1194                   --  Rendezvous is over immediately
1195
1196                   STPO.Wakeup (Acceptor, Acceptor_Sleep);
1197                   STPO.Unlock (Acceptor);
1198                   STPO.Unlock (Parent);
1199
1200                   STPO.Write_Lock (Entry_Call.Self);
1201                   Initialization.Wakeup_Entry_Caller
1202                     (Self_ID, Entry_Call, Done);
1203                   STPO.Unlock (Entry_Call.Self);
1204
1205                else
1206                   Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor);
1207
1208                   --  For terminate_alternative, acceptor may not be asleep
1209                   --  yet, so we skip the wakeup
1210
1211                   if Acceptor.Common.State /= Runnable then
1212                      STPO.Wakeup (Acceptor, Acceptor_Sleep);
1213                   end if;
1214
1215                   STPO.Unlock (Acceptor);
1216                   STPO.Unlock (Parent);
1217                end if;
1218
1219                return True;
1220             end if;
1221          end loop;
1222
1223          --  The acceptor is accepting, but not this entry
1224       end if;
1225
1226       --  If the acceptor was ready to accept this call,
1227       --  we would not have gotten this far, so now we should
1228       --  (re)enqueue the call, if the mode permits that.
1229
1230       --  If the call is timed, it may have timed out before the requeue,
1231       --  in the unusual case where the current accept has taken longer than
1232       --  the given delay. In that case the requeue is cancelled, and the
1233       --  outer timed call will be aborted.
1234
1235       if Entry_Call.Mode = Conditional_Call
1236         or else
1237           (Entry_Call.Mode = Timed_Call
1238             and then Entry_Call.With_Abort
1239             and then Entry_Call.Cancellation_Attempted)
1240       then
1241          STPO.Unlock (Acceptor);
1242          STPO.Unlock (Parent);
1243
1244          STPO.Write_Lock (Entry_Call.Self);
1245
1246          pragma Assert (Entry_Call.State >= Was_Abortable);
1247
1248          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
1249          STPO.Unlock (Entry_Call.Self);
1250
1251       else
1252          --  Timed_Call, Simple_Call, or Asynchronous_Call
1253
1254          Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
1255
1256          --  Update abortability of call
1257
1258          pragma Assert (Old_State < Done);
1259
1260          Entry_Call.State :=
1261            New_State (Entry_Call.With_Abort, Entry_Call.State);
1262
1263          STPO.Unlock (Acceptor);
1264          STPO.Unlock (Parent);
1265
1266          if Old_State /= Entry_Call.State
1267            and then Entry_Call.State = Now_Abortable
1268            and then Entry_Call.Mode /= Simple_Call
1269            and then Entry_Call.Self /= Self_ID
1270
1271          --  Asynchronous_Call or Conditional_Call
1272
1273          then
1274             --  Because of ATCB lock ordering rule
1275
1276             STPO.Write_Lock (Entry_Call.Self);
1277
1278             if Entry_Call.Self.Common.State = Async_Select_Sleep then
1279
1280                --  Caller may not yet have reached wait-point
1281
1282                STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1283             end if;
1284
1285             STPO.Unlock (Entry_Call.Self);
1286          end if;
1287       end if;
1288
1289       return True;
1290    end Task_Do_Or_Queue;
1291
1292    ---------------------
1293    -- Task_Entry_Call --
1294    ---------------------
1295
1296    procedure Task_Entry_Call
1297      (Acceptor              : Task_Id;
1298       E                     : Task_Entry_Index;
1299       Uninterpreted_Data    : System.Address;
1300       Mode                  : Call_Modes;
1301       Rendezvous_Successful : out Boolean)
1302    is
1303       Self_Id    : constant Task_Id := STPO.Self;
1304       Entry_Call : Entry_Call_Link;
1305
1306    begin
1307       --  If pragma Detect_Blocking is active then Program_Error must be
1308       --  raised if this potentially blocking operation is called from a
1309       --  protected action.
1310
1311       if System.Tasking.Detect_Blocking
1312         and then Self_Id.Common.Protected_Action_Nesting > 0
1313       then
1314          raise Program_Error with "potentially blocking operation";
1315       end if;
1316
1317       if Parameters.Runtime_Traces then
1318          Send_Trace_Info (W_Call, Acceptor, Entry_Index (E));
1319       end if;
1320
1321       if Mode = Simple_Call or else Mode = Conditional_Call then
1322          Call_Synchronous
1323            (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
1324
1325       else
1326          --  This is an asynchronous call
1327
1328          --  Abort must already be deferred by the compiler-generated code.
1329          --  Without this, an abort that occurs between the time that this
1330          --  call is made and the time that the abortable part's cleanup
1331          --  handler is set up might miss the cleanup handler and leave the
1332          --  call pending.
1333
1334          Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1335          pragma Debug
1336            (Debug.Trace (Self_Id, "TEC: entered ATC level: " &
1337             ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1338          Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1339          Entry_Call.Next := null;
1340          Entry_Call.Mode := Mode;
1341          Entry_Call.Cancellation_Attempted := False;
1342          Entry_Call.State := Not_Yet_Abortable;
1343          Entry_Call.E := Entry_Index (E);
1344          Entry_Call.Prio := Get_Priority (Self_Id);
1345          Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1346          Entry_Call.Called_Task := Acceptor;
1347          Entry_Call.Called_PO := Null_Address;
1348          Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1349          Entry_Call.With_Abort := True;
1350
1351          if Single_Lock then
1352             Lock_RTS;
1353          end if;
1354
1355          if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1356             STPO.Write_Lock (Self_Id);
1357             Utilities.Exit_One_ATC_Level (Self_Id);
1358             STPO.Unlock (Self_Id);
1359
1360             if Single_Lock then
1361                Unlock_RTS;
1362             end if;
1363
1364             Initialization.Undefer_Abort (Self_Id);
1365
1366             if Parameters.Runtime_Traces then
1367                Send_Trace_Info (E_Missed, Acceptor);
1368             end if;
1369
1370             raise Tasking_Error;
1371          end if;
1372
1373          --  The following is special for async. entry calls. If the call was
1374          --  not queued abortably, we need to wait until it is before
1375          --  proceeding with the abortable part.
1376
1377          --  Wait_Until_Abortable can be called unconditionally here, but it is
1378          --  expensive.
1379
1380          if Entry_Call.State < Was_Abortable then
1381             Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call);
1382          end if;
1383
1384          if Single_Lock then
1385             Unlock_RTS;
1386          end if;
1387
1388          --  Note: following assignment needs to be atomic
1389
1390          Rendezvous_Successful := Entry_Call.State = Done;
1391       end if;
1392    end Task_Entry_Call;
1393
1394    -----------------------
1395    -- Task_Entry_Caller --
1396    -----------------------
1397
1398    function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is
1399       Self_Id    : constant Task_Id := STPO.Self;
1400       Entry_Call : Entry_Call_Link;
1401
1402    begin
1403       Entry_Call := Self_Id.Common.Call;
1404
1405       for Depth in 1 .. D loop
1406          Entry_Call := Entry_Call.Acceptor_Prev_Call;
1407          pragma Assert (Entry_Call /= null);
1408       end loop;
1409
1410       return Entry_Call.Self;
1411    end Task_Entry_Caller;
1412
1413    --------------------------
1414    -- Timed_Selective_Wait --
1415    --------------------------
1416
1417    procedure Timed_Selective_Wait
1418      (Open_Accepts       : Accept_List_Access;
1419       Select_Mode        : Select_Modes;
1420       Uninterpreted_Data : out System.Address;
1421       Timeout            : Duration;
1422       Mode               : Delay_Modes;
1423       Index              : out Select_Index)
1424    is
1425       Self_Id          : constant Task_Id := STPO.Self;
1426       Treatment        : Select_Treatment;
1427       Entry_Call       : Entry_Call_Link;
1428       Caller           : Task_Id;
1429       Selection        : Select_Index;
1430       Open_Alternative : Boolean;
1431       Timedout         : Boolean := False;
1432       Yielded          : Boolean := True;
1433
1434    begin
1435       pragma Assert (Select_Mode = Delay_Mode);
1436
1437       Initialization.Defer_Abort (Self_Id);
1438
1439       --  If we are aborted here, the effect will be pending
1440
1441       if Single_Lock then
1442          Lock_RTS;
1443       end if;
1444
1445       STPO.Write_Lock (Self_Id);
1446
1447       if not Self_Id.Callable then
1448          pragma Assert (Self_Id.Pending_ATC_Level = 0);
1449
1450          pragma Assert (Self_Id.Pending_Action);
1451
1452          STPO.Unlock (Self_Id);
1453
1454          if Single_Lock then
1455             Unlock_RTS;
1456          end if;
1457
1458          Initialization.Undefer_Abort (Self_Id);
1459
1460          --  Should never get here ???
1461
1462          pragma Assert (False);
1463          raise Standard'Abort_Signal;
1464       end if;
1465
1466       Uninterpreted_Data := Null_Address;
1467
1468       pragma Assert (Open_Accepts /= null);
1469
1470       Queuing.Select_Task_Entry_Call
1471         (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative);
1472
1473       --  Determine the kind and disposition of the select
1474
1475       Treatment := Default_Treatment (Select_Mode);
1476       Self_Id.Chosen_Index := No_Rendezvous;
1477
1478       if Open_Alternative then
1479          if Entry_Call /= null then
1480             if Open_Accepts (Selection).Null_Body then
1481                Treatment := Accept_Alternative_Completed;
1482
1483             else
1484                Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id);
1485                Treatment := Accept_Alternative_Selected;
1486             end if;
1487
1488             Self_Id.Chosen_Index := Selection;
1489
1490          elsif Treatment = No_Alternative_Open then
1491             Treatment := Accept_Alternative_Open;
1492          end if;
1493       end if;
1494
1495       --  Handle the select according to the disposition selected above
1496
1497       case Treatment is
1498          when Accept_Alternative_Selected =>
1499
1500             --  Ready to rendezvous. In this case the accept body is not
1501             --  Null_Body. Defer abort until it gets into the accept body.
1502
1503             Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1504             Initialization.Defer_Abort_Nestable (Self_Id);
1505             STPO.Unlock (Self_Id);
1506
1507          when Accept_Alternative_Completed =>
1508
1509             --  Rendezvous is over
1510
1511             if Parameters.Runtime_Traces then
1512                Send_Trace_Info (M_RDV_Complete, Entry_Call.Self);
1513             end if;
1514
1515             STPO.Unlock (Self_Id);
1516             Caller := Entry_Call.Self;
1517
1518             STPO.Write_Lock (Caller);
1519             Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
1520             STPO.Unlock (Caller);
1521
1522          when Accept_Alternative_Open =>
1523
1524             --  Wait for caller
1525
1526             Self_Id.Open_Accepts := Open_Accepts;
1527
1528             --  Wait for a normal call and a pending action until the
1529             --  Wakeup_Time is reached.
1530
1531             Self_Id.Common.State := Acceptor_Delay_Sleep;
1532
1533             --  Try to remove calls to Sleep in the loop below by letting the
1534             --  caller a chance of getting ready immediately, using Unlock
1535             --  Yield. See similar action in Wait_For_Completion/Wait_For_Call.
1536
1537             if Single_Lock then
1538                Unlock_RTS;
1539             else
1540                Unlock (Self_Id);
1541             end if;
1542
1543             if Self_Id.Open_Accepts /= null then
1544                Yield;
1545             end if;
1546
1547             if Single_Lock then
1548                Lock_RTS;
1549             else
1550                Write_Lock (Self_Id);
1551             end if;
1552
1553             --  Check if this task has been aborted while the lock was released
1554
1555             if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1556                Self_Id.Open_Accepts := null;
1557             end if;
1558
1559             loop
1560                exit when Self_Id.Open_Accepts = null;
1561
1562                if Timedout then
1563                   Sleep (Self_Id, Acceptor_Delay_Sleep);
1564                else
1565                   if Parameters.Runtime_Traces then
1566                      Send_Trace_Info (WT_Select,
1567                                       Self_Id,
1568                                       Integer (Open_Accepts'Length),
1569                                       Timeout);
1570                   end if;
1571
1572                   STPO.Timed_Sleep (Self_Id, Timeout, Mode,
1573                     Acceptor_Delay_Sleep, Timedout, Yielded);
1574                end if;
1575
1576                if Timedout then
1577                   Self_Id.Open_Accepts := null;
1578
1579                   if Parameters.Runtime_Traces then
1580                      Send_Trace_Info (E_Timeout);
1581                   end if;
1582                end if;
1583             end loop;
1584
1585             Self_Id.Common.State := Runnable;
1586
1587             --  Self_Id.Common.Call should already be updated by the Caller if
1588             --  not aborted. It might also be ready to do rendezvous even if
1589             --  this wakes up due to an abort. Therefore, if the call is not
1590             --  empty we need to do the rendezvous if the accept body is not
1591             --  Null_Body.
1592
1593             if Self_Id.Chosen_Index /= No_Rendezvous
1594               and then Self_Id.Common.Call /= null
1595               and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body
1596             then
1597                Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data;
1598
1599                pragma Assert (Self_Id.Deferral_Level = 1);
1600
1601                Initialization.Defer_Abort_Nestable (Self_Id);
1602
1603                --  Leave abort deferred until the accept body
1604             end if;
1605
1606             STPO.Unlock (Self_Id);
1607
1608          when No_Alternative_Open =>
1609
1610             --  In this case, Index will be No_Rendezvous on return. We sleep
1611             --  for the time we need to.
1612
1613             --  Wait for a signal or timeout. A wakeup can be made
1614             --  for several reasons:
1615             --    1) Delay is expired
1616             --    2) Pending_Action needs to be checked
1617             --       (Abort, Priority change)
1618             --    3) Spurious wakeup
1619
1620             Self_Id.Open_Accepts := null;
1621             Self_Id.Common.State := Acceptor_Delay_Sleep;
1622
1623             STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep,
1624               Timedout, Yielded);
1625
1626             Self_Id.Common.State := Runnable;
1627
1628             STPO.Unlock (Self_Id);
1629
1630          when others =>
1631
1632             --  Should never get here
1633
1634             pragma Assert (False);
1635             null;
1636       end case;
1637
1638       if Single_Lock then
1639          Unlock_RTS;
1640       end if;
1641
1642       if not Yielded then
1643          Yield;
1644       end if;
1645
1646       --  Caller has been chosen
1647
1648       --  Self_Id.Common.Call should already be updated by the Caller
1649
1650       --  Self_Id.Chosen_Index should either be updated by the Caller
1651       --  or by Test_Selective_Wait
1652
1653       Index := Self_Id.Chosen_Index;
1654       Initialization.Undefer_Abort_Nestable (Self_Id);
1655
1656       --  Start rendezvous, if not already completed
1657    end Timed_Selective_Wait;
1658
1659    ---------------------------
1660    -- Timed_Task_Entry_Call --
1661    ---------------------------
1662
1663    procedure Timed_Task_Entry_Call
1664      (Acceptor              : Task_Id;
1665       E                     : Task_Entry_Index;
1666       Uninterpreted_Data    : System.Address;
1667       Timeout               : Duration;
1668       Mode                  : Delay_Modes;
1669       Rendezvous_Successful : out Boolean)
1670    is
1671       Self_Id    : constant Task_Id := STPO.Self;
1672       Level      : ATC_Level;
1673       Entry_Call : Entry_Call_Link;
1674
1675       Yielded : Boolean;
1676       pragma Unreferenced (Yielded);
1677
1678    begin
1679       --  If pragma Detect_Blocking is active then Program_Error must be
1680       --  raised if this potentially blocking operation is called from a
1681       --  protected action.
1682
1683       if System.Tasking.Detect_Blocking
1684         and then Self_Id.Common.Protected_Action_Nesting > 0
1685       then
1686          raise Program_Error with "potentially blocking operation";
1687       end if;
1688
1689       Initialization.Defer_Abort (Self_Id);
1690       Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1691
1692       pragma Debug
1693         (Debug.Trace (Self_Id, "TTEC: entered ATC level: " &
1694          ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1695
1696       if Parameters.Runtime_Traces then
1697          Send_Trace_Info (WT_Call, Acceptor,
1698                           Entry_Index (E), Timeout);
1699       end if;
1700
1701       Level := Self_Id.ATC_Nesting_Level;
1702       Entry_Call := Self_Id.Entry_Calls (Level)'Access;
1703       Entry_Call.Next := null;
1704       Entry_Call.Mode := Timed_Call;
1705       Entry_Call.Cancellation_Attempted := False;
1706
1707       --  If this is a call made inside of an abort deferred region,
1708       --  the call should be never abortable.
1709
1710       Entry_Call.State :=
1711         (if Self_Id.Deferral_Level > 1
1712          then Never_Abortable
1713          else Now_Abortable);
1714
1715       Entry_Call.E := Entry_Index (E);
1716       Entry_Call.Prio := Get_Priority (Self_Id);
1717       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1718       Entry_Call.Called_Task := Acceptor;
1719       Entry_Call.Called_PO := Null_Address;
1720       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1721       Entry_Call.With_Abort := True;
1722
1723       --  Note: the caller will undefer abort on return (see WARNING above)
1724
1725       if Single_Lock then
1726          Lock_RTS;
1727       end if;
1728
1729       if not Task_Do_Or_Queue (Self_Id, Entry_Call) then
1730          STPO.Write_Lock (Self_Id);
1731          Utilities.Exit_One_ATC_Level (Self_Id);
1732          STPO.Unlock (Self_Id);
1733
1734          if Single_Lock then
1735             Unlock_RTS;
1736          end if;
1737
1738          Initialization.Undefer_Abort (Self_Id);
1739
1740          if Parameters.Runtime_Traces then
1741             Send_Trace_Info (E_Missed, Acceptor);
1742          end if;
1743          raise Tasking_Error;
1744       end if;
1745
1746       Write_Lock (Self_Id);
1747       Entry_Calls.Wait_For_Completion_With_Timeout
1748         (Entry_Call, Timeout, Mode, Yielded);
1749       Unlock (Self_Id);
1750
1751       if Single_Lock then
1752          Unlock_RTS;
1753       end if;
1754
1755       --  ??? Do we need to yield in case Yielded is False
1756
1757       Rendezvous_Successful := Entry_Call.State = Done;
1758       Initialization.Undefer_Abort (Self_Id);
1759       Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1760    end Timed_Task_Entry_Call;
1761
1762    -------------------
1763    -- Wait_For_Call --
1764    -------------------
1765
1766    procedure Wait_For_Call (Self_Id : Task_Id) is
1767    begin
1768       Self_Id.Common.State := Acceptor_Sleep;
1769
1770       --  Try to remove calls to Sleep in the loop below by letting the caller
1771       --  a chance of getting ready immediately, using Unlock & Yield.
1772       --  See similar action in Wait_For_Completion & Timed_Selective_Wait.
1773
1774       if Single_Lock then
1775          Unlock_RTS;
1776       else
1777          Unlock (Self_Id);
1778       end if;
1779
1780       if Self_Id.Open_Accepts /= null then
1781          Yield;
1782       end if;
1783
1784       if Single_Lock then
1785          Lock_RTS;
1786       else
1787          Write_Lock (Self_Id);
1788       end if;
1789
1790       --  Check if this task has been aborted while the lock was released
1791
1792       if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
1793          Self_Id.Open_Accepts := null;
1794       end if;
1795
1796       loop
1797          exit when Self_Id.Open_Accepts = null;
1798          Sleep (Self_Id, Acceptor_Sleep);
1799       end loop;
1800
1801       Self_Id.Common.State := Runnable;
1802    end Wait_For_Call;
1803
1804 end System.Tasking.Rendezvous;