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