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