gcc/ada/s-tpobop.adb

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