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