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