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