gcc/ada/s-tpobop.adb

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