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