gcc/ada/s-taenca.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 . E N T R Y _ C A L L S          --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --         Copyright (C) 1992-2004, Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNARL was developed by the GNARL team at Florida State University.       --
  30 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System.Task_Primitives.Operations;
  35 --  used for STPO.Write_Lock
  36 --           Unlock
  37 --           STPO.Get_Priority
  38 --           Sleep
  39 --           Timed_Sleep
  40
  41 with System.Tasking.Initialization;
  42 --  used for Change_Base_Priority
  43 --           Dynamic_Priority_Support
  44 --           Defer_Abort/Undefer_Abort
  45
  46 with System.Tasking.Protected_Objects.Entries;
  47 --  used for To_Protection
  48
  49 with System.Tasking.Protected_Objects.Operations;
  50 --  used for PO_Service_Entries
  51
  52 with System.Tasking.Queuing;
  53 --  used for Requeue_Call_With_New_Prio
  54 --           Onqueue
  55 --           Dequeue_Call
  56
  57 with System.Tasking.Utilities;
  58 --  used for Exit_One_ATC_Level
  59
  60 with System.Parameters;
  61 --  used for Single_Lock
  62 --           Runtime_Traces
  63
  64 with System.Traces;
  65 --  used for Send_Trace_Info
  66
  67 package body System.Tasking.Entry_Calls is
  68
  69    package STPO renames System.Task_Primitives.Operations;
  70
  71    use Parameters;
  72    use Task_Primitives;
  73    use Protected_Objects.Entries;
  74    use Protected_Objects.Operations;
  75    use System.Traces;
  76
  77    --  DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock
  78    --  internally. Those operations will raise Program_Error, which
  79    --  we are not prepared to handle inside the RTS. Instead, use
  80    --  System.Task_Primitives lock operations directly on Protection.L.
  81
  82    -----------------------
  83    -- Local Subprograms --
  84    -----------------------
  85
  86    procedure Lock_Server (Entry_Call : Entry_Call_Link);
  87    --  This locks the server targeted by Entry_Call.
  88    --
  89    --  This may be a task or a protected object,
  90    --  depending on the target of the original call or any subsequent
  91    --  requeues.
  92    --
  93    --  This routine is needed because the field specifying the server
  94    --  for this call must be protected by the server's mutex. If it were
  95    --  protected by the caller's mutex, accessing the server's queues would
  96    --  require locking the caller to get the server, locking the server,
  97    --  and then accessing the queues. This involves holding two ATCB
  98    --  locks at once, something which we can guarantee that it will always
  99    --  be done in the same order, or locking a protected object while we
 100    --  hold an ATCB lock, something which is not permitted. Since
 101    --  the server cannot be obtained reliably, it must be obtained unreliably
 102    --  and then checked again once it has been locked.
 103    --
 104    --  If Single_Lock and server is a PO, release RTS_Lock.
 105    --
 106    --  This should only be called by the Entry_Call.Self.
 107    --  It should be holding no other ATCB locks at the time.
 108
 109    procedure Unlock_Server (Entry_Call : Entry_Call_Link);
 110    --  STPO.Unlock the server targeted by Entry_Call. The server must
 111    --  be locked before calling this.
 112    --
 113    --  If Single_Lock and server is a PO, take RTS_Lock on exit.
 114
 115    procedure Unlock_And_Update_Server
 116      (Self_ID    : Task_Id;
 117       Entry_Call : Entry_Call_Link);
 118    --  Similar to Unlock_Server, but services entry calls if the
 119    --  server is a protected object.
 120    --
 121    --  If Single_Lock and server is a PO, take RTS_Lock on exit.
 122
 123    procedure Check_Pending_Actions_For_Entry_Call
 124      (Self_ID    : Task_Id;
 125       Entry_Call : Entry_Call_Link);
 126    --  This procedure performs priority change of a queued call and
 127    --  dequeuing of an entry call when the call is cancelled.
 128    --  If the call is dequeued the state should be set to Cancelled.
 129    --  Call only with abort deferred and holding lock of Self_ID. This
 130    --  is a bit of common code for all entry calls. The effect is to do
 131    --  any deferred base priority change operation, in case some other
 132    --  task called STPO.Set_Priority while the current task had abort deferred,
 133    --  and to dequeue the call if the call has been aborted.
 134
 135    procedure Poll_Base_Priority_Change_At_Entry_Call
 136      (Self_ID    : Task_Id;
 137       Entry_Call : Entry_Call_Link);
 138    pragma Inline (Poll_Base_Priority_Change_At_Entry_Call);
 139    --  A specialized version of Poll_Base_Priority_Change,
 140    --  that does the optional entry queue reordering.
 141    --  Has to be called with the Self_ID's ATCB write-locked.
 142    --  May temporariliy release the lock.
 143
 144    ---------------------
 145    -- Check_Exception --
 146    ---------------------
 147
 148    procedure Check_Exception
 149      (Self_ID    : Task_Id;
 150       Entry_Call : Entry_Call_Link)
 151    is
 152       pragma Warnings (Off, Self_ID);
 153
 154       use type Ada.Exceptions.Exception_Id;
 155
 156       procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
 157       pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
 158
 159       E : constant Ada.Exceptions.Exception_Id :=
 160             Entry_Call.Exception_To_Raise;
 161    begin
 162       --  pragma Assert (Self_ID.Deferral_Level = 0);
 163       --  The above may be useful for debugging, but the Florist packages
 164       --  contain critical sections that defer abort and then do entry calls,
 165       --  which causes the above Assert to trip.
 166
 167       if E /= Ada.Exceptions.Null_Id then
 168          Internal_Raise (E);
 169       end if;
 170    end Check_Exception;
 171
 172    ------------------------------------------
 173    -- Check_Pending_Actions_For_Entry_Call --
 174    ------------------------------------------
 175
 176    procedure Check_Pending_Actions_For_Entry_Call
 177      (Self_ID    : Task_Id;
 178       Entry_Call : Entry_Call_Link) is
 179    begin
 180       pragma Assert (Self_ID = Entry_Call.Self);
 181
 182       Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call);
 183
 184       if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
 185         and then Entry_Call.State = Now_Abortable
 186       then
 187          STPO.Unlock (Self_ID);
 188          Lock_Server (Entry_Call);
 189
 190          if Queuing.Onqueue (Entry_Call)
 191            and then Entry_Call.State = Now_Abortable
 192          then
 193             Queuing.Dequeue_Call (Entry_Call);
 194
 195             if Entry_Call.Cancellation_Attempted then
 196                Entry_Call.State := Cancelled;
 197             else
 198                Entry_Call.State := Done;
 199             end if;
 200
 201             Unlock_And_Update_Server (Self_ID, Entry_Call);
 202
 203          else
 204             Unlock_Server (Entry_Call);
 205          end if;
 206
 207          STPO.Write_Lock (Self_ID);
 208       end if;
 209    end Check_Pending_Actions_For_Entry_Call;
 210
 211    -----------------
 212    -- Lock_Server --
 213    -----------------
 214
 215    procedure Lock_Server (Entry_Call : Entry_Call_Link) is
 216       Test_Task         : Task_Id;
 217       Test_PO           : Protection_Entries_Access;
 218       Ceiling_Violation : Boolean;
 219       Failures          : Integer := 0;
 220
 221    begin
 222       Test_Task := Entry_Call.Called_Task;
 223
 224       loop
 225          if Test_Task = null then
 226
 227             --  Entry_Call was queued on a protected object,
 228             --  or in transition, when we last fetched Test_Task.
 229
 230             Test_PO := To_Protection (Entry_Call.Called_PO);
 231
 232             if Test_PO = null then
 233
 234                --  We had very bad luck, interleaving with TWO different
 235                --  requeue operations. Go around the loop and try again.
 236
 237                if Single_Lock then
 238                   STPO.Unlock_RTS;
 239                   STPO.Yield;
 240                   STPO.Lock_RTS;
 241                else
 242                   STPO.Yield;
 243                end if;
 244
 245             else
 246                if Single_Lock then
 247                   STPO.Unlock_RTS;
 248                end if;
 249
 250                Lock_Entries (Test_PO, Ceiling_Violation);
 251
 252                --  ????
 253                --  The following code allows Lock_Server to be called
 254                --  when cancelling a call, to allow for the possibility
 255                --  that the priority of the caller has been raised
 256                --  beyond that of the protected entry call by
 257                --  Ada.Dynamic_Priorities.Set_Priority.
 258
 259                --  If the current task has a higher priority than the ceiling
 260                --  of the protected object, temporarily lower it. It will
 261                --  be reset in Unlock.
 262
 263                if Ceiling_Violation then
 264                   declare
 265                      Current_Task      : constant Task_Id := STPO.Self;
 266                      Old_Base_Priority : System.Any_Priority;
 267
 268                   begin
 269                      if Single_Lock then
 270                         STPO.Lock_RTS;
 271                      end if;
 272
 273                      STPO.Write_Lock (Current_Task);
 274                      Old_Base_Priority := Current_Task.Common.Base_Priority;
 275                      Current_Task.New_Base_Priority := Test_PO.Ceiling;
 276                      System.Tasking.Initialization.Change_Base_Priority
 277                        (Current_Task);
 278                      STPO.Unlock (Current_Task);
 279
 280                      if Single_Lock then
 281                         STPO.Unlock_RTS;
 282                      end if;
 283
 284                      --  Following lock should not fail
 285
 286                      Lock_Entries (Test_PO);
 287
 288                      Test_PO.Old_Base_Priority := Old_Base_Priority;
 289                      Test_PO.Pending_Action := True;
 290                   end;
 291                end if;
 292
 293                exit when To_Address (Test_PO) = Entry_Call.Called_PO;
 294                Unlock_Entries (Test_PO);
 295
 296                if Single_Lock then
 297                   STPO.Lock_RTS;
 298                end if;
 299             end if;
 300
 301          else
 302             STPO.Write_Lock (Test_Task);
 303             exit when Test_Task = Entry_Call.Called_Task;
 304             STPO.Unlock (Test_Task);
 305          end if;
 306
 307          Test_Task := Entry_Call.Called_Task;
 308          Failures := Failures + 1;
 309          pragma Assert (Failures <= 5);
 310       end loop;
 311    end Lock_Server;
 312
 313    ---------------------------------------------
 314    -- Poll_Base_Priority_Change_At_Entry_Call --
 315    ---------------------------------------------
 316
 317    procedure Poll_Base_Priority_Change_At_Entry_Call
 318      (Self_ID    : Task_Id;
 319       Entry_Call : Entry_Call_Link) is
 320    begin
 321       if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then
 322          --  Check for ceiling violations ???
 323
 324          Self_ID.Pending_Priority_Change := False;
 325
 326          if Self_ID.Common.Base_Priority = Self_ID.New_Base_Priority then
 327             if Single_Lock then
 328                STPO.Unlock_RTS;
 329                STPO.Yield;
 330                STPO.Lock_RTS;
 331             else
 332                STPO.Unlock (Self_ID);
 333                STPO.Yield;
 334                STPO.Write_Lock (Self_ID);
 335             end if;
 336
 337          else
 338             if Self_ID.Common.Base_Priority < Self_ID.New_Base_Priority then
 339                --  Raising priority
 340
 341                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 342                STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 343
 344             else
 345                --  Lowering priority
 346
 347                Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
 348                STPO.Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
 349
 350                if Single_Lock then
 351                   STPO.Unlock_RTS;
 352                   STPO.Yield;
 353                   STPO.Lock_RTS;
 354                else
 355                   STPO.Unlock (Self_ID);
 356                   STPO.Yield;
 357                   STPO.Write_Lock (Self_ID);
 358                end if;
 359             end if;
 360          end if;
 361
 362          --  Requeue the entry call at the new priority.
 363          --  We need to requeue even if the new priority is the same than
 364          --  the previous (see ACVC cxd4006).
 365
 366          STPO.Unlock (Self_ID);
 367          Lock_Server (Entry_Call);
 368          Queuing.Requeue_Call_With_New_Prio
 369            (Entry_Call, STPO.Get_Priority (Self_ID));
 370          Unlock_And_Update_Server (Self_ID, Entry_Call);
 371          STPO.Write_Lock (Self_ID);
 372       end if;
 373    end Poll_Base_Priority_Change_At_Entry_Call;
 374
 375    --------------------
 376    -- Reset_Priority --
 377    --------------------
 378
 379    procedure Reset_Priority
 380      (Acceptor               : Task_Id;
 381       Acceptor_Prev_Priority : Rendezvous_Priority) is
 382    begin
 383       pragma Assert (Acceptor = STPO.Self);
 384
 385       --  Since we limit this kind of "active" priority change to be done
 386       --  by the task for itself, we don't need to lock Acceptor.
 387
 388       if Acceptor_Prev_Priority /= Priority_Not_Boosted then
 389          STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority,
 390            Loss_Of_Inheritance => True);
 391       end if;
 392    end Reset_Priority;
 393
 394    ------------------------------
 395    -- Try_To_Cancel_Entry_Call --
 396    ------------------------------
 397
 398    procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is
 399       Entry_Call : Entry_Call_Link;
 400       Self_ID    : constant Task_Id := STPO.Self;
 401
 402       use type Ada.Exceptions.Exception_Id;
 403
 404    begin
 405       Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
 406
 407       --  Experimentation has shown that abort is sometimes (but not
 408       --  always) already deferred when Cancel_xxx_Entry_Call is called.
 409       --  That may indicate an error. Find out what is going on. ???
 410
 411       pragma Assert (Entry_Call.Mode = Asynchronous_Call);
 412       Initialization.Defer_Abort_Nestable (Self_ID);
 413
 414       if Single_Lock then
 415          STPO.Lock_RTS;
 416       end if;
 417
 418       STPO.Write_Lock (Self_ID);
 419       Entry_Call.Cancellation_Attempted := True;
 420
 421       if Self_ID.Pending_ATC_Level >= Entry_Call.Level then
 422          Self_ID.Pending_ATC_Level := Entry_Call.Level - 1;
 423       end if;
 424
 425       Entry_Calls.Wait_For_Completion (Entry_Call);
 426       STPO.Unlock (Self_ID);
 427
 428       if Single_Lock then
 429          STPO.Unlock_RTS;
 430       end if;
 431
 432       Succeeded := Entry_Call.State = Cancelled;
 433
 434       if Succeeded then
 435          Initialization.Undefer_Abort_Nestable (Self_ID);
 436       else
 437          --  ???
 438
 439          Initialization.Undefer_Abort_Nestable (Self_ID);
 440
 441          --  Ideally, abort should no longer be deferred at this
 442          --  point, so we should be able to call Check_Exception.
 443          --  The loop below should be considered temporary,
 444          --  to work around the possiblility that abort may be deferred
 445          --  more than one level deep.
 446
 447          if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then
 448             while Self_ID.Deferral_Level > 0 loop
 449                System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID);
 450             end loop;
 451
 452             Entry_Calls.Check_Exception (Self_ID, Entry_Call);
 453          end if;
 454       end if;
 455    end Try_To_Cancel_Entry_Call;
 456
 457    ------------------------------
 458    -- Unlock_And_Update_Server --
 459    ------------------------------
 460
 461    procedure Unlock_And_Update_Server
 462      (Self_ID    : Task_Id;
 463       Entry_Call : Entry_Call_Link)
 464    is
 465       Called_PO : Protection_Entries_Access;
 466       Caller    : Task_Id;
 467
 468    begin
 469       if Entry_Call.Called_Task /= null then
 470          STPO.Unlock (Entry_Call.Called_Task);
 471       else
 472          Called_PO := To_Protection (Entry_Call.Called_PO);
 473          PO_Service_Entries (Self_ID, Called_PO, False);
 474
 475          if Called_PO.Pending_Action then
 476             Called_PO.Pending_Action := False;
 477             Caller := STPO.Self;
 478
 479             if Single_Lock then
 480                STPO.Lock_RTS;
 481             end if;
 482
 483             STPO.Write_Lock (Caller);
 484             Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
 485             Initialization.Change_Base_Priority (Caller);
 486             STPO.Unlock (Caller);
 487
 488             if Single_Lock then
 489                STPO.Unlock_RTS;
 490             end if;
 491          end if;
 492
 493          Unlock_Entries (Called_PO);
 494
 495          if Single_Lock then
 496             STPO.Lock_RTS;
 497          end if;
 498       end if;
 499    end Unlock_And_Update_Server;
 500
 501    -------------------
 502    -- Unlock_Server --
 503    -------------------
 504
 505    procedure Unlock_Server (Entry_Call : Entry_Call_Link) is
 506       Caller    : Task_Id;
 507       Called_PO : Protection_Entries_Access;
 508
 509    begin
 510       if Entry_Call.Called_Task /= null then
 511          STPO.Unlock (Entry_Call.Called_Task);
 512       else
 513          Called_PO := To_Protection (Entry_Call.Called_PO);
 514
 515          if Called_PO.Pending_Action then
 516             Called_PO.Pending_Action := False;
 517             Caller := STPO.Self;
 518
 519             if Single_Lock then
 520                STPO.Lock_RTS;
 521             end if;
 522
 523             STPO.Write_Lock (Caller);
 524             Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
 525             Initialization.Change_Base_Priority (Caller);
 526             STPO.Unlock (Caller);
 527
 528             if Single_Lock then
 529                STPO.Unlock_RTS;
 530             end if;
 531          end if;
 532
 533          Unlock_Entries (Called_PO);
 534
 535          if Single_Lock then
 536             STPO.Lock_RTS;
 537          end if;
 538       end if;
 539    end Unlock_Server;
 540
 541    -------------------------
 542    -- Wait_For_Completion --
 543    -------------------------
 544
 545    procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
 546       Self_Id : constant Task_Id := Entry_Call.Self;
 547    begin
 548       --  If this is a conditional call, it should be cancelled when it
 549       --  becomes abortable. This is checked in the loop below.
 550
 551       if Parameters.Runtime_Traces then
 552          Send_Trace_Info (W_Completion);
 553       end if;
 554
 555       --  Try to remove calls to Sleep in the loop below by letting the caller
 556       --  a chance of getting ready immediately, using Unlock & Yield.
 557       --  See similar action in Wait_For_Call & Selective_Wait.
 558
 559       if Single_Lock then
 560          STPO.Unlock_RTS;
 561       else
 562          STPO.Unlock (Self_Id);
 563       end if;
 564
 565       if Entry_Call.State < Done then
 566          STPO.Yield;
 567       end if;
 568
 569       if Single_Lock then
 570          STPO.Lock_RTS;
 571       else
 572          STPO.Write_Lock (Self_Id);
 573       end if;
 574
 575       Self_Id.Common.State := Entry_Caller_Sleep;
 576
 577       loop
 578          Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
 579
 580          exit when Entry_Call.State >= Done;
 581
 582          STPO.Sleep (Self_Id, Entry_Caller_Sleep);
 583       end loop;
 584
 585       Self_Id.Common.State := Runnable;
 586       Utilities.Exit_One_ATC_Level (Self_Id);
 587
 588       if Parameters.Runtime_Traces then
 589          Send_Trace_Info (M_Call_Complete);
 590       end if;
 591    end Wait_For_Completion;
 592
 593    --------------------------------------
 594    -- Wait_For_Completion_With_Timeout --
 595    --------------------------------------
 596
 597    procedure Wait_For_Completion_With_Timeout
 598      (Entry_Call  : Entry_Call_Link;
 599       Wakeup_Time : Duration;
 600       Mode        : Delay_Modes;
 601       Yielded     : out Boolean)
 602    is
 603       Self_Id  : constant Task_Id := Entry_Call.Self;
 604       Timedout : Boolean := False;
 605
 606       use type Ada.Exceptions.Exception_Id;
 607
 608    begin
 609       --  This procedure waits for the entry call to be served, with a timeout.
 610       --  It tries to cancel the call if the timeout expires before the call is
 611       --  served.
 612
 613       --  If we wake up from the timed sleep operation here, it may be for
 614       --  several possible reasons:
 615
 616       --  1) The entry call is done being served.
 617       --  2) There is an abort or priority change to be served.
 618       --  3) The timeout has expired (Timedout = True)
 619       --  4) There has been a spurious wakeup.
 620
 621       --  Once the timeout has expired we may need to continue to wait if the
 622       --  call is already being serviced. In that case, we want to go back to
 623       --  sleep, but without any timeout. The variable Timedout is used to
 624       --  control this. If the Timedout flag is set, we do not need to
 625       --  STPO.Sleep with a timeout. We just sleep until we get a wakeup for
 626       --  some status change.
 627
 628       --  The original call may have become abortable after waking up. We want
 629       --  to check Check_Pending_Actions_For_Entry_Call again in any case.
 630
 631       pragma Assert (Entry_Call.Mode = Timed_Call);
 632
 633       Yielded := False;
 634       Self_Id.Common.State := Entry_Caller_Sleep;
 635
 636       --  Looping is necessary in case the task wakes up early from the
 637       --  timed sleep, due to a "spurious wakeup". Spurious wakeups are
 638       --  a weakness of POSIX condition variables. A thread waiting for
 639       --  a condition variable is allowed to wake up at any time, not just
 640       --  when the condition is signaled. See the same loop in the
 641       --  ordinary Wait_For_Completion, above.
 642
 643       if Parameters.Runtime_Traces then
 644          Send_Trace_Info (WT_Completion, Wakeup_Time);
 645       end if;
 646
 647       loop
 648          Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
 649          exit when Entry_Call.State >= Done;
 650
 651          STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode,
 652            Entry_Caller_Sleep, Timedout, Yielded);
 653
 654          if Timedout then
 655             if Parameters.Runtime_Traces then
 656                Send_Trace_Info (E_Timeout);
 657             end if;
 658
 659             --  Try to cancel the call (see Try_To_Cancel_Entry_Call for
 660             --  corresponding code in the ATC case).
 661
 662             Entry_Call.Cancellation_Attempted := True;
 663
 664             if Self_Id.Pending_ATC_Level >= Entry_Call.Level then
 665                Self_Id.Pending_ATC_Level := Entry_Call.Level - 1;
 666             end if;
 667
 668             --  The following loop is the same as the loop and exit code
 669             --  from the ordinary Wait_For_Completion. If we get here, we
 670             --  have timed out but we need to keep waiting until the call
 671             --  has actually completed or been cancelled successfully.
 672
 673             loop
 674                Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
 675                exit when Entry_Call.State >= Done;
 676                STPO.Sleep (Self_Id, Entry_Caller_Sleep);
 677             end loop;
 678
 679             Self_Id.Common.State := Runnable;
 680             Utilities.Exit_One_ATC_Level (Self_Id);
 681
 682             return;
 683          end if;
 684       end loop;
 685
 686       --  This last part is the same as ordinary Wait_For_Completion,
 687       --  and is only executed if the call completed without timing out.
 688
 689       if Parameters.Runtime_Traces then
 690          Send_Trace_Info (M_Call_Complete);
 691       end if;
 692
 693       Self_Id.Common.State := Runnable;
 694       Utilities.Exit_One_ATC_Level (Self_Id);
 695    end Wait_For_Completion_With_Timeout;
 696
 697    --------------------------
 698    -- Wait_Until_Abortable --
 699    --------------------------
 700
 701    procedure Wait_Until_Abortable
 702      (Self_ID : Task_Id;
 703       Call    : Entry_Call_Link) is
 704    begin
 705       pragma Assert (Self_ID.ATC_Nesting_Level > 0);
 706       pragma Assert (Call.Mode = Asynchronous_Call);
 707
 708       if Parameters.Runtime_Traces then
 709          Send_Trace_Info (W_Completion);
 710       end if;
 711
 712       STPO.Write_Lock (Self_ID);
 713       Self_ID.Common.State := Entry_Caller_Sleep;
 714
 715       loop
 716          Check_Pending_Actions_For_Entry_Call (Self_ID, Call);
 717          exit when Call.State >= Was_Abortable;
 718          STPO.Sleep (Self_ID, Async_Select_Sleep);
 719       end loop;
 720
 721       Self_ID.Common.State := Runnable;
 722       STPO.Unlock (Self_ID);
 723
 724       if Parameters.Runtime_Traces then
 725          Send_Trace_Info (M_Call_Complete);
 726       end if;
 727    end Wait_Until_Abortable;
 728
 729 end System.Tasking.Entry_Calls;