gcc/ada/s-tpobop.adb

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