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