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