gcc/ada/s-tpobop.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --
   4 --                                                                          --
   5 --     S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S .    --
   6 --                             O P E R A T I O N S                          --
   7 --                                                                          --
   8 --                                  B o d y                                 --
   9 --                                                                          --
  10 --         Copyright (C) 1998-2007, Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNARL was developed by the GNARL team at Florida State University.       --
  31 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This package contains all the extended primitives related to
  36 --  Protected_Objects with entries.
  37
  38 --  The handling of protected objects with no entries is done in
  39 --  System.Tasking.Protected_Objects, the simple routines for protected
  40 --  objects with entries in System.Tasking.Protected_Objects.Entries.
  41
  42 --  The split between Entries and Operations is needed to break circular
  43 --  dependencies inside the run time.
  44
  45 --  This package contains all primitives related to Protected_Objects.
  46 --  Note: the compiler generates direct calls to this interface, via Rtsfind.
  47
  48 with System.Task_Primitives.Operations;
  49 --  used for Initialize_Lock
  50 --           Write_Lock
  51 --           Unlock
  52 --           Get_Priority
  53 --           Wakeup
  54
  55 with System.Tasking.Entry_Calls;
  56 --  used for Wait_For_Completion
  57 --           Wait_Until_Abortable
  58 --           Wait_For_Completion_With_Timeout
  59
  60 with System.Tasking.Initialization;
  61 --  Used for Defer_Abort,
  62 --           Undefer_Abort,
  63 --           Change_Base_Priority
  64
  65 pragma Elaborate_All (System.Tasking.Initialization);
  66 --  This insures that tasking is initialized if any protected objects are
  67 --  created.
  68
  69 with System.Tasking.Queuing;
  70 --  used for Enqueue
  71 --           Broadcast_Program_Error
  72 --           Select_Protected_Entry_Call
  73 --           Onqueue
  74 --           Count_Waiting
  75
  76 with System.Tasking.Rendezvous;
  77 --  used for Task_Do_Or_Queue
  78
  79 with System.Tasking.Utilities;
  80 --  used for Exit_One_ATC_Level
  81
  82 with System.Tasking.Debug;
  83 --  used for Trace
  84
  85 with System.Parameters;
  86 --  used for Single_Lock
  87 --           Runtime_Traces
  88
  89 with System.Traces.Tasking;
  90 --  used for Send_Trace_Info
  91
  92 with System.Restrictions;
  93 --  used for Run_Time_Restrictions
  94
  95 package body System.Tasking.Protected_Objects.Operations is
  96
  97    package STPO renames System.Task_Primitives.Operations;
  98
  99    use Parameters;
 100    use Task_Primitives;
 101    use Ada.Exceptions;
 102    use Entries;
 103
 104    use System.Restrictions;
 105    use System.Restrictions.Rident;
 106    use System.Traces;
 107    use System.Traces.Tasking;
 108
 109    -----------------------
 110    -- Local Subprograms --
 111    -----------------------
 112
 113    procedure Update_For_Queue_To_PO
 114      (Entry_Call : Entry_Call_Link;
 115       With_Abort : Boolean);
 116    pragma Inline (Update_For_Queue_To_PO);
 117    --  Update the state of an existing entry call to reflect
 118    --  the fact that it is being enqueued, based on
 119    --  whether the current queuing action is with or without abort.
 120    --  Call this only while holding the PO's lock.
 121    --  It returns with the PO's lock still held.
 122
 123    procedure Requeue_Call
 124      (Self_Id    : Task_Id;
 125       Object     : Protection_Entries_Access;
 126       Entry_Call : Entry_Call_Link;
 127       With_Abort : Boolean);
 128    --  Handle requeue of Entry_Call.
 129    --  In particular, queue the call if needed, or service it immediately
 130    --  if possible.
 131
 132    ---------------------------------
 133    -- Cancel_Protected_Entry_Call --
 134    ---------------------------------
 135
 136    --  Compiler interface only.  Do not call from within the RTS.
 137    --  This should have analogous effect to Cancel_Task_Entry_Call,
 138    --  setting the value of Block.Cancelled instead of returning
 139    --  the parameter value Cancelled.
 140
 141    --  The effect should be idempotent, since the call may already
 142    --  have been dequeued.
 143
 144    --  source code:
 145
 146    --      select r.e;
 147    --         ...A...
 148    --      then abort
 149    --         ...B...
 150    --      end select;
 151
 152    --  expanded code:
 153
 154    --      declare
 155    --         X : protected_entry_index := 1;
 156    --         B80b : communication_block;
 157    --         communication_blockIP (B80b);
 158    --      begin
 159    --         begin
 160    --            A79b : label
 161    --            A79b : declare
 162    --               procedure _clean is
 163    --               begin
 164    --                  if enqueued (B80b) then
 165    --                     cancel_protected_entry_call (B80b);
 166    --                  end if;
 167    --                  return;
 168    --               end _clean;
 169    --            begin
 170    --               protected_entry_call (rTV!(r)._object'unchecked_access, X,
 171    --                 null_address, asynchronous_call, B80b, objectF => 0);
 172    --               if enqueued (B80b) then
 173    --                  ...B...
 174    --               end if;
 175    --            at end
 176    --               _clean;
 177    --            end A79b;
 178    --         exception
 179    --            when _abort_signal =>
 180    --               abort_undefer.all;
 181    --               null;
 182    --         end;
 183    --         if not cancelled (B80b) then
 184    --            x := ...A...
 185    --         end if;
 186    --      end;
 187
 188    --  If the entry call completes after we get into the abortable part,
 189    --  Abort_Signal should be raised and ATC will take us to the at-end
 190    --  handler, which will call _clean.
 191
 192    --  If the entry call returns with the call already completed,
 193    --  we can skip this, and use the "if enqueued()" to go past
 194    --  the at-end handler, but we will still call _clean.
 195
 196    --  If the abortable part completes before the entry call is Done,
 197    --  it will call _clean.
 198
 199    --  If the entry call or the abortable part raises an exception,
 200    --  we will still call _clean, but the value of Cancelled should not matter.
 201
 202    --  Whoever calls _clean first gets to decide whether the call
 203    --  has been "cancelled".
 204
 205    --  Enqueued should be true if there is any chance that the call
 206    --  is still on a queue. It seems to be safe to make it True if
 207    --  the call was Onqueue at some point before return from
 208    --  Protected_Entry_Call.
 209
 210    --  Cancelled should be true iff the abortable part completed
 211    --  and succeeded in cancelling the entry call before it completed.
 212
 213    --  ?????
 214    --  The need for Enqueued is less obvious.
 215    --  The "if enqueued ()" tests are not necessary, since both
 216    --  Cancel_Protected_Entry_Call and Protected_Entry_Call must
 217    --  do the same test internally, with locking. The one that
 218    --  makes cancellation conditional may be a useful heuristic
 219    --  since at least 1/2 the time the call should be off-queue
 220    --  by that point. The other one seems totally useless, since
 221    --  Protected_Entry_Call must do the same check and then
 222    --  possibly wait for the call to be abortable, internally.
 223
 224    --  We can check Call.State here without locking the caller's mutex,
 225    --  since the call must be over after returning from Wait_For_Completion.
 226    --  No other task can access the call record at this point.
 227
 228    procedure Cancel_Protected_Entry_Call
 229      (Block : in out Communication_Block) is
 230    begin
 231       Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled);
 232    end Cancel_Protected_Entry_Call;
 233
 234    ---------------
 235    -- Cancelled --
 236    ---------------
 237
 238    function Cancelled (Block : Communication_Block) return Boolean is
 239    begin
 240       return Block.Cancelled;
 241    end Cancelled;
 242
 243    -------------------------
 244    -- Complete_Entry_Body --
 245    -------------------------
 246
 247    procedure Complete_Entry_Body (Object : Protection_Entries_Access) is
 248    begin
 249       Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id);
 250    end Complete_Entry_Body;
 251
 252    --------------
 253    -- Enqueued --
 254    --------------
 255
 256    function Enqueued (Block : Communication_Block) return Boolean is
 257    begin
 258       return Block.Enqueued;
 259    end Enqueued;
 260
 261    -------------------------------------
 262    -- Exceptional_Complete_Entry_Body --
 263    -------------------------------------
 264
 265    procedure Exceptional_Complete_Entry_Body
 266      (Object : Protection_Entries_Access;
 267       Ex     : Ada.Exceptions.Exception_Id)
 268    is
 269       procedure Transfer_Occurrence
 270         (Target : Ada.Exceptions.Exception_Occurrence_Access;
 271          Source : Ada.Exceptions.Exception_Occurrence);
 272       pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
 273
 274       Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
 275       Self_Id    : Task_Id;
 276
 277    begin
 278       pragma Debug
 279        (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));
 280
 281       --  We must have abort deferred, since we are inside
 282       --  a protected operation.
 283
 284       if Entry_Call /= null then
 285          --  The call was not requeued.
 286
 287          Entry_Call.Exception_To_Raise := Ex;
 288
 289          if Ex /= Ada.Exceptions.Null_Id then
 290             --  An exception was raised and abort was deferred, so adjust
 291             --  before propagating, otherwise the task will stay with deferral
 292             --  enabled for its remaining life.
 293
 294             Self_Id := STPO.Self;
 295             Initialization.Undefer_Abort_Nestable (Self_Id);
 296             Transfer_Occurrence
 297               (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,
 298                Self_Id.Common.Compiler_Data.Current_Excep);
 299          end if;
 300
 301          --  Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
 302          --  PO_Service_Entries on return.
 303       end if;
 304
 305       if Runtime_Traces then
 306          Send_Trace_Info (PO_Done, Entry_Call.Self);
 307       end if;
 308    end Exceptional_Complete_Entry_Body;
 309
 310    --------------------
 311    -- PO_Do_Or_Queue --
 312    --------------------
 313
 314    procedure PO_Do_Or_Queue
 315      (Self_ID    : Task_Id;
 316       Object     : Protection_Entries_Access;
 317       Entry_Call : Entry_Call_Link;
 318       With_Abort : Boolean)
 319    is
 320       E             : constant Protected_Entry_Index :=
 321                         Protected_Entry_Index (Entry_Call.E);
 322       Barrier_Value : Boolean;
 323
 324    begin
 325       --  When the Action procedure for an entry body returns, it is either
 326       --  completed (having called [Exceptional_]Complete_Entry_Body) or it
 327       --  is queued, having executed a requeue statement.
 328
 329       Barrier_Value :=
 330         Object.Entry_Bodies (
 331           Object.Find_Body_Index (Object.Compiler_Info, E)).
 332             Barrier (Object.Compiler_Info, E);
 333
 334       if Barrier_Value then
 335
 336          --  Not abortable while service is in progress.
 337
 338          if Entry_Call.State = Now_Abortable then
 339             Entry_Call.State := Was_Abortable;
 340          end if;
 341
 342          Object.Call_In_Progress := Entry_Call;
 343
 344          pragma Debug
 345           (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));
 346          Object.Entry_Bodies (
 347            Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
 348              Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
 349
 350          if Object.Call_In_Progress /= null then
 351
 352             --  Body of current entry served call to completion
 353
 354             Object.Call_In_Progress := null;
 355
 356             if Single_Lock then
 357                STPO.Lock_RTS;
 358             end if;
 359
 360             STPO.Write_Lock (Entry_Call.Self);
 361             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 362             STPO.Unlock (Entry_Call.Self);
 363
 364             if Single_Lock then
 365                STPO.Unlock_RTS;
 366             end if;
 367
 368          else
 369             Requeue_Call (Self_ID, Object, Entry_Call, With_Abort);
 370          end if;
 371
 372       elsif Entry_Call.Mode /= Conditional_Call
 373         or else not With_Abort
 374       then
 375
 376          if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
 377               and then
 378             Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
 379               Queuing.Count_Waiting (Object.Entry_Queues (E))
 380          then
 381             --  This violates the Max_Entry_Queue_Length restriction,
 382             --  raise Program_Error.
 383
 384             Entry_Call.Exception_To_Raise := Program_Error'Identity;
 385
 386             if Single_Lock then
 387                STPO.Lock_RTS;
 388             end if;
 389
 390             STPO.Write_Lock (Entry_Call.Self);
 391             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 392             STPO.Unlock (Entry_Call.Self);
 393
 394             if Single_Lock then
 395                STPO.Unlock_RTS;
 396             end if;
 397          else
 398             Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
 399             Update_For_Queue_To_PO (Entry_Call, With_Abort);
 400          end if;
 401       else
 402          --  Conditional_Call and With_Abort
 403
 404          if Single_Lock then
 405             STPO.Lock_RTS;
 406          end if;
 407
 408          STPO.Write_Lock (Entry_Call.Self);
 409          pragma Assert (Entry_Call.State >= Was_Abortable);
 410          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
 411          STPO.Unlock (Entry_Call.Self);
 412
 413          if Single_Lock then
 414             STPO.Unlock_RTS;
 415          end if;
 416       end if;
 417
 418    exception
 419       when others =>
 420          Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);
 421    end PO_Do_Or_Queue;
 422
 423    ------------------------
 424    -- PO_Service_Entries --
 425    ------------------------
 426
 427    procedure PO_Service_Entries
 428      (Self_ID       : Task_Id;
 429       Object        : Entries.Protection_Entries_Access;
 430       Unlock_Object : Boolean := True)
 431    is
 432       E          : Protected_Entry_Index;
 433       Caller     : Task_Id;
 434       Entry_Call : Entry_Call_Link;
 435
 436    begin
 437       loop
 438          Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);
 439
 440          exit when Entry_Call = null;
 441
 442          E := Protected_Entry_Index (Entry_Call.E);
 443
 444          --  Not abortable while service is in progress.
 445
 446          if Entry_Call.State = Now_Abortable then
 447             Entry_Call.State := Was_Abortable;
 448          end if;
 449
 450          Object.Call_In_Progress := Entry_Call;
 451
 452          begin
 453             if Runtime_Traces then
 454                Send_Trace_Info (PO_Run, Self_ID,
 455                                 Entry_Call.Self, Entry_Index (E));
 456             end if;
 457
 458             pragma Debug
 459              (Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
 460             Object.Entry_Bodies (
 461               Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
 462                 Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
 463          exception
 464             when others =>
 465                Queuing.Broadcast_Program_Error
 466                  (Self_ID, Object, Entry_Call);
 467          end;
 468
 469          if Object.Call_In_Progress = null then
 470             Requeue_Call
 471               (Self_ID, Object, Entry_Call, Entry_Call.Requeue_With_Abort);
 472             exit when Entry_Call.State = Cancelled;
 473
 474          else
 475             Object.Call_In_Progress := null;
 476             Caller := Entry_Call.Self;
 477
 478             if Single_Lock then
 479                STPO.Lock_RTS;
 480             end if;
 481
 482             STPO.Write_Lock (Caller);
 483             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 484             STPO.Unlock (Caller);
 485
 486             if Single_Lock then
 487                STPO.Unlock_RTS;
 488             end if;
 489          end if;
 490       end loop;
 491
 492       if Unlock_Object then
 493          Unlock_Entries (Object);
 494       end if;
 495    end PO_Service_Entries;
 496
 497    ---------------------
 498    -- Protected_Count --
 499    ---------------------
 500
 501    function Protected_Count
 502      (Object : Protection_Entries'Class;
 503       E      : Protected_Entry_Index)
 504       return   Natural
 505    is
 506    begin
 507       return Queuing.Count_Waiting (Object.Entry_Queues (E));
 508    end Protected_Count;
 509
 510    --------------------------
 511    -- Protected_Entry_Call --
 512    --------------------------
 513
 514    --  Compiler interface only.  Do not call from within the RTS.
 515
 516    --  select r.e;
 517    --     ...A...
 518    --  else
 519    --     ...B...
 520    --  end select;
 521
 522    --  declare
 523    --     X : protected_entry_index := 1;
 524    --     B85b : communication_block;
 525    --     communication_blockIP (B85b);
 526    --  begin
 527    --     protected_entry_call (rTV!(r)._object'unchecked_access, X,
 528    --       null_address, conditional_call, B85b, objectF => 0);
 529    --     if cancelled (B85b) then
 530    --        ...B...
 531    --     else
 532    --        ...A...
 533    --     end if;
 534    --  end;
 535
 536    --  See also Cancel_Protected_Entry_Call for code expansion of asynchronous
 537    --  entry call.
 538
 539    --  The initial part of this procedure does not need to lock the the calling
 540    --  task's ATCB, up to the point where the call record first may be queued
 541    --  (PO_Do_Or_Queue), since before that no other task will have access to
 542    --  the record.
 543
 544    --  If this is a call made inside of an abort deferred region, the call
 545    --  should be never abortable.
 546
 547    --  If the call was not queued abortably, we need to wait until it is before
 548    --  proceeding with the abortable part.
 549
 550    --  There are some heuristics here, just to save time for frequently
 551    --  occurring cases. For example, we check Initially_Abortable to try to
 552    --  avoid calling the procedure Wait_Until_Abortable, since the normal case
 553    --  for async.  entry calls is to be queued abortably.
 554
 555    --  Another heuristic uses the Block.Enqueued to try to avoid calling
 556    --  Cancel_Protected_Entry_Call if the call can be served immediately.
 557
 558    procedure Protected_Entry_Call
 559      (Object              : Protection_Entries_Access;
 560       E                   : Protected_Entry_Index;
 561       Uninterpreted_Data  : System.Address;
 562       Mode                : Call_Modes;
 563       Block               : out Communication_Block)
 564    is
 565       Self_ID             : constant Task_Id := STPO.Self;
 566       Entry_Call          : Entry_Call_Link;
 567       Initially_Abortable : Boolean;
 568       Ceiling_Violation   : Boolean;
 569
 570    begin
 571       pragma Debug
 572         (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));
 573
 574       if Runtime_Traces then
 575          Send_Trace_Info (PO_Call, Entry_Index (E));
 576       end if;
 577
 578       if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
 579          Raise_Exception
 580            (Storage_Error'Identity, "not enough ATC nesting levels");
 581       end if;
 582
 583       --  If pragma Detect_Blocking is active then Program_Error must be
 584       --  raised if this potentially blocking operation is called from a
 585       --  protected action.
 586
 587       if Detect_Blocking
 588         and then Self_ID.Common.Protected_Action_Nesting > 0
 589       then
 590          Ada.Exceptions.Raise_Exception
 591            (Program_Error'Identity, "potentially blocking operation");
 592       end if;
 593
 594       --  Self_ID.Deferral_Level should be 0, except when called from Finalize,
 595       --  where abort is already deferred.
 596
 597       Initialization.Defer_Abort_Nestable (Self_ID);
 598       Lock_Entries (Object, Ceiling_Violation);
 599
 600       if Ceiling_Violation then
 601
 602          --  Failed ceiling check
 603
 604          Initialization.Undefer_Abort_Nestable (Self_ID);
 605          raise Program_Error;
 606       end if;
 607
 608       Block.Self := Self_ID;
 609       Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;
 610       pragma Debug
 611         (Debug.Trace (Self_ID, "PEC: entered ATC level: " &
 612          ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
 613       Entry_Call :=
 614          Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
 615       Entry_Call.Next := null;
 616       Entry_Call.Mode := Mode;
 617       Entry_Call.Cancellation_Attempted := False;
 618
 619       if Self_ID.Deferral_Level > 1 then
 620          Entry_Call.State := Never_Abortable;
 621       else
 622          Entry_Call.State := Now_Abortable;
 623       end if;
 624
 625       Entry_Call.E := Entry_Index (E);
 626       Entry_Call.Prio := STPO.Get_Priority (Self_ID);
 627       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
 628       Entry_Call.Called_PO := To_Address (Object);
 629       Entry_Call.Called_Task := null;
 630       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
 631
 632       PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True);
 633       Initially_Abortable := Entry_Call.State = Now_Abortable;
 634       PO_Service_Entries (Self_ID, Object);
 635
 636       --  Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
 637       --  for completed or cancelled calls.  (This is a heuristic, only.)
 638
 639       if Entry_Call.State >= Done then
 640
 641          --  Once State >= Done it will not change any more.
 642
 643          if Single_Lock then
 644             STPO.Lock_RTS;
 645          end if;
 646
 647          STPO.Write_Lock (Self_ID);
 648          Utilities.Exit_One_ATC_Level (Self_ID);
 649          STPO.Unlock (Self_ID);
 650
 651          if Single_Lock then
 652             STPO.Unlock_RTS;
 653          end if;
 654
 655          Block.Enqueued := False;
 656          Block.Cancelled := Entry_Call.State = Cancelled;
 657          Initialization.Undefer_Abort_Nestable (Self_ID);
 658          Entry_Calls.Check_Exception (Self_ID, Entry_Call);
 659          return;
 660
 661       else
 662          --  In this case we cannot conclude anything,
 663          --  since State can change concurrently.
 664          null;
 665       end if;
 666
 667       --  Now for the general case.
 668
 669       if Mode = Asynchronous_Call then
 670
 671          --  Try to avoid an expensive call.
 672
 673          if not Initially_Abortable then
 674             if Single_Lock then
 675                STPO.Lock_RTS;
 676                Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
 677                STPO.Unlock_RTS;
 678             else
 679                Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
 680             end if;
 681          end if;
 682
 683       elsif Mode < Asynchronous_Call then
 684
 685          --  Simple_Call or Conditional_Call
 686
 687          if Single_Lock then
 688             STPO.Lock_RTS;
 689             Entry_Calls.Wait_For_Completion (Entry_Call);
 690             STPO.Unlock_RTS;
 691          else
 692             STPO.Write_Lock (Self_ID);
 693             Entry_Calls.Wait_For_Completion (Entry_Call);
 694             STPO.Unlock (Self_ID);
 695          end if;
 696
 697          Block.Cancelled := Entry_Call.State = Cancelled;
 698
 699       else
 700          pragma Assert (False);
 701          null;
 702       end if;
 703
 704       Initialization.Undefer_Abort_Nestable (Self_ID);
 705       Entry_Calls.Check_Exception (Self_ID, Entry_Call);
 706    end Protected_Entry_Call;
 707
 708    ------------------
 709    -- Requeue_Call --
 710    ------------------
 711
 712    procedure Requeue_Call
 713      (Self_Id    : Task_Id;
 714       Object     : Protection_Entries_Access;
 715       Entry_Call : Entry_Call_Link;
 716       With_Abort : Boolean)
 717    is
 718       New_Object        : Protection_Entries_Access;
 719       Ceiling_Violation : Boolean;
 720       Result            : Boolean;
 721       E                 : Protected_Entry_Index;
 722
 723    begin
 724       New_Object := To_Protection (Entry_Call.Called_PO);
 725
 726       if New_Object = null then
 727
 728          --  Call is to be requeued to a task entry
 729
 730          if Single_Lock then
 731             STPO.Lock_RTS;
 732          end if;
 733
 734          Result := Rendezvous.Task_Do_Or_Queue
 735            (Self_Id, Entry_Call,
 736             With_Abort => Entry_Call.Requeue_With_Abort);
 737
 738          if not Result then
 739             Queuing.Broadcast_Program_Error
 740               (Self_Id, Object, Entry_Call, RTS_Locked => True);
 741          end if;
 742
 743          if Single_Lock then
 744             STPO.Unlock_RTS;
 745          end if;
 746
 747       else
 748          --  Call should be requeued to a PO
 749
 750          if Object /= New_Object then
 751
 752             --  Requeue is to different PO
 753
 754             Lock_Entries (New_Object, Ceiling_Violation);
 755
 756             if Ceiling_Violation then
 757                Object.Call_In_Progress := null;
 758                Queuing.Broadcast_Program_Error
 759                  (Self_Id, Object, Entry_Call);
 760
 761             else
 762                PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call, With_Abort);
 763                PO_Service_Entries (Self_Id, New_Object);
 764             end if;
 765
 766          else
 767             --  Requeue is to same protected object
 768
 769             --  ??? Try to compensate apparent failure of the
 770             --  scheduler on some OS (e.g VxWorks) to give higher
 771             --  priority tasks a chance to run (see CXD6002).
 772
 773             STPO.Yield (False);
 774
 775             if Entry_Call.Requeue_With_Abort
 776               and then Entry_Call.Cancellation_Attempted
 777             then
 778                --  If this is a requeue with abort and someone tried
 779                --  to cancel this call, cancel it at this point.
 780
 781                Entry_Call.State := Cancelled;
 782                return;
 783             end if;
 784
 785             if not With_Abort
 786               or else Entry_Call.Mode /= Conditional_Call
 787             then
 788                E := Protected_Entry_Index (Entry_Call.E);
 789
 790                if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
 791                     and then
 792                   Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
 793                     Queuing.Count_Waiting (Object.Entry_Queues (E))
 794                then
 795                   --  This violates the Max_Entry_Queue_Length restriction,
 796                   --  raise Program_Error.
 797
 798                   Entry_Call.Exception_To_Raise := Program_Error'Identity;
 799
 800                   if Single_Lock then
 801                      STPO.Lock_RTS;
 802                   end if;
 803
 804                   STPO.Write_Lock (Entry_Call.Self);
 805                   Initialization.Wakeup_Entry_Caller
 806                     (Self_Id, Entry_Call, Done);
 807                   STPO.Unlock (Entry_Call.Self);
 808
 809                   if Single_Lock then
 810                      STPO.Unlock_RTS;
 811                   end if;
 812                else
 813                   Queuing.Enqueue
 814                     (New_Object.Entry_Queues (E), Entry_Call);
 815                   Update_For_Queue_To_PO (Entry_Call, With_Abort);
 816                end if;
 817
 818             else
 819                PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call, With_Abort);
 820             end if;
 821          end if;
 822       end if;
 823    end Requeue_Call;
 824
 825    ----------------------------
 826    -- Protected_Entry_Caller --
 827    ----------------------------
 828
 829    function Protected_Entry_Caller
 830      (Object : Protection_Entries'Class) return Task_Id is
 831    begin
 832       return Object.Call_In_Progress.Self;
 833    end Protected_Entry_Caller;
 834
 835    -----------------------------
 836    -- Requeue_Protected_Entry --
 837    -----------------------------
 838
 839    --  Compiler interface only.  Do not call from within the RTS.
 840
 841    --  entry e when b is
 842    --  begin
 843    --     b := false;
 844    --     ...A...
 845    --     requeue e2;
 846    --  end e;
 847
 848    --  procedure rPT__E10b (O : address; P : address; E :
 849    --    protected_entry_index) is
 850    --     type rTVP is access rTV;
 851    --     freeze rTVP []
 852    --     _object : rTVP := rTVP!(O);
 853    --  begin
 854    --     declare
 855    --        rR : protection renames _object._object;
 856    --        vP : integer renames _object.v;
 857    --        bP : boolean renames _object.b;
 858    --     begin
 859    --        b := false;
 860    --        ...A...
 861    --        requeue_protected_entry (rR'unchecked_access, rR'
 862    --          unchecked_access, 2, false, objectF => 0, new_objectF =>
 863    --          0);
 864    --        return;
 865    --     end;
 866    --     complete_entry_body (_object._object'unchecked_access, objectF =>
 867    --       0);
 868    --     return;
 869    --  exception
 870    --     when others =>
 871    --        abort_undefer.all;
 872    --        exceptional_complete_entry_body (_object._object'
 873    --          unchecked_access, current_exception, objectF => 0);
 874    --        return;
 875    --  end rPT__E10b;
 876
 877    procedure Requeue_Protected_Entry
 878      (Object     : Protection_Entries_Access;
 879       New_Object : Protection_Entries_Access;
 880       E          : Protected_Entry_Index;
 881       With_Abort : Boolean)
 882    is
 883       Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
 884
 885    begin
 886       pragma Debug
 887         (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P'));
 888       pragma Assert (STPO.Self.Deferral_Level > 0);
 889
 890       Entry_Call.E := Entry_Index (E);
 891       Entry_Call.Called_PO := To_Address (New_Object);
 892       Entry_Call.Called_Task := null;
 893       Entry_Call.Requeue_With_Abort := With_Abort;
 894       Object.Call_In_Progress := null;
 895    end Requeue_Protected_Entry;
 896
 897    -------------------------------------
 898    -- Requeue_Task_To_Protected_Entry --
 899    -------------------------------------
 900
 901    --  Compiler interface only.
 902
 903    --    accept e1 do
 904    --      ...A...
 905    --      requeue r.e2;
 906    --    end e1;
 907
 908    --    A79b : address;
 909    --    L78b : label
 910    --    begin
 911    --       accept_call (1, A79b);
 912    --       ...A...
 913    --       requeue_task_to_protected_entry (rTV!(r)._object'
 914    --         unchecked_access, 2, false, new_objectF => 0);
 915    --       goto L78b;
 916    --       <<L78b>>
 917    --       complete_rendezvous;
 918    --    exception
 919    --       when all others =>
 920    --          exceptional_complete_rendezvous (get_gnat_exception);
 921    --    end;
 922
 923    procedure Requeue_Task_To_Protected_Entry
 924      (New_Object : Protection_Entries_Access;
 925       E          : Protected_Entry_Index;
 926       With_Abort : Boolean)
 927    is
 928       Self_ID    : constant Task_Id := STPO.Self;
 929       Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call;
 930
 931    begin
 932       Initialization.Defer_Abort (Self_ID);
 933
 934       --  We do not need to lock Self_ID here since the call is not abortable
 935       --  at this point, and therefore, the caller cannot cancel the call.
 936
 937       Entry_Call.Needs_Requeue := True;
 938       Entry_Call.Requeue_With_Abort := With_Abort;
 939       Entry_Call.Called_PO := To_Address (New_Object);
 940       Entry_Call.Called_Task := null;
 941       Entry_Call.E := Entry_Index (E);
 942       Initialization.Undefer_Abort (Self_ID);
 943    end Requeue_Task_To_Protected_Entry;
 944
 945    ---------------------
 946    -- Service_Entries --
 947    ---------------------
 948
 949    procedure Service_Entries (Object : Protection_Entries_Access) is
 950       Self_ID : constant Task_Id := STPO.Self;
 951    begin
 952       PO_Service_Entries (Self_ID, Object);
 953    end Service_Entries;
 954
 955    --------------------------------
 956    -- Timed_Protected_Entry_Call --
 957    --------------------------------
 958
 959    --  Compiler interface only.  Do not call from within the RTS.
 960
 961    procedure Timed_Protected_Entry_Call
 962      (Object                : Protection_Entries_Access;
 963       E                     : Protected_Entry_Index;
 964       Uninterpreted_Data    : System.Address;
 965       Timeout               : Duration;
 966       Mode                  : Delay_Modes;
 967       Entry_Call_Successful : out Boolean)
 968    is
 969       Self_Id           : constant Task_Id  := STPO.Self;
 970       Entry_Call        : Entry_Call_Link;
 971       Ceiling_Violation : Boolean;
 972       Yielded           : Boolean;
 973
 974    begin
 975       if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
 976          Raise_Exception (Storage_Error'Identity,
 977            "not enough ATC nesting levels");
 978       end if;
 979
 980       --  If pragma Detect_Blocking is active then Program_Error must be
 981       --  raised if this potentially blocking operation is called from a
 982       --  protected action.
 983
 984       if Detect_Blocking
 985         and then Self_Id.Common.Protected_Action_Nesting > 0
 986       then
 987          Ada.Exceptions.Raise_Exception
 988            (Program_Error'Identity, "potentially blocking operation");
 989       end if;
 990
 991       if Runtime_Traces then
 992          Send_Trace_Info (POT_Call, Entry_Index (E), Timeout);
 993       end if;
 994
 995       Initialization.Defer_Abort (Self_Id);
 996       Lock_Entries (Object, Ceiling_Violation);
 997
 998       if Ceiling_Violation then
 999          Initialization.Undefer_Abort (Self_Id);
1000          raise Program_Error;
1001       end if;
1002
1003       Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
1004       pragma Debug
1005         (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
1006          ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
1007       Entry_Call :=
1008         Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
1009       Entry_Call.Next := null;
1010       Entry_Call.Mode := Timed_Call;
1011       Entry_Call.Cancellation_Attempted := False;
1012
1013       if Self_Id.Deferral_Level > 1 then
1014          Entry_Call.State := Never_Abortable;
1015       else
1016          Entry_Call.State := Now_Abortable;
1017       end if;
1018
1019       Entry_Call.E := Entry_Index (E);
1020       Entry_Call.Prio := STPO.Get_Priority (Self_Id);
1021       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1022       Entry_Call.Called_PO := To_Address (Object);
1023       Entry_Call.Called_Task := null;
1024       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1025
1026       PO_Do_Or_Queue (Self_Id, Object, Entry_Call, With_Abort => True);
1027       PO_Service_Entries (Self_Id, Object);
1028
1029       if Single_Lock then
1030          STPO.Lock_RTS;
1031       else
1032          STPO.Write_Lock (Self_Id);
1033       end if;
1034
1035       --  Try to avoid waiting for completed or cancelled calls.
1036
1037       if Entry_Call.State >= Done then
1038          Utilities.Exit_One_ATC_Level (Self_Id);
1039
1040          if Single_Lock then
1041             STPO.Unlock_RTS;
1042          else
1043             STPO.Unlock (Self_Id);
1044          end if;
1045
1046          Entry_Call_Successful := Entry_Call.State = Done;
1047          Initialization.Undefer_Abort (Self_Id);
1048          Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1049          return;
1050       end if;
1051
1052       Entry_Calls.Wait_For_Completion_With_Timeout
1053         (Entry_Call, Timeout, Mode, Yielded);
1054
1055       if Single_Lock then
1056          STPO.Unlock_RTS;
1057       else
1058          STPO.Unlock (Self_Id);
1059       end if;
1060
1061       --  ??? Do we need to yield in case Yielded is False
1062
1063       Initialization.Undefer_Abort (Self_Id);
1064       Entry_Call_Successful := Entry_Call.State = Done;
1065       Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1066    end Timed_Protected_Entry_Call;
1067
1068    ----------------------------
1069    -- Update_For_Queue_To_PO --
1070    ----------------------------
1071
1072    --  Update the state of an existing entry call, based on
1073    --  whether the current queuing action is with or without abort.
1074    --  Call this only while holding the server's lock.
1075    --  It returns with the server's lock released.
1076
1077    New_State : constant array (Boolean, Entry_Call_State)
1078      of Entry_Call_State :=
1079        (True =>
1080          (Never_Abortable   => Never_Abortable,
1081           Not_Yet_Abortable => Now_Abortable,
1082           Was_Abortable     => Now_Abortable,
1083           Now_Abortable     => Now_Abortable,
1084           Done              => Done,
1085           Cancelled         => Cancelled),
1086         False =>
1087          (Never_Abortable   => Never_Abortable,
1088           Not_Yet_Abortable => Not_Yet_Abortable,
1089           Was_Abortable     => Was_Abortable,
1090           Now_Abortable     => Now_Abortable,
1091           Done              => Done,
1092           Cancelled         => Cancelled)
1093        );
1094
1095    procedure Update_For_Queue_To_PO
1096      (Entry_Call : Entry_Call_Link;
1097       With_Abort : Boolean)
1098    is
1099       Old : constant Entry_Call_State := Entry_Call.State;
1100
1101    begin
1102       pragma Assert (Old < Done);
1103
1104       Entry_Call.State := New_State (With_Abort, Entry_Call.State);
1105
1106       if Entry_Call.Mode = Asynchronous_Call then
1107          if Old < Was_Abortable and then
1108            Entry_Call.State = Now_Abortable
1109          then
1110             if Single_Lock then
1111                STPO.Lock_RTS;
1112             end if;
1113
1114             STPO.Write_Lock (Entry_Call.Self);
1115
1116             if Entry_Call.Self.Common.State = Async_Select_Sleep then
1117                STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1118             end if;
1119
1120             STPO.Unlock (Entry_Call.Self);
1121
1122             if Single_Lock then
1123                STPO.Unlock_RTS;
1124             end if;
1125
1126          end if;
1127
1128       elsif Entry_Call.Mode = Conditional_Call then
1129          pragma Assert (Entry_Call.State < Was_Abortable);
1130          null;
1131       end if;
1132    end Update_For_Queue_To_PO;
1133
1134 end System.Tasking.Protected_Objects.Operations;