1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
9 -- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 -- This package contains all extended primitives related to Protected_Objects
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.
39 -- The split between Entries and Operations is needed to break circular
40 -- dependencies inside the run time.
42 -- This package contains all primitives related to Protected_Objects.
43 -- Note: the compiler generates direct calls to this interface, via Rtsfind.
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
.Restrictions
;
53 with System
.Tasking
.Initialization
;
54 pragma Elaborate_All
(System
.Tasking
.Initialization
);
55 -- Insures that tasking is initialized if any protected objects are created
57 package body System
.Tasking
.Protected_Objects
.Operations
is
59 package STPO
renames System
.Task_Primitives
.Operations
;
64 use System
.Restrictions
;
65 use System
.Restrictions
.Rident
;
67 -----------------------
68 -- Local Subprograms --
69 -----------------------
71 procedure Update_For_Queue_To_PO
72 (Entry_Call
: Entry_Call_Link
;
73 With_Abort
: Boolean);
74 pragma Inline
(Update_For_Queue_To_PO
);
75 -- Update the state of an existing entry call to reflect the fact that it
76 -- is being enqueued, based on whether the current queuing action is with
77 -- or without abort. Call this only while holding the PO's lock. It returns
78 -- with the PO's lock still held.
80 procedure Requeue_Call
82 Object
: Protection_Entries_Access
;
83 Entry_Call
: Entry_Call_Link
);
84 -- Handle requeue of Entry_Call.
85 -- In particular, queue the call if needed, or service it immediately
88 ---------------------------------
89 -- Cancel_Protected_Entry_Call --
90 ---------------------------------
92 -- Compiler interface only (do not call from within the RTS)
94 -- This should have analogous effect to Cancel_Task_Entry_Call, setting
95 -- the value of Block.Cancelled instead of returning the parameter value
98 -- The effect should be idempotent, since the call may already have been
112 -- X : protected_entry_index := 1;
113 -- B80b : communication_block;
114 -- communication_blockIP (B80b);
120 -- procedure _clean is
122 -- if enqueued (B80b) then
123 -- cancel_protected_entry_call (B80b);
129 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
130 -- null_address, asynchronous_call, B80b, objectF => 0);
131 -- if enqueued (B80b) then
139 -- when _abort_signal =>
140 -- abort_undefer.all;
144 -- if not cancelled (B80b) then
149 -- If the entry call completes after we get into the abortable part,
150 -- Abort_Signal should be raised and ATC will take us to the at-end
151 -- handler, which will call _clean.
153 -- If the entry call returns with the call already completed, we can skip
154 -- this, and use the "if enqueued()" to go past the at-end handler, but we
155 -- will still call _clean.
157 -- If the abortable part completes before the entry call is Done, it will
160 -- If the entry call or the abortable part raises an exception,
161 -- we will still call _clean, but the value of Cancelled should not matter.
163 -- Whoever calls _clean first gets to decide whether the call
164 -- has been "cancelled".
166 -- Enqueued should be true if there is any chance that the call is still on
167 -- a queue. It seems to be safe to make it True if the call was Onqueue at
168 -- some point before return from Protected_Entry_Call.
170 -- Cancelled should be true iff the abortable part completed
171 -- and succeeded in cancelling the entry call before it completed.
174 -- The need for Enqueued is less obvious. The "if enqueued ()" tests are
175 -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call
176 -- must do the same test internally, with locking. The one that makes
177 -- cancellation conditional may be a useful heuristic since at least 1/2
178 -- the time the call should be off-queue by that point. The other one seems
179 -- totally useless, since Protected_Entry_Call must do the same check and
180 -- then possibly wait for the call to be abortable, internally.
182 -- We can check Call.State here without locking the caller's mutex,
183 -- since the call must be over after returning from Wait_For_Completion.
184 -- No other task can access the call record at this point.
186 procedure Cancel_Protected_Entry_Call
187 (Block
: in out Communication_Block
) is
189 Entry_Calls
.Try_To_Cancel_Entry_Call
(Block
.Cancelled
);
190 end Cancel_Protected_Entry_Call
;
196 function Cancelled
(Block
: Communication_Block
) return Boolean is
198 return Block
.Cancelled
;
201 -------------------------
202 -- Complete_Entry_Body --
203 -------------------------
205 procedure Complete_Entry_Body
(Object
: Protection_Entries_Access
) is
207 Exceptional_Complete_Entry_Body
(Object
, Ada
.Exceptions
.Null_Id
);
208 end Complete_Entry_Body
;
214 function Enqueued
(Block
: Communication_Block
) return Boolean is
216 return Block
.Enqueued
;
219 -------------------------------------
220 -- Exceptional_Complete_Entry_Body --
221 -------------------------------------
223 procedure Exceptional_Complete_Entry_Body
224 (Object
: Protection_Entries_Access
;
225 Ex
: Ada
.Exceptions
.Exception_Id
)
227 procedure Transfer_Occurrence
228 (Target
: Ada
.Exceptions
.Exception_Occurrence_Access
;
229 Source
: Ada
.Exceptions
.Exception_Occurrence
);
230 pragma Import
(C
, Transfer_Occurrence
, "__gnat_transfer_occurrence");
232 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
237 (Debug
.Trace
(STPO
.Self
, "Exceptional_Complete_Entry_Body", 'P'));
239 -- We must have abort deferred, since we are inside a protected
242 if Entry_Call
/= null then
244 -- The call was not requeued
246 Entry_Call
.Exception_To_Raise
:= Ex
;
248 if Ex
/= Ada
.Exceptions
.Null_Id
then
249 Self_Id
:= STPO
.Self
;
251 (Entry_Call
.Self
.Common
.Compiler_Data
.Current_Excep
'Access,
252 Self_Id
.Common
.Compiler_Data
.Current_Excep
);
255 -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
256 -- PO_Service_Entries on return.
259 end Exceptional_Complete_Entry_Body
;
265 procedure PO_Do_Or_Queue
267 Object
: Protection_Entries_Access
;
268 Entry_Call
: Entry_Call_Link
)
270 E
: constant Protected_Entry_Index
:=
271 Protected_Entry_Index
(Entry_Call
.E
);
272 Index
: constant Protected_Entry_Index
:=
273 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
);
274 Barrier_Value
: Boolean;
275 Queue_Length
: Natural;
277 -- When the Action procedure for an entry body returns, it is either
278 -- completed (having called [Exceptional_]Complete_Entry_Body) or it
279 -- is queued, having executed a requeue statement.
282 Object
.Entry_Bodies
(Index
).Barrier
(Object
.Compiler_Info
, E
);
284 if Barrier_Value
then
286 -- Not abortable while service is in progress
288 if Entry_Call
.State
= Now_Abortable
then
289 Entry_Call
.State
:= Was_Abortable
;
292 Object
.Call_In_Progress
:= Entry_Call
;
295 (Debug
.Trace
(Self_ID
, "PODOQ: start entry body", 'P'));
296 Object
.Entry_Bodies
(Index
).Action
(
297 Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
299 if Object
.Call_In_Progress
/= null then
301 -- Body of current entry served call to completion
303 Object
.Call_In_Progress
:= null;
304 STPO
.Write_Lock
(Entry_Call
.Self
);
305 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
306 STPO
.Unlock
(Entry_Call
.Self
);
309 Requeue_Call
(Self_ID
, Object
, Entry_Call
);
312 elsif Entry_Call
.Mode
/= Conditional_Call
313 or else not Entry_Call
.With_Abort
315 if Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
316 or else Object
.Entry_Queue_Maxes
/= null
318 -- Need to check the queue length. Computing the length is an
319 -- unusual case and is slow (need to walk the queue).
321 Queue_Length
:= Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
));
323 if (Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
324 and then Queue_Length
>=
325 Run_Time_Restrictions
.Value
(Max_Entry_Queue_Length
))
327 (Object
.Entry_Queue_Maxes
/= null
328 and then Object
.Entry_Queue_Maxes
(Index
) /= 0
329 and then Queue_Length
>= Object
.Entry_Queue_Maxes
(Index
))
331 -- This violates the Max_Entry_Queue_Length restriction or the
332 -- Max_Queue_Length bound, raise Program_Error.
334 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
335 STPO
.Write_Lock
(Entry_Call
.Self
);
336 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
337 STPO
.Unlock
(Entry_Call
.Self
);
343 -- Do the work: queue the call
345 Queuing
.Enqueue
(Object
.Entry_Queues
(E
), Entry_Call
);
346 Update_For_Queue_To_PO
(Entry_Call
, Entry_Call
.With_Abort
);
350 -- Conditional_Call and With_Abort
352 STPO
.Write_Lock
(Entry_Call
.Self
);
353 pragma Assert
(Entry_Call
.State
/= Not_Yet_Abortable
);
354 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Cancelled
);
355 STPO
.Unlock
(Entry_Call
.Self
);
360 Queuing
.Broadcast_Program_Error
(Self_ID
, Object
, Entry_Call
);
363 ------------------------
364 -- PO_Service_Entries --
365 ------------------------
367 procedure PO_Service_Entries
369 Object
: Entries
.Protection_Entries_Access
;
370 Unlock_Object
: Boolean := True)
372 E
: Protected_Entry_Index
;
374 Entry_Call
: Entry_Call_Link
;
378 Queuing
.Select_Protected_Entry_Call
(Self_ID
, Object
, Entry_Call
);
380 exit when Entry_Call
= null;
382 E
:= Protected_Entry_Index
(Entry_Call
.E
);
384 -- Not abortable while service is in progress
386 if Entry_Call
.State
= Now_Abortable
then
387 Entry_Call
.State
:= Was_Abortable
;
390 Object
.Call_In_Progress
:= Entry_Call
;
394 (Debug
.Trace
(Self_ID
, "POSE: start entry body", 'P'));
397 (Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).Action
398 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
402 Queuing
.Broadcast_Program_Error
(Self_ID
, Object
, Entry_Call
);
405 if Object
.Call_In_Progress
= null then
406 Requeue_Call
(Self_ID
, Object
, Entry_Call
);
407 exit when Entry_Call
.State
= Cancelled
;
410 Object
.Call_In_Progress
:= null;
411 Caller
:= Entry_Call
.Self
;
412 STPO
.Write_Lock
(Caller
);
413 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
414 STPO
.Unlock
(Caller
);
418 if Unlock_Object
then
419 Unlock_Entries
(Object
);
421 end PO_Service_Entries
;
423 ---------------------
424 -- Protected_Count --
425 ---------------------
427 function Protected_Count
428 (Object
: Protection_Entries
'Class;
429 E
: Protected_Entry_Index
) return Natural
432 return Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
));
435 --------------------------
436 -- Protected_Entry_Call --
437 --------------------------
439 -- Compiler interface only (do not call from within the RTS)
448 -- X : protected_entry_index := 1;
449 -- B85b : communication_block;
450 -- communication_blockIP (B85b);
453 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
454 -- null_address, conditional_call, B85b, objectF => 0);
456 -- if cancelled (B85b) then
463 -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous
466 -- The initial part of this procedure does not need to lock the calling
467 -- task's ATCB, up to the point where the call record first may be queued
468 -- (PO_Do_Or_Queue), since before that no other task will have access to
471 -- If this is a call made inside of an abort deferred region, the call
472 -- should be never abortable.
474 -- If the call was not queued abortably, we need to wait until it is before
475 -- proceeding with the abortable part.
477 -- There are some heuristics here, just to save time for frequently
478 -- occurring cases. For example, we check Initially_Abortable to try to
479 -- avoid calling the procedure Wait_Until_Abortable, since the normal case
480 -- for async. entry calls is to be queued abortably.
482 -- Another heuristic uses the Block.Enqueued to try to avoid calling
483 -- Cancel_Protected_Entry_Call if the call can be served immediately.
485 procedure Protected_Entry_Call
486 (Object
: Protection_Entries_Access
;
487 E
: Protected_Entry_Index
;
488 Uninterpreted_Data
: System
.Address
;
490 Block
: out Communication_Block
)
492 Self_ID
: constant Task_Id
:= STPO
.Self
;
493 Entry_Call
: Entry_Call_Link
;
494 Initially_Abortable
: Boolean;
495 Ceiling_Violation
: Boolean;
499 (Debug
.Trace
(Self_ID
, "Protected_Entry_Call", 'P'));
501 if Self_ID
.ATC_Nesting_Level
= ATC_Level
'Last then
502 raise Storage_Error
with "not enough ATC nesting levels";
505 -- If pragma Detect_Blocking is active then Program_Error must be
506 -- raised if this potentially blocking operation is called from a
510 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
512 raise Program_Error
with "potentially blocking operation";
515 -- Self_ID.Deferral_Level should be 0, except when called from Finalize,
516 -- where abort is already deferred.
518 Initialization
.Defer_Abort_Nestable
(Self_ID
);
519 Lock_Entries_With_Status
(Object
, Ceiling_Violation
);
521 if Ceiling_Violation
then
523 -- Failed ceiling check
525 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
529 Block
.Self
:= Self_ID
;
530 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
+ 1;
532 (Debug
.Trace
(Self_ID
, "PEC: entered ATC level: " &
533 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
535 Self_ID
.Entry_Calls
(Self_ID
.ATC_Nesting_Level
)'Access;
536 Entry_Call
.Next
:= null;
537 Entry_Call
.Mode
:= Mode
;
538 Entry_Call
.Cancellation_Attempted
:= False;
541 (if Self_ID
.Deferral_Level
> 1
542 then Never_Abortable
else Now_Abortable
);
544 Entry_Call
.E
:= Entry_Index
(E
);
545 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_ID
);
546 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
547 Entry_Call
.Called_PO
:= To_Address
(Object
);
548 Entry_Call
.Called_Task
:= null;
549 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
550 Entry_Call
.With_Abort
:= True;
552 PO_Do_Or_Queue
(Self_ID
, Object
, Entry_Call
);
553 Initially_Abortable
:= Entry_Call
.State
= Now_Abortable
;
554 PO_Service_Entries
(Self_ID
, Object
);
556 -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
557 -- for completed or cancelled calls. (This is a heuristic, only.)
559 if Entry_Call
.State
>= Done
then
561 -- Once State >= Done it will not change any more
563 STPO
.Write_Lock
(Self_ID
);
564 Utilities
.Exit_One_ATC_Level
(Self_ID
);
565 STPO
.Unlock
(Self_ID
);
567 Block
.Enqueued
:= False;
568 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
569 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
570 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
574 -- In this case we cannot conclude anything, since State can change
580 -- Now for the general case
582 if Mode
= Asynchronous_Call
then
584 -- Try to avoid an expensive call
586 if not Initially_Abortable
then
587 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
592 when Conditional_Call
595 STPO
.Write_Lock
(Self_ID
);
596 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
597 STPO
.Unlock
(Self_ID
);
599 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
601 when Asynchronous_Call
604 pragma Assert
(False);
609 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
610 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
611 end Protected_Entry_Call
;
617 procedure Requeue_Call
619 Object
: Protection_Entries_Access
;
620 Entry_Call
: Entry_Call_Link
)
622 New_Object
: Protection_Entries_Access
;
623 Ceiling_Violation
: Boolean;
625 E
: Protected_Entry_Index
;
628 New_Object
:= To_Protection
(Entry_Call
.Called_PO
);
630 if New_Object
= null then
632 -- Call is to be requeued to a task entry
634 Result
:= Rendezvous
.Task_Do_Or_Queue
(Self_Id
, Entry_Call
);
637 Queuing
.Broadcast_Program_Error
(Self_Id
, Object
, Entry_Call
);
640 -- Call should be requeued to a PO
642 if Object
/= New_Object
then
644 -- Requeue is to different PO
646 Lock_Entries_With_Status
(New_Object
, Ceiling_Violation
);
648 if Ceiling_Violation
then
649 Object
.Call_In_Progress
:= null;
650 Queuing
.Broadcast_Program_Error
(Self_Id
, Object
, Entry_Call
);
653 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
);
654 PO_Service_Entries
(Self_Id
, New_Object
);
658 -- Requeue is to same protected object
660 -- ??? Try to compensate apparent failure of the scheduler on some
661 -- OS (e.g VxWorks) to give higher priority tasks a chance to run
664 STPO
.Yield
(Do_Yield
=> False);
666 if Entry_Call
.With_Abort
667 and then Entry_Call
.Cancellation_Attempted
669 -- If this is a requeue with abort and someone tried to cancel
670 -- this call, cancel it at this point.
672 Entry_Call
.State
:= Cancelled
;
676 if not Entry_Call
.With_Abort
677 or else Entry_Call
.Mode
/= Conditional_Call
679 E
:= Protected_Entry_Index
(Entry_Call
.E
);
681 if Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
683 Run_Time_Restrictions
.Value
(Max_Entry_Queue_Length
) <=
684 Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
))
686 -- This violates the Max_Entry_Queue_Length restriction,
687 -- raise Program_Error.
689 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
691 STPO
.Write_Lock
(Entry_Call
.Self
);
692 Initialization
.Wakeup_Entry_Caller
693 (Self_Id
, Entry_Call
, Done
);
694 STPO
.Unlock
(Entry_Call
.Self
);
698 (New_Object
.Entry_Queues
(E
), Entry_Call
);
699 Update_For_Queue_To_PO
(Entry_Call
, Entry_Call
.With_Abort
);
703 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
);
709 ----------------------------
710 -- Protected_Entry_Caller --
711 ----------------------------
713 function Protected_Entry_Caller
714 (Object
: Protection_Entries
'Class) return Task_Id
is
716 return Object
.Call_In_Progress
.Self
;
717 end Protected_Entry_Caller
;
719 -----------------------------
720 -- Requeue_Protected_Entry --
721 -----------------------------
723 -- Compiler interface only (do not call from within the RTS)
732 -- procedure rPT__E10b (O : address; P : address; E :
733 -- protected_entry_index) is
734 -- type rTVP is access rTV;
736 -- _object : rTVP := rTVP!(O);
739 -- rR : protection renames _object._object;
740 -- vP : integer renames _object.v;
741 -- bP : boolean renames _object.b;
745 -- requeue_protected_entry (rR'unchecked_access, rR'
746 -- unchecked_access, 2, false, objectF => 0, new_objectF =>
750 -- complete_entry_body (_object._object'unchecked_access, objectF =>
755 -- abort_undefer.all;
756 -- exceptional_complete_entry_body (_object._object'
757 -- unchecked_access, current_exception, objectF => 0);
761 procedure Requeue_Protected_Entry
762 (Object
: Protection_Entries_Access
;
763 New_Object
: Protection_Entries_Access
;
764 E
: Protected_Entry_Index
;
765 With_Abort
: Boolean)
767 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
771 (Debug
.Trace
(STPO
.Self
, "Requeue_Protected_Entry", 'P'));
772 pragma Assert
(STPO
.Self
.Deferral_Level
> 0);
774 Entry_Call
.E
:= Entry_Index
(E
);
775 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
776 Entry_Call
.Called_Task
:= null;
777 Entry_Call
.With_Abort
:= With_Abort
;
778 Object
.Call_In_Progress
:= null;
779 end Requeue_Protected_Entry
;
781 -------------------------------------
782 -- Requeue_Task_To_Protected_Entry --
783 -------------------------------------
785 -- Compiler interface only (do not call from within the RTS)
796 -- accept_call (1, A79b);
798 -- requeue_task_to_protected_entry (rTV!(r)._object'
799 -- unchecked_access, 2, false, new_objectF => 0);
802 -- complete_rendezvous;
805 -- when all others =>
806 -- exceptional_complete_rendezvous (get_gnat_exception);
809 procedure Requeue_Task_To_Protected_Entry
810 (New_Object
: Protection_Entries_Access
;
811 E
: Protected_Entry_Index
;
812 With_Abort
: Boolean)
814 Self_ID
: constant Task_Id
:= STPO
.Self
;
815 Entry_Call
: constant Entry_Call_Link
:= Self_ID
.Common
.Call
;
818 Initialization
.Defer_Abort
(Self_ID
);
820 -- We do not need to lock Self_ID here since the call is not abortable
821 -- at this point, and therefore, the caller cannot cancel the call.
823 Entry_Call
.Needs_Requeue
:= True;
824 Entry_Call
.With_Abort
:= With_Abort
;
825 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
826 Entry_Call
.Called_Task
:= null;
827 Entry_Call
.E
:= Entry_Index
(E
);
828 Initialization
.Undefer_Abort
(Self_ID
);
829 end Requeue_Task_To_Protected_Entry
;
831 ---------------------
832 -- Service_Entries --
833 ---------------------
835 procedure Service_Entries
(Object
: Protection_Entries_Access
) is
836 Self_ID
: constant Task_Id
:= STPO
.Self
;
838 PO_Service_Entries
(Self_ID
, Object
);
841 --------------------------------
842 -- Timed_Protected_Entry_Call --
843 --------------------------------
845 -- Compiler interface only (do not call from within the RTS)
847 procedure Timed_Protected_Entry_Call
848 (Object
: Protection_Entries_Access
;
849 E
: Protected_Entry_Index
;
850 Uninterpreted_Data
: System
.Address
;
853 Entry_Call_Successful
: out Boolean)
855 Self_Id
: constant Task_Id
:= STPO
.Self
;
856 Entry_Call
: Entry_Call_Link
;
857 Ceiling_Violation
: Boolean;
860 pragma Unreferenced
(Yielded
);
863 if Self_Id
.ATC_Nesting_Level
= ATC_Level
'Last then
864 raise Storage_Error
with "not enough ATC nesting levels";
867 -- If pragma Detect_Blocking is active then Program_Error must be
868 -- raised if this potentially blocking operation is called from a
872 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
874 raise Program_Error
with "potentially blocking operation";
877 Initialization
.Defer_Abort_Nestable
(Self_Id
);
878 Lock_Entries_With_Status
(Object
, Ceiling_Violation
);
880 if Ceiling_Violation
then
881 Initialization
.Undefer_Abort
(Self_Id
);
885 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
+ 1;
887 (Debug
.Trace
(Self_Id
, "TPEC: exited to ATC level: " &
888 ATC_Level
'Image (Self_Id
.ATC_Nesting_Level
), 'A'));
889 Entry_Call
:= Self_Id
.Entry_Calls
(Self_Id
.ATC_Nesting_Level
)'Access;
890 Entry_Call
.Next
:= null;
891 Entry_Call
.Mode
:= Timed_Call
;
892 Entry_Call
.Cancellation_Attempted
:= False;
895 (if Self_Id
.Deferral_Level
> 1
899 Entry_Call
.E
:= Entry_Index
(E
);
900 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_Id
);
901 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
902 Entry_Call
.Called_PO
:= To_Address
(Object
);
903 Entry_Call
.Called_Task
:= null;
904 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
905 Entry_Call
.With_Abort
:= True;
907 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
);
908 PO_Service_Entries
(Self_Id
, Object
);
909 STPO
.Write_Lock
(Self_Id
);
911 -- Try to avoid waiting for completed or cancelled calls
913 if Entry_Call
.State
>= Done
then
914 Utilities
.Exit_One_ATC_Level
(Self_Id
);
915 STPO
.Unlock
(Self_Id
);
917 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
918 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
919 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
923 Entry_Calls
.Wait_For_Completion_With_Timeout
924 (Entry_Call
, Timeout
, Mode
, Yielded
);
925 STPO
.Unlock
(Self_Id
);
927 -- ??? Do we need to yield in case Yielded is False
929 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
930 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
931 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
932 end Timed_Protected_Entry_Call
;
934 ----------------------------
935 -- Update_For_Queue_To_PO --
936 ----------------------------
938 -- Update the state of an existing entry call, based on
939 -- whether the current queuing action is with or without abort.
940 -- Call this only while holding the server's lock.
941 -- It returns with the server's lock released.
943 New_State
: constant array (Boolean, Entry_Call_State
)
944 of Entry_Call_State
:=
946 (Never_Abortable
=> Never_Abortable
,
947 Not_Yet_Abortable
=> Now_Abortable
,
948 Was_Abortable
=> Now_Abortable
,
949 Now_Abortable
=> Now_Abortable
,
951 Cancelled
=> Cancelled
),
953 (Never_Abortable
=> Never_Abortable
,
954 Not_Yet_Abortable
=> Not_Yet_Abortable
,
955 Was_Abortable
=> Was_Abortable
,
956 Now_Abortable
=> Now_Abortable
,
958 Cancelled
=> Cancelled
)
961 procedure Update_For_Queue_To_PO
962 (Entry_Call
: Entry_Call_Link
;
963 With_Abort
: Boolean)
965 Old
: constant Entry_Call_State
:= Entry_Call
.State
;
968 pragma Assert
(Old
< Done
);
970 Entry_Call
.State
:= New_State
(With_Abort
, Entry_Call
.State
);
972 if Entry_Call
.Mode
= Asynchronous_Call
then
973 if Old
< Was_Abortable
and then
974 Entry_Call
.State
= Now_Abortable
976 STPO
.Write_Lock
(Entry_Call
.Self
);
978 if Entry_Call
.Self
.Common
.State
= Async_Select_Sleep
then
979 STPO
.Wakeup
(Entry_Call
.Self
, Async_Select_Sleep
);
982 STPO
.Unlock
(Entry_Call
.Self
);
985 elsif Entry_Call
.Mode
= Conditional_Call
then
986 pragma Assert
(Entry_Call
.State
< Was_Abortable
);
989 end Update_For_Queue_To_PO
;
991 end System
.Tasking
.Protected_Objects
.Operations
;