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