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