gcc/ada/s-tasren.adb

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