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