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