1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
9 -- Copyright (C) 1998-2010, 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
.Parameters
;
52 with System
.Traces
.Tasking
;
53 with System
.Restrictions
;
55 with System
.Tasking
.Initialization
;
56 pragma Elaborate_All
(System
.Tasking
.Initialization
);
57 -- Insures that tasking is initialized if any protected objects are created
59 package body System
.Tasking
.Protected_Objects
.Operations
is
61 package STPO
renames System
.Task_Primitives
.Operations
;
68 use System
.Restrictions
;
69 use System
.Restrictions
.Rident
;
71 use System
.Traces
.Tasking
;
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
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.
86 procedure Requeue_Call
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
94 ---------------------------------
95 -- Cancel_Protected_Entry_Call --
96 ---------------------------------
98 -- Compiler interface only (do not call from within the RTS)
100 -- This should have analogous effect to Cancel_Task_Entry_Call, setting
101 -- the value of Block.Cancelled instead of returning the parameter value
104 -- The effect should be idempotent, since the call may already have been
118 -- X : protected_entry_index := 1;
119 -- B80b : communication_block;
120 -- communication_blockIP (B80b);
126 -- procedure _clean is
128 -- if enqueued (B80b) then
129 -- cancel_protected_entry_call (B80b);
135 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
136 -- null_address, asynchronous_call, B80b, objectF => 0);
137 -- if enqueued (B80b) then
145 -- when _abort_signal =>
146 -- abort_undefer.all;
150 -- if not cancelled (B80b) then
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.
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.
163 -- If the abortable part completes before the entry call is Done, it will
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.
169 -- Whoever calls _clean first gets to decide whether the call
170 -- has been "cancelled".
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.
176 -- Cancelled should be true iff the abortable part completed
177 -- and succeeded in cancelling the entry call before it completed.
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.
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.
192 procedure Cancel_Protected_Entry_Call
193 (Block
: in out Communication_Block
) is
195 Entry_Calls
.Try_To_Cancel_Entry_Call
(Block
.Cancelled
);
196 end Cancel_Protected_Entry_Call
;
202 function Cancelled
(Block
: Communication_Block
) return Boolean is
204 return Block
.Cancelled
;
207 -------------------------
208 -- Complete_Entry_Body --
209 -------------------------
211 procedure Complete_Entry_Body
(Object
: Protection_Entries_Access
) is
213 Exceptional_Complete_Entry_Body
(Object
, Ada
.Exceptions
.Null_Id
);
214 end Complete_Entry_Body
;
220 function Enqueued
(Block
: Communication_Block
) return Boolean is
222 return Block
.Enqueued
;
225 -------------------------------------
226 -- Exceptional_Complete_Entry_Body --
227 -------------------------------------
229 procedure Exceptional_Complete_Entry_Body
230 (Object
: Protection_Entries_Access
;
231 Ex
: Ada
.Exceptions
.Exception_Id
)
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");
238 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
243 (Debug
.Trace
(STPO
.Self
, "Exceptional_Complete_Entry_Body", 'P'));
245 -- We must have abort deferred, since we are inside a protected
248 if Entry_Call
/= null then
250 -- The call was not requeued
252 Entry_Call
.Exception_To_Raise
:= Ex
;
254 if Ex
/= Ada
.Exceptions
.Null_Id
then
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.
260 Self_Id
:= STPO
.Self
;
261 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
263 (Entry_Call
.Self
.Common
.Compiler_Data
.Current_Excep
'Access,
264 Self_Id
.Common
.Compiler_Data
.Current_Excep
);
267 -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
268 -- PO_Service_Entries on return.
272 if Runtime_Traces
then
273 Send_Trace_Info
(PO_Done
, Entry_Call
.Self
);
275 end Exceptional_Complete_Entry_Body
;
281 procedure PO_Do_Or_Queue
283 Object
: Protection_Entries_Access
;
284 Entry_Call
: Entry_Call_Link
)
286 E
: constant Protected_Entry_Index
:=
287 Protected_Entry_Index
(Entry_Call
.E
);
288 Barrier_Value
: Boolean;
291 -- When the Action procedure for an entry body returns, it is either
292 -- completed (having called [Exceptional_]Complete_Entry_Body) or it
293 -- is queued, having executed a requeue statement.
296 Object
.Entry_Bodies
(
297 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).
298 Barrier
(Object
.Compiler_Info
, E
);
300 if Barrier_Value
then
302 -- Not abortable while service is in progress
304 if Entry_Call
.State
= Now_Abortable
then
305 Entry_Call
.State
:= Was_Abortable
;
308 Object
.Call_In_Progress
:= Entry_Call
;
311 (Debug
.Trace
(Self_ID
, "PODOQ: start entry body", 'P'));
312 Object
.Entry_Bodies
(
313 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).Action
(
314 Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
316 if Object
.Call_In_Progress
/= null then
318 -- Body of current entry served call to completion
320 Object
.Call_In_Progress
:= null;
326 STPO
.Write_Lock
(Entry_Call
.Self
);
327 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
328 STPO
.Unlock
(Entry_Call
.Self
);
335 Requeue_Call
(Self_ID
, Object
, Entry_Call
);
338 elsif Entry_Call
.Mode
/= Conditional_Call
339 or else not Entry_Call
.With_Abort
342 if Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
344 Run_Time_Restrictions
.Value
(Max_Entry_Queue_Length
) <=
345 Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
))
347 -- This violates the Max_Entry_Queue_Length restriction,
348 -- raise Program_Error.
350 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
356 STPO
.Write_Lock
(Entry_Call
.Self
);
357 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
358 STPO
.Unlock
(Entry_Call
.Self
);
364 Queuing
.Enqueue
(Object
.Entry_Queues
(E
), Entry_Call
);
365 Update_For_Queue_To_PO
(Entry_Call
, Entry_Call
.With_Abort
);
368 -- Conditional_Call and With_Abort
374 STPO
.Write_Lock
(Entry_Call
.Self
);
375 pragma Assert
(Entry_Call
.State
>= Was_Abortable
);
376 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Cancelled
);
377 STPO
.Unlock
(Entry_Call
.Self
);
386 Queuing
.Broadcast_Program_Error
(Self_ID
, Object
, Entry_Call
);
389 ------------------------
390 -- PO_Service_Entries --
391 ------------------------
393 procedure PO_Service_Entries
395 Object
: Entries
.Protection_Entries_Access
;
396 Unlock_Object
: Boolean := True)
398 E
: Protected_Entry_Index
;
400 Entry_Call
: Entry_Call_Link
;
404 Queuing
.Select_Protected_Entry_Call
(Self_ID
, Object
, Entry_Call
);
406 exit when Entry_Call
= null;
408 E
:= Protected_Entry_Index
(Entry_Call
.E
);
410 -- Not abortable while service is in progress
412 if Entry_Call
.State
= Now_Abortable
then
413 Entry_Call
.State
:= Was_Abortable
;
416 Object
.Call_In_Progress
:= Entry_Call
;
419 if Runtime_Traces
then
420 Send_Trace_Info
(PO_Run
, Self_ID
,
421 Entry_Call
.Self
, Entry_Index
(E
));
425 (Debug
.Trace
(Self_ID
, "POSE: start entry body", 'P'));
428 (Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).Action
429 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
433 Queuing
.Broadcast_Program_Error
434 (Self_ID
, Object
, Entry_Call
);
437 if Object
.Call_In_Progress
= null then
438 Requeue_Call
(Self_ID
, Object
, Entry_Call
);
439 exit when Entry_Call
.State
= Cancelled
;
442 Object
.Call_In_Progress
:= null;
443 Caller
:= Entry_Call
.Self
;
449 STPO
.Write_Lock
(Caller
);
450 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
451 STPO
.Unlock
(Caller
);
459 if Unlock_Object
then
460 Unlock_Entries
(Object
);
462 end PO_Service_Entries
;
464 ---------------------
465 -- Protected_Count --
466 ---------------------
468 function Protected_Count
469 (Object
: Protection_Entries
'Class;
470 E
: Protected_Entry_Index
) return Natural
473 return Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
));
476 --------------------------
477 -- Protected_Entry_Call --
478 --------------------------
480 -- Compiler interface only (do not call from within the RTS)
489 -- X : protected_entry_index := 1;
490 -- B85b : communication_block;
491 -- communication_blockIP (B85b);
494 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
495 -- null_address, conditional_call, B85b, objectF => 0);
497 -- if cancelled (B85b) then
504 -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous
507 -- The initial part of this procedure does not need to lock the calling
508 -- task's ATCB, up to the point where the call record first may be queued
509 -- (PO_Do_Or_Queue), since before that no other task will have access to
512 -- If this is a call made inside of an abort deferred region, the call
513 -- should be never abortable.
515 -- If the call was not queued abortably, we need to wait until it is before
516 -- proceeding with the abortable part.
518 -- There are some heuristics here, just to save time for frequently
519 -- occurring cases. For example, we check Initially_Abortable to try to
520 -- avoid calling the procedure Wait_Until_Abortable, since the normal case
521 -- for async. entry calls is to be queued abortably.
523 -- Another heuristic uses the Block.Enqueued to try to avoid calling
524 -- Cancel_Protected_Entry_Call if the call can be served immediately.
526 procedure Protected_Entry_Call
527 (Object
: Protection_Entries_Access
;
528 E
: Protected_Entry_Index
;
529 Uninterpreted_Data
: System
.Address
;
531 Block
: out Communication_Block
)
533 Self_ID
: constant Task_Id
:= STPO
.Self
;
534 Entry_Call
: Entry_Call_Link
;
535 Initially_Abortable
: Boolean;
536 Ceiling_Violation
: Boolean;
540 (Debug
.Trace
(Self_ID
, "Protected_Entry_Call", 'P'));
542 if Runtime_Traces
then
543 Send_Trace_Info
(PO_Call
, Entry_Index
(E
));
546 if Self_ID
.ATC_Nesting_Level
= ATC_Level
'Last then
547 raise Storage_Error
with "not enough ATC nesting levels";
550 -- If pragma Detect_Blocking is active then Program_Error must be
551 -- raised if this potentially blocking operation is called from a
555 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
557 raise Program_Error
with "potentially blocking operation";
560 -- Self_ID.Deferral_Level should be 0, except when called from Finalize,
561 -- where abort is already deferred.
563 Initialization
.Defer_Abort_Nestable
(Self_ID
);
564 Lock_Entries
(Object
, Ceiling_Violation
);
566 if Ceiling_Violation
then
568 -- Failed ceiling check
570 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
574 Block
.Self
:= Self_ID
;
575 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
+ 1;
577 (Debug
.Trace
(Self_ID
, "PEC: entered ATC level: " &
578 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
580 Self_ID
.Entry_Calls
(Self_ID
.ATC_Nesting_Level
)'Access;
581 Entry_Call
.Next
:= null;
582 Entry_Call
.Mode
:= Mode
;
583 Entry_Call
.Cancellation_Attempted
:= False;
586 (if Self_ID
.Deferral_Level
> 1
587 then Never_Abortable
else Now_Abortable
);
589 Entry_Call
.E
:= Entry_Index
(E
);
590 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_ID
);
591 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
592 Entry_Call
.Called_PO
:= To_Address
(Object
);
593 Entry_Call
.Called_Task
:= null;
594 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
595 Entry_Call
.With_Abort
:= True;
597 PO_Do_Or_Queue
(Self_ID
, Object
, Entry_Call
);
598 Initially_Abortable
:= Entry_Call
.State
= Now_Abortable
;
599 PO_Service_Entries
(Self_ID
, Object
);
601 -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
602 -- for completed or cancelled calls. (This is a heuristic, only.)
604 if Entry_Call
.State
>= Done
then
606 -- Once State >= Done it will not change any more
612 STPO
.Write_Lock
(Self_ID
);
613 Utilities
.Exit_One_ATC_Level
(Self_ID
);
614 STPO
.Unlock
(Self_ID
);
620 Block
.Enqueued
:= False;
621 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
622 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
623 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
627 -- In this case we cannot conclude anything, since State can change
633 -- Now for the general case
635 if Mode
= Asynchronous_Call
then
637 -- Try to avoid an expensive call
639 if not Initially_Abortable
then
642 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
645 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
651 when Simple_Call | Conditional_Call
=>
654 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
658 STPO
.Write_Lock
(Self_ID
);
659 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
660 STPO
.Unlock
(Self_ID
);
663 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
665 when Asynchronous_Call | Timed_Call
=>
666 pragma Assert
(False);
671 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
672 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
673 end Protected_Entry_Call
;
679 procedure Requeue_Call
681 Object
: Protection_Entries_Access
;
682 Entry_Call
: Entry_Call_Link
)
684 New_Object
: Protection_Entries_Access
;
685 Ceiling_Violation
: Boolean;
687 E
: Protected_Entry_Index
;
690 New_Object
:= To_Protection
(Entry_Call
.Called_PO
);
692 if New_Object
= null then
694 -- Call is to be requeued to a task entry
700 Result
:= Rendezvous
.Task_Do_Or_Queue
(Self_Id
, Entry_Call
);
703 Queuing
.Broadcast_Program_Error
704 (Self_Id
, Object
, Entry_Call
, RTS_Locked
=> True);
712 -- Call should be requeued to a PO
714 if Object
/= New_Object
then
716 -- Requeue is to different PO
718 Lock_Entries
(New_Object
, Ceiling_Violation
);
720 if Ceiling_Violation
then
721 Object
.Call_In_Progress
:= null;
722 Queuing
.Broadcast_Program_Error
(Self_Id
, Object
, Entry_Call
);
725 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
);
726 PO_Service_Entries
(Self_Id
, New_Object
);
730 -- Requeue is to same protected object
732 -- ??? Try to compensate apparent failure of the scheduler on some
733 -- OS (e.g VxWorks) to give higher priority tasks a chance to run
738 if Entry_Call
.With_Abort
739 and then Entry_Call
.Cancellation_Attempted
741 -- If this is a requeue with abort and someone tried to cancel
742 -- this call, cancel it at this point.
744 Entry_Call
.State
:= Cancelled
;
748 if not Entry_Call
.With_Abort
749 or else Entry_Call
.Mode
/= Conditional_Call
751 E
:= Protected_Entry_Index
(Entry_Call
.E
);
753 if Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
755 Run_Time_Restrictions
.Value
(Max_Entry_Queue_Length
) <=
756 Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
))
758 -- This violates the Max_Entry_Queue_Length restriction,
759 -- raise Program_Error.
761 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
767 STPO
.Write_Lock
(Entry_Call
.Self
);
768 Initialization
.Wakeup_Entry_Caller
769 (Self_Id
, Entry_Call
, Done
);
770 STPO
.Unlock
(Entry_Call
.Self
);
778 (New_Object
.Entry_Queues
(E
), Entry_Call
);
779 Update_For_Queue_To_PO
(Entry_Call
, Entry_Call
.With_Abort
);
783 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
);
789 ----------------------------
790 -- Protected_Entry_Caller --
791 ----------------------------
793 function Protected_Entry_Caller
794 (Object
: Protection_Entries
'Class) return Task_Id
is
796 return Object
.Call_In_Progress
.Self
;
797 end Protected_Entry_Caller
;
799 -----------------------------
800 -- Requeue_Protected_Entry --
801 -----------------------------
803 -- Compiler interface only (do not call from within the RTS)
812 -- procedure rPT__E10b (O : address; P : address; E :
813 -- protected_entry_index) is
814 -- type rTVP is access rTV;
816 -- _object : rTVP := rTVP!(O);
819 -- rR : protection renames _object._object;
820 -- vP : integer renames _object.v;
821 -- bP : boolean renames _object.b;
825 -- requeue_protected_entry (rR'unchecked_access, rR'
826 -- unchecked_access, 2, false, objectF => 0, new_objectF =>
830 -- complete_entry_body (_object._object'unchecked_access, objectF =>
835 -- abort_undefer.all;
836 -- exceptional_complete_entry_body (_object._object'
837 -- unchecked_access, current_exception, objectF => 0);
841 procedure Requeue_Protected_Entry
842 (Object
: Protection_Entries_Access
;
843 New_Object
: Protection_Entries_Access
;
844 E
: Protected_Entry_Index
;
845 With_Abort
: Boolean)
847 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
851 (Debug
.Trace
(STPO
.Self
, "Requeue_Protected_Entry", 'P'));
852 pragma Assert
(STPO
.Self
.Deferral_Level
> 0);
854 Entry_Call
.E
:= Entry_Index
(E
);
855 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
856 Entry_Call
.Called_Task
:= null;
857 Entry_Call
.With_Abort
:= With_Abort
;
858 Object
.Call_In_Progress
:= null;
859 end Requeue_Protected_Entry
;
861 -------------------------------------
862 -- Requeue_Task_To_Protected_Entry --
863 -------------------------------------
865 -- Compiler interface only (do not call from within the RTS)
876 -- accept_call (1, A79b);
878 -- requeue_task_to_protected_entry (rTV!(r)._object'
879 -- unchecked_access, 2, false, new_objectF => 0);
882 -- complete_rendezvous;
885 -- when all others =>
886 -- exceptional_complete_rendezvous (get_gnat_exception);
889 procedure Requeue_Task_To_Protected_Entry
890 (New_Object
: Protection_Entries_Access
;
891 E
: Protected_Entry_Index
;
892 With_Abort
: Boolean)
894 Self_ID
: constant Task_Id
:= STPO
.Self
;
895 Entry_Call
: constant Entry_Call_Link
:= Self_ID
.Common
.Call
;
898 Initialization
.Defer_Abort
(Self_ID
);
900 -- We do not need to lock Self_ID here since the call is not abortable
901 -- at this point, and therefore, the caller cannot cancel the call.
903 Entry_Call
.Needs_Requeue
:= True;
904 Entry_Call
.With_Abort
:= With_Abort
;
905 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
906 Entry_Call
.Called_Task
:= null;
907 Entry_Call
.E
:= Entry_Index
(E
);
908 Initialization
.Undefer_Abort
(Self_ID
);
909 end Requeue_Task_To_Protected_Entry
;
911 ---------------------
912 -- Service_Entries --
913 ---------------------
915 procedure Service_Entries
(Object
: Protection_Entries_Access
) is
916 Self_ID
: constant Task_Id
:= STPO
.Self
;
918 PO_Service_Entries
(Self_ID
, Object
);
921 --------------------------------
922 -- Timed_Protected_Entry_Call --
923 --------------------------------
925 -- Compiler interface only (do not call from within the RTS)
927 procedure Timed_Protected_Entry_Call
928 (Object
: Protection_Entries_Access
;
929 E
: Protected_Entry_Index
;
930 Uninterpreted_Data
: System
.Address
;
933 Entry_Call_Successful
: out Boolean)
935 Self_Id
: constant Task_Id
:= STPO
.Self
;
936 Entry_Call
: Entry_Call_Link
;
937 Ceiling_Violation
: Boolean;
940 pragma Unreferenced
(Yielded
);
943 if Self_Id
.ATC_Nesting_Level
= ATC_Level
'Last then
944 raise Storage_Error
with "not enough ATC nesting levels";
947 -- If pragma Detect_Blocking is active then Program_Error must be
948 -- raised if this potentially blocking operation is called from a
952 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
954 raise Program_Error
with "potentially blocking operation";
957 if Runtime_Traces
then
958 Send_Trace_Info
(POT_Call
, Entry_Index
(E
), Timeout
);
961 Initialization
.Defer_Abort_Nestable
(Self_Id
);
962 Lock_Entries
(Object
, Ceiling_Violation
);
964 if Ceiling_Violation
then
965 Initialization
.Undefer_Abort
(Self_Id
);
969 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
+ 1;
971 (Debug
.Trace
(Self_Id
, "TPEC: exited to ATC level: " &
972 ATC_Level
'Image (Self_Id
.ATC_Nesting_Level
), 'A'));
973 Entry_Call
:= Self_Id
.Entry_Calls
(Self_Id
.ATC_Nesting_Level
)'Access;
974 Entry_Call
.Next
:= null;
975 Entry_Call
.Mode
:= Timed_Call
;
976 Entry_Call
.Cancellation_Attempted
:= False;
979 (if Self_Id
.Deferral_Level
> 1
983 Entry_Call
.E
:= Entry_Index
(E
);
984 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_Id
);
985 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
986 Entry_Call
.Called_PO
:= To_Address
(Object
);
987 Entry_Call
.Called_Task
:= null;
988 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
989 Entry_Call
.With_Abort
:= True;
991 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
);
992 PO_Service_Entries
(Self_Id
, Object
);
997 STPO
.Write_Lock
(Self_Id
);
1000 -- Try to avoid waiting for completed or cancelled calls
1002 if Entry_Call
.State
>= Done
then
1003 Utilities
.Exit_One_ATC_Level
(Self_Id
);
1008 STPO
.Unlock
(Self_Id
);
1011 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
1012 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
1013 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
1017 Entry_Calls
.Wait_For_Completion_With_Timeout
1018 (Entry_Call
, Timeout
, Mode
, Yielded
);
1023 STPO
.Unlock
(Self_Id
);
1026 -- ??? Do we need to yield in case Yielded is False
1028 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
1029 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
1030 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
1031 end Timed_Protected_Entry_Call
;
1033 ----------------------------
1034 -- Update_For_Queue_To_PO --
1035 ----------------------------
1037 -- Update the state of an existing entry call, based on
1038 -- whether the current queuing action is with or without abort.
1039 -- Call this only while holding the server's lock.
1040 -- It returns with the server's lock released.
1042 New_State
: constant array (Boolean, Entry_Call_State
)
1043 of Entry_Call_State
:=
1045 (Never_Abortable
=> Never_Abortable
,
1046 Not_Yet_Abortable
=> Now_Abortable
,
1047 Was_Abortable
=> Now_Abortable
,
1048 Now_Abortable
=> Now_Abortable
,
1050 Cancelled
=> Cancelled
),
1052 (Never_Abortable
=> Never_Abortable
,
1053 Not_Yet_Abortable
=> Not_Yet_Abortable
,
1054 Was_Abortable
=> Was_Abortable
,
1055 Now_Abortable
=> Now_Abortable
,
1057 Cancelled
=> Cancelled
)
1060 procedure Update_For_Queue_To_PO
1061 (Entry_Call
: Entry_Call_Link
;
1062 With_Abort
: Boolean)
1064 Old
: constant Entry_Call_State
:= Entry_Call
.State
;
1067 pragma Assert
(Old
< Done
);
1069 Entry_Call
.State
:= New_State
(With_Abort
, Entry_Call
.State
);
1071 if Entry_Call
.Mode
= Asynchronous_Call
then
1072 if Old
< Was_Abortable
and then
1073 Entry_Call
.State
= Now_Abortable
1079 STPO
.Write_Lock
(Entry_Call
.Self
);
1081 if Entry_Call
.Self
.Common
.State
= Async_Select_Sleep
then
1082 STPO
.Wakeup
(Entry_Call
.Self
, Async_Select_Sleep
);
1085 STPO
.Unlock
(Entry_Call
.Self
);
1093 elsif Entry_Call
.Mode
= Conditional_Call
then
1094 pragma Assert
(Entry_Call
.State
< Was_Abortable
);
1097 end Update_For_Queue_To_PO
;
1099 end System
.Tasking
.Protected_Objects
.Operations
;