gcc/ada/s-tpobop.adb

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