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-2006, 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    begin
 276       pragma Debug
 277        (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));
 278
 279       --  We must have abort deferred, since we are inside
 280       --  a protected operation.
 281
 282       if Entry_Call /= null then
 283          --  The call was not requeued.
 284
 285          Entry_Call.Exception_To_Raise := Ex;
 286
 287          if Ex /= Ada.Exceptions.Null_Id then
 288             Transfer_Occurrence
 289               (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,
 290                STPO.Self.Common.Compiler_Data.Current_Excep);
 291          end if;
 292
 293          --  Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
 294          --  PO_Service_Entries on return.
 295       end if;
 296
 297       if Runtime_Traces then
 298          Send_Trace_Info (PO_Done, Entry_Call.Self);
 299       end if;
 300    end Exceptional_Complete_Entry_Body;
 301
 302    --------------------
 303    -- PO_Do_Or_Queue --
 304    --------------------
 305
 306    procedure PO_Do_Or_Queue
 307      (Self_ID    : Task_Id;
 308       Object     : Protection_Entries_Access;
 309       Entry_Call : Entry_Call_Link;
 310       With_Abort : Boolean)
 311    is
 312       E             : constant Protected_Entry_Index :=
 313                         Protected_Entry_Index (Entry_Call.E);
 314       Barrier_Value : Boolean;
 315
 316    begin
 317       --  When the Action procedure for an entry body returns, it is either
 318       --  completed (having called [Exceptional_]Complete_Entry_Body) or it
 319       --  is queued, having executed a requeue statement.
 320
 321       Barrier_Value :=
 322         Object.Entry_Bodies (
 323           Object.Find_Body_Index (Object.Compiler_Info, E)).
 324             Barrier (Object.Compiler_Info, E);
 325
 326       if Barrier_Value then
 327
 328          --  Not abortable while service is in progress.
 329
 330          if Entry_Call.State = Now_Abortable then
 331             Entry_Call.State := Was_Abortable;
 332          end if;
 333
 334          Object.Call_In_Progress := Entry_Call;
 335
 336          pragma Debug
 337           (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));
 338          Object.Entry_Bodies (
 339            Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
 340              Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
 341
 342          if Object.Call_In_Progress /= null then
 343
 344             --  Body of current entry served call to completion
 345
 346             Object.Call_In_Progress := null;
 347
 348             if Single_Lock then
 349                STPO.Lock_RTS;
 350             end if;
 351
 352             STPO.Write_Lock (Entry_Call.Self);
 353             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 354             STPO.Unlock (Entry_Call.Self);
 355
 356             if Single_Lock then
 357                STPO.Unlock_RTS;
 358             end if;
 359
 360          else
 361             Requeue_Call (Self_ID, Object, Entry_Call, With_Abort);
 362          end if;
 363
 364       elsif Entry_Call.Mode /= Conditional_Call
 365         or else not With_Abort
 366       then
 367
 368          if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
 369               and then
 370             Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
 371               Queuing.Count_Waiting (Object.Entry_Queues (E))
 372          then
 373             --  This violates the Max_Entry_Queue_Length restriction,
 374             --  raise Program_Error.
 375
 376             Entry_Call.Exception_To_Raise := Program_Error'Identity;
 377
 378             if Single_Lock then
 379                STPO.Lock_RTS;
 380             end if;
 381
 382             STPO.Write_Lock (Entry_Call.Self);
 383             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 384             STPO.Unlock (Entry_Call.Self);
 385
 386             if Single_Lock then
 387                STPO.Unlock_RTS;
 388             end if;
 389          else
 390             Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
 391             Update_For_Queue_To_PO (Entry_Call, With_Abort);
 392          end if;
 393       else
 394          --  Conditional_Call and With_Abort
 395
 396          if Single_Lock then
 397             STPO.Lock_RTS;
 398          end if;
 399
 400          STPO.Write_Lock (Entry_Call.Self);
 401          pragma Assert (Entry_Call.State >= Was_Abortable);
 402          Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
 403          STPO.Unlock (Entry_Call.Self);
 404
 405          if Single_Lock then
 406             STPO.Unlock_RTS;
 407          end if;
 408       end if;
 409
 410    exception
 411       when others =>
 412          Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);
 413    end PO_Do_Or_Queue;
 414
 415    ------------------------
 416    -- PO_Service_Entries --
 417    ------------------------
 418
 419    procedure PO_Service_Entries
 420      (Self_ID       : Task_Id;
 421       Object        : Entries.Protection_Entries_Access;
 422       Unlock_Object : Boolean := True)
 423    is
 424       E          : Protected_Entry_Index;
 425       Caller     : Task_Id;
 426       Entry_Call : Entry_Call_Link;
 427
 428    begin
 429       loop
 430          Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);
 431
 432          exit when Entry_Call = null;
 433
 434          E := Protected_Entry_Index (Entry_Call.E);
 435
 436          --  Not abortable while service is in progress.
 437
 438          if Entry_Call.State = Now_Abortable then
 439             Entry_Call.State := Was_Abortable;
 440          end if;
 441
 442          Object.Call_In_Progress := Entry_Call;
 443
 444          begin
 445             if Runtime_Traces then
 446                Send_Trace_Info (PO_Run, Self_ID,
 447                                 Entry_Call.Self, Entry_Index (E));
 448             end if;
 449
 450             pragma Debug
 451              (Debug.Trace (Self_ID, "POSE: start entry body", 'P'));
 452             Object.Entry_Bodies (
 453               Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
 454                 Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
 455          exception
 456             when others =>
 457                Queuing.Broadcast_Program_Error
 458                  (Self_ID, Object, Entry_Call);
 459          end;
 460
 461          if Object.Call_In_Progress = null then
 462             Requeue_Call
 463               (Self_ID, Object, Entry_Call, Entry_Call.Requeue_With_Abort);
 464             exit when Entry_Call.State = Cancelled;
 465
 466          else
 467             Object.Call_In_Progress := null;
 468             Caller := Entry_Call.Self;
 469
 470             if Single_Lock then
 471                STPO.Lock_RTS;
 472             end if;
 473
 474             STPO.Write_Lock (Caller);
 475             Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
 476             STPO.Unlock (Caller);
 477
 478             if Single_Lock then
 479                STPO.Unlock_RTS;
 480             end if;
 481          end if;
 482       end loop;
 483
 484       if Unlock_Object then
 485          Unlock_Entries (Object);
 486       end if;
 487    end PO_Service_Entries;
 488
 489    ---------------------
 490    -- Protected_Count --
 491    ---------------------
 492
 493    function Protected_Count
 494      (Object : Protection_Entries'Class;
 495       E      : Protected_Entry_Index)
 496       return   Natural
 497    is
 498    begin
 499       return Queuing.Count_Waiting (Object.Entry_Queues (E));
 500    end Protected_Count;
 501
 502    --------------------------
 503    -- Protected_Entry_Call --
 504    --------------------------
 505
 506    --  Compiler interface only.  Do not call from within the RTS.
 507
 508    --  select r.e;
 509    --     ...A...
 510    --  else
 511    --     ...B...
 512    --  end select;
 513
 514    --  declare
 515    --     X : protected_entry_index := 1;
 516    --     B85b : communication_block;
 517    --     communication_blockIP (B85b);
 518    --  begin
 519    --     protected_entry_call (rTV!(r)._object'unchecked_access, X,
 520    --       null_address, conditional_call, B85b, objectF => 0);
 521    --     if cancelled (B85b) then
 522    --        ...B...
 523    --     else
 524    --        ...A...
 525    --     end if;
 526    --  end;
 527
 528    --  See also Cancel_Protected_Entry_Call for code expansion of asynchronous
 529    --  entry call.
 530
 531    --  The initial part of this procedure does not need to lock the the calling
 532    --  task's ATCB, up to the point where the call record first may be queued
 533    --  (PO_Do_Or_Queue), since before that no other task will have access to
 534    --  the record.
 535
 536    --  If this is a call made inside of an abort deferred region, the call
 537    --  should be never abortable.
 538
 539    --  If the call was not queued abortably, we need to wait until it is before
 540    --  proceeding with the abortable part.
 541
 542    --  There are some heuristics here, just to save time for frequently
 543    --  occurring cases. For example, we check Initially_Abortable to try to
 544    --  avoid calling the procedure Wait_Until_Abortable, since the normal case
 545    --  for async.  entry calls is to be queued abortably.
 546
 547    --  Another heuristic uses the Block.Enqueued to try to avoid calling
 548    --  Cancel_Protected_Entry_Call if the call can be served immediately.
 549
 550    procedure Protected_Entry_Call
 551      (Object              : Protection_Entries_Access;
 552       E                   : Protected_Entry_Index;
 553       Uninterpreted_Data  : System.Address;
 554       Mode                : Call_Modes;
 555       Block               : out Communication_Block)
 556    is
 557       Self_ID             : constant Task_Id  := STPO.Self;
 558       Entry_Call          : Entry_Call_Link;
 559       Initially_Abortable : Boolean;
 560       Ceiling_Violation   : Boolean;
 561
 562    begin
 563       pragma Debug
 564         (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));
 565
 566       if Runtime_Traces then
 567          Send_Trace_Info (PO_Call, Entry_Index (E));
 568       end if;
 569
 570       if Self_ID.ATC_Nesting_Level = ATC_Level'Last then
 571          Raise_Exception
 572            (Storage_Error'Identity, "not enough ATC nesting levels");
 573       end if;
 574
 575       --  If pragma Detect_Blocking is active then Program_Error must be
 576       --  raised if this potentially blocking operation is called from a
 577       --  protected action.
 578
 579       if Detect_Blocking
 580         and then Self_ID.Common.Protected_Action_Nesting > 0
 581       then
 582          Ada.Exceptions.Raise_Exception
 583            (Program_Error'Identity, "potentially blocking operation");
 584       end if;
 585
 586       Initialization.Defer_Abort (Self_ID);
 587       Lock_Entries (Object, Ceiling_Violation);
 588
 589       if Ceiling_Violation then
 590
 591          --  Failed ceiling check
 592
 593          Initialization.Undefer_Abort (Self_ID);
 594          raise Program_Error;
 595       end if;
 596
 597       Block.Self := Self_ID;
 598       Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;
 599       pragma Debug
 600         (Debug.Trace (Self_ID, "PEC: entered ATC level: " &
 601          ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));
 602       Entry_Call :=
 603          Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
 604       Entry_Call.Next := null;
 605       Entry_Call.Mode := Mode;
 606       Entry_Call.Cancellation_Attempted := False;
 607
 608       if Self_ID.Deferral_Level > 1 then
 609          Entry_Call.State := Never_Abortable;
 610       else
 611          Entry_Call.State := Now_Abortable;
 612       end if;
 613
 614       Entry_Call.E := Entry_Index (E);
 615       Entry_Call.Prio := STPO.Get_Priority (Self_ID);
 616       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
 617       Entry_Call.Called_PO := To_Address (Object);
 618       Entry_Call.Called_Task := null;
 619       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
 620
 621       PO_Do_Or_Queue (Self_ID, Object, Entry_Call, With_Abort => True);
 622       Initially_Abortable := Entry_Call.State = Now_Abortable;
 623       PO_Service_Entries (Self_ID, Object);
 624
 625       --  Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
 626       --  for completed or cancelled calls.  (This is a heuristic, only.)
 627
 628       if Entry_Call.State >= Done then
 629
 630          --  Once State >= Done it will not change any more.
 631
 632          if Single_Lock then
 633             STPO.Lock_RTS;
 634          end if;
 635
 636          STPO.Write_Lock (Self_ID);
 637          Utilities.Exit_One_ATC_Level (Self_ID);
 638          STPO.Unlock (Self_ID);
 639
 640          if Single_Lock then
 641             STPO.Unlock_RTS;
 642          end if;
 643
 644          Block.Enqueued := False;
 645          Block.Cancelled := Entry_Call.State = Cancelled;
 646          Initialization.Undefer_Abort (Self_ID);
 647          Entry_Calls.Check_Exception (Self_ID, Entry_Call);
 648          return;
 649
 650       else
 651          --  In this case we cannot conclude anything,
 652          --  since State can change concurrently.
 653          null;
 654       end if;
 655
 656       --  Now for the general case.
 657
 658       if Mode = Asynchronous_Call then
 659
 660          --  Try to avoid an expensive call.
 661
 662          if not Initially_Abortable then
 663             if Single_Lock then
 664                STPO.Lock_RTS;
 665                Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
 666                STPO.Unlock_RTS;
 667             else
 668                Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);
 669             end if;
 670          end if;
 671
 672       elsif Mode < Asynchronous_Call then
 673
 674          --  Simple_Call or Conditional_Call
 675
 676          if Single_Lock then
 677             STPO.Lock_RTS;
 678             Entry_Calls.Wait_For_Completion (Entry_Call);
 679             STPO.Unlock_RTS;
 680          else
 681             STPO.Write_Lock (Self_ID);
 682             Entry_Calls.Wait_For_Completion (Entry_Call);
 683             STPO.Unlock (Self_ID);
 684          end if;
 685
 686          Block.Cancelled := Entry_Call.State = Cancelled;
 687
 688       else
 689          pragma Assert (False);
 690          null;
 691       end if;
 692
 693       Initialization.Undefer_Abort (Self_ID);
 694       Entry_Calls.Check_Exception (Self_ID, Entry_Call);
 695    end Protected_Entry_Call;
 696
 697    ------------------
 698    -- Requeue_Call --
 699    ------------------
 700
 701    procedure Requeue_Call
 702      (Self_Id    : Task_Id;
 703       Object     : Protection_Entries_Access;
 704       Entry_Call : Entry_Call_Link;
 705       With_Abort : Boolean)
 706    is
 707       New_Object        : Protection_Entries_Access;
 708       Ceiling_Violation : Boolean;
 709       Result            : Boolean;
 710       E                 : Protected_Entry_Index;
 711
 712    begin
 713       New_Object := To_Protection (Entry_Call.Called_PO);
 714
 715       if New_Object = null then
 716
 717          --  Call is to be requeued to a task entry
 718
 719          if Single_Lock then
 720             STPO.Lock_RTS;
 721          end if;
 722
 723          Result := Rendezvous.Task_Do_Or_Queue
 724            (Self_Id, Entry_Call,
 725             With_Abort => Entry_Call.Requeue_With_Abort);
 726
 727          if not Result then
 728             Queuing.Broadcast_Program_Error
 729               (Self_Id, Object, Entry_Call, RTS_Locked => True);
 730          end if;
 731
 732          if Single_Lock then
 733             STPO.Unlock_RTS;
 734          end if;
 735
 736       else
 737          --  Call should be requeued to a PO
 738
 739          if Object /= New_Object then
 740
 741             --  Requeue is to different PO
 742
 743             Lock_Entries (New_Object, Ceiling_Violation);
 744
 745             if Ceiling_Violation then
 746                Object.Call_In_Progress := null;
 747                Queuing.Broadcast_Program_Error
 748                  (Self_Id, Object, Entry_Call);
 749
 750             else
 751                PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call, With_Abort);
 752                PO_Service_Entries (Self_Id, New_Object);
 753             end if;
 754
 755          else
 756             --  Requeue is to same protected object
 757
 758             --  ??? Try to compensate apparent failure of the
 759             --  scheduler on some OS (e.g VxWorks) to give higher
 760             --  priority tasks a chance to run (see CXD6002).
 761
 762             STPO.Yield (False);
 763
 764             if Entry_Call.Requeue_With_Abort
 765               and then Entry_Call.Cancellation_Attempted
 766             then
 767                --  If this is a requeue with abort and someone tried
 768                --  to cancel this call, cancel it at this point.
 769
 770                Entry_Call.State := Cancelled;
 771                return;
 772             end if;
 773
 774             if not With_Abort
 775               or else Entry_Call.Mode /= Conditional_Call
 776             then
 777                E := Protected_Entry_Index (Entry_Call.E);
 778
 779                if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
 780                     and then
 781                   Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
 782                     Queuing.Count_Waiting (Object.Entry_Queues (E))
 783                then
 784                   --  This violates the Max_Entry_Queue_Length restriction,
 785                   --  raise Program_Error.
 786
 787                   Entry_Call.Exception_To_Raise := Program_Error'Identity;
 788
 789                   if Single_Lock then
 790                      STPO.Lock_RTS;
 791                   end if;
 792
 793                   STPO.Write_Lock (Entry_Call.Self);
 794                   Initialization.Wakeup_Entry_Caller
 795                     (Self_Id, Entry_Call, Done);
 796                   STPO.Unlock (Entry_Call.Self);
 797
 798                   if Single_Lock then
 799                      STPO.Unlock_RTS;
 800                   end if;
 801                else
 802                   Queuing.Enqueue
 803                     (New_Object.Entry_Queues (E), Entry_Call);
 804                   Update_For_Queue_To_PO (Entry_Call, With_Abort);
 805                end if;
 806
 807             else
 808                PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call, With_Abort);
 809             end if;
 810          end if;
 811       end if;
 812    end Requeue_Call;
 813
 814    ----------------------------
 815    -- Protected_Entry_Caller --
 816    ----------------------------
 817
 818    function Protected_Entry_Caller
 819      (Object : Protection_Entries'Class) return Task_Id is
 820    begin
 821       return Object.Call_In_Progress.Self;
 822    end Protected_Entry_Caller;
 823
 824    -----------------------------
 825    -- Requeue_Protected_Entry --
 826    -----------------------------
 827
 828    --  Compiler interface only.  Do not call from within the RTS.
 829
 830    --  entry e when b is
 831    --  begin
 832    --     b := false;
 833    --     ...A...
 834    --     requeue e2;
 835    --  end e;
 836
 837    --  procedure rPT__E10b (O : address; P : address; E :
 838    --    protected_entry_index) is
 839    --     type rTVP is access rTV;
 840    --     freeze rTVP []
 841    --     _object : rTVP := rTVP!(O);
 842    --  begin
 843    --     declare
 844    --        rR : protection renames _object._object;
 845    --        vP : integer renames _object.v;
 846    --        bP : boolean renames _object.b;
 847    --     begin
 848    --        b := false;
 849    --        ...A...
 850    --        requeue_protected_entry (rR'unchecked_access, rR'
 851    --          unchecked_access, 2, false, objectF => 0, new_objectF =>
 852    --          0);
 853    --        return;
 854    --     end;
 855    --     complete_entry_body (_object._object'unchecked_access, objectF =>
 856    --       0);
 857    --     return;
 858    --  exception
 859    --     when others =>
 860    --        abort_undefer.all;
 861    --        exceptional_complete_entry_body (_object._object'
 862    --          unchecked_access, current_exception, objectF => 0);
 863    --        return;
 864    --  end rPT__E10b;
 865
 866    procedure Requeue_Protected_Entry
 867      (Object     : Protection_Entries_Access;
 868       New_Object : Protection_Entries_Access;
 869       E          : Protected_Entry_Index;
 870       With_Abort : Boolean)
 871    is
 872       Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;
 873
 874    begin
 875       pragma Debug
 876         (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P'));
 877       pragma Assert (STPO.Self.Deferral_Level > 0);
 878
 879       Entry_Call.E := Entry_Index (E);
 880       Entry_Call.Called_PO := To_Address (New_Object);
 881       Entry_Call.Called_Task := null;
 882       Entry_Call.Requeue_With_Abort := With_Abort;
 883       Object.Call_In_Progress := null;
 884    end Requeue_Protected_Entry;
 885
 886    -------------------------------------
 887    -- Requeue_Task_To_Protected_Entry --
 888    -------------------------------------
 889
 890    --  Compiler interface only.
 891
 892    --    accept e1 do
 893    --      ...A...
 894    --      requeue r.e2;
 895    --    end e1;
 896
 897    --    A79b : address;
 898    --    L78b : label
 899    --    begin
 900    --       accept_call (1, A79b);
 901    --       ...A...
 902    --       requeue_task_to_protected_entry (rTV!(r)._object'
 903    --         unchecked_access, 2, false, new_objectF => 0);
 904    --       goto L78b;
 905    --       <<L78b>>
 906    --       complete_rendezvous;
 907    --    exception
 908    --       when all others =>
 909    --          exceptional_complete_rendezvous (get_gnat_exception);
 910    --    end;
 911
 912    procedure Requeue_Task_To_Protected_Entry
 913      (New_Object : Protection_Entries_Access;
 914       E          : Protected_Entry_Index;
 915       With_Abort : Boolean)
 916    is
 917       Self_ID    : constant Task_Id := STPO.Self;
 918       Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call;
 919
 920    begin
 921       Initialization.Defer_Abort (Self_ID);
 922
 923       --  We do not need to lock Self_ID here since the call is not abortable
 924       --  at this point, and therefore, the caller cannot cancel the call.
 925
 926       Entry_Call.Needs_Requeue := True;
 927       Entry_Call.Requeue_With_Abort := With_Abort;
 928       Entry_Call.Called_PO := To_Address (New_Object);
 929       Entry_Call.Called_Task := null;
 930       Entry_Call.E := Entry_Index (E);
 931       Initialization.Undefer_Abort (Self_ID);
 932    end Requeue_Task_To_Protected_Entry;
 933
 934    ---------------------
 935    -- Service_Entries --
 936    ---------------------
 937
 938    procedure Service_Entries (Object : Protection_Entries_Access) is
 939       Self_ID : constant Task_Id := STPO.Self;
 940    begin
 941       PO_Service_Entries (Self_ID, Object);
 942    end Service_Entries;
 943
 944    --------------------------------
 945    -- Timed_Protected_Entry_Call --
 946    --------------------------------
 947
 948    --  Compiler interface only.  Do not call from within the RTS.
 949
 950    procedure Timed_Protected_Entry_Call
 951      (Object                : Protection_Entries_Access;
 952       E                     : Protected_Entry_Index;
 953       Uninterpreted_Data    : System.Address;
 954       Timeout               : Duration;
 955       Mode                  : Delay_Modes;
 956       Entry_Call_Successful : out Boolean)
 957    is
 958       Self_Id           : constant Task_Id  := STPO.Self;
 959       Entry_Call        : Entry_Call_Link;
 960       Ceiling_Violation : Boolean;
 961       Yielded           : Boolean;
 962
 963    begin
 964       if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
 965          Raise_Exception (Storage_Error'Identity,
 966            "not enough ATC nesting levels");
 967       end if;
 968
 969       --  If pragma Detect_Blocking is active then Program_Error must be
 970       --  raised if this potentially blocking operation is called from a
 971       --  protected action.
 972
 973       if Detect_Blocking
 974         and then Self_Id.Common.Protected_Action_Nesting > 0
 975       then
 976          Ada.Exceptions.Raise_Exception
 977            (Program_Error'Identity, "potentially blocking operation");
 978       end if;
 979
 980       if Runtime_Traces then
 981          Send_Trace_Info (POT_Call, Entry_Index (E), Timeout);
 982       end if;
 983
 984       Initialization.Defer_Abort (Self_Id);
 985       Lock_Entries (Object, Ceiling_Violation);
 986
 987       if Ceiling_Violation then
 988          Initialization.Undefer_Abort (Self_Id);
 989          raise Program_Error;
 990       end if;
 991
 992       Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
 993       pragma Debug
 994         (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " &
 995          ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
 996       Entry_Call :=
 997         Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access;
 998       Entry_Call.Next := null;
 999       Entry_Call.Mode := Timed_Call;
1000       Entry_Call.Cancellation_Attempted := False;
1001
1002       if Self_Id.Deferral_Level > 1 then
1003          Entry_Call.State := Never_Abortable;
1004       else
1005          Entry_Call.State := Now_Abortable;
1006       end if;
1007
1008       Entry_Call.E := Entry_Index (E);
1009       Entry_Call.Prio := STPO.Get_Priority (Self_Id);
1010       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
1011       Entry_Call.Called_PO := To_Address (Object);
1012       Entry_Call.Called_Task := null;
1013       Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
1014
1015       PO_Do_Or_Queue (Self_Id, Object, Entry_Call, With_Abort => True);
1016       PO_Service_Entries (Self_Id, Object);
1017
1018       if Single_Lock then
1019          STPO.Lock_RTS;
1020       else
1021          STPO.Write_Lock (Self_Id);
1022       end if;
1023
1024       --  Try to avoid waiting for completed or cancelled calls.
1025
1026       if Entry_Call.State >= Done then
1027          Utilities.Exit_One_ATC_Level (Self_Id);
1028
1029          if Single_Lock then
1030             STPO.Unlock_RTS;
1031          else
1032             STPO.Unlock (Self_Id);
1033          end if;
1034
1035          Entry_Call_Successful := Entry_Call.State = Done;
1036          Initialization.Undefer_Abort (Self_Id);
1037          Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1038          return;
1039       end if;
1040
1041       Entry_Calls.Wait_For_Completion_With_Timeout
1042         (Entry_Call, Timeout, Mode, Yielded);
1043
1044       if Single_Lock then
1045          STPO.Unlock_RTS;
1046       else
1047          STPO.Unlock (Self_Id);
1048       end if;
1049
1050       --  ??? Do we need to yield in case Yielded is False
1051
1052       Initialization.Undefer_Abort (Self_Id);
1053       Entry_Call_Successful := Entry_Call.State = Done;
1054       Entry_Calls.Check_Exception (Self_Id, Entry_Call);
1055    end Timed_Protected_Entry_Call;
1056
1057    ----------------------------
1058    -- Update_For_Queue_To_PO --
1059    ----------------------------
1060
1061    --  Update the state of an existing entry call, based on
1062    --  whether the current queuing action is with or without abort.
1063    --  Call this only while holding the server's lock.
1064    --  It returns with the server's lock released.
1065
1066    New_State : constant array (Boolean, Entry_Call_State)
1067      of Entry_Call_State :=
1068        (True =>
1069          (Never_Abortable   => Never_Abortable,
1070           Not_Yet_Abortable => Now_Abortable,
1071           Was_Abortable     => Now_Abortable,
1072           Now_Abortable     => Now_Abortable,
1073           Done              => Done,
1074           Cancelled         => Cancelled),
1075         False =>
1076          (Never_Abortable   => Never_Abortable,
1077           Not_Yet_Abortable => Not_Yet_Abortable,
1078           Was_Abortable     => Was_Abortable,
1079           Now_Abortable     => Now_Abortable,
1080           Done              => Done,
1081           Cancelled         => Cancelled)
1082        );
1083
1084    procedure Update_For_Queue_To_PO
1085      (Entry_Call : Entry_Call_Link;
1086       With_Abort : Boolean)
1087    is
1088       Old : constant Entry_Call_State := Entry_Call.State;
1089
1090    begin
1091       pragma Assert (Old < Done);
1092
1093       Entry_Call.State := New_State (With_Abort, Entry_Call.State);
1094
1095       if Entry_Call.Mode = Asynchronous_Call then
1096          if Old < Was_Abortable and then
1097            Entry_Call.State = Now_Abortable
1098          then
1099             if Single_Lock then
1100                STPO.Lock_RTS;
1101             end if;
1102
1103             STPO.Write_Lock (Entry_Call.Self);
1104
1105             if Entry_Call.Self.Common.State = Async_Select_Sleep then
1106                STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep);
1107             end if;
1108
1109             STPO.Unlock (Entry_Call.Self);
1110
1111             if Single_Lock then
1112                STPO.Unlock_RTS;
1113             end if;
1114
1115          end if;
1116
1117       elsif Entry_Call.Mode = Conditional_Call then
1118          pragma Assert (Entry_Call.State < Was_Abortable);
1119          null;
1120       end if;
1121    end Update_For_Queue_To_PO;
1122
1123 end System.Tasking.Protected_Objects.Operations;