gcc/ada/s-tpobop.adb

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