gcc/ada/s-tasren.adb

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