Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnarl/s-tpobop.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2017, 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;