1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
9 -- Copyright (C) 1998-2016, 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
;
262 if not ZCX_By_Default
then
263 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
267 (Entry_Call
.Self
.Common
.Compiler_Data
.Current_Excep
'Access,
268 Self_Id
.Common
.Compiler_Data
.Current_Excep
);
271 -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
272 -- PO_Service_Entries on return.
276 if Runtime_Traces
then
278 -- ??? Entry_Call can be null
280 Send_Trace_Info
(PO_Done
, Entry_Call
.Self
);
282 end Exceptional_Complete_Entry_Body
;
288 procedure PO_Do_Or_Queue
290 Object
: Protection_Entries_Access
;
291 Entry_Call
: Entry_Call_Link
)
293 E
: constant Protected_Entry_Index
:=
294 Protected_Entry_Index
(Entry_Call
.E
);
295 Barrier_Value
: Boolean;
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.
303 Object
.Entry_Bodies
(
304 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).
305 Barrier
(Object
.Compiler_Info
, E
);
307 if Barrier_Value
then
309 -- Not abortable while service is in progress
311 if Entry_Call
.State
= Now_Abortable
then
312 Entry_Call
.State
:= Was_Abortable
;
315 Object
.Call_In_Progress
:= Entry_Call
;
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
);
323 if Object
.Call_In_Progress
/= null then
325 -- Body of current entry served call to completion
327 Object
.Call_In_Progress
:= null;
333 STPO
.Write_Lock
(Entry_Call
.Self
);
334 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
335 STPO
.Unlock
(Entry_Call
.Self
);
342 Requeue_Call
(Self_ID
, Object
, Entry_Call
);
345 elsif Entry_Call
.Mode
/= Conditional_Call
346 or else not Entry_Call
.With_Abort
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
))
352 -- This violates the Max_Entry_Queue_Length restriction, raise
355 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
361 STPO
.Write_Lock
(Entry_Call
.Self
);
362 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
363 STPO
.Unlock
(Entry_Call
.Self
);
369 Queuing
.Enqueue
(Object
.Entry_Queues
(E
), Entry_Call
);
370 Update_For_Queue_To_PO
(Entry_Call
, Entry_Call
.With_Abort
);
373 -- Conditional_Call and With_Abort
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
);
391 Queuing
.Broadcast_Program_Error
(Self_ID
, Object
, Entry_Call
);
394 ------------------------
395 -- PO_Service_Entries --
396 ------------------------
398 procedure PO_Service_Entries
400 Object
: Entries
.Protection_Entries_Access
;
401 Unlock_Object
: Boolean := True)
403 E
: Protected_Entry_Index
;
405 Entry_Call
: Entry_Call_Link
;
409 Queuing
.Select_Protected_Entry_Call
(Self_ID
, Object
, Entry_Call
);
411 exit when Entry_Call
= null;
413 E
:= Protected_Entry_Index
(Entry_Call
.E
);
415 -- Not abortable while service is in progress
417 if Entry_Call
.State
= Now_Abortable
then
418 Entry_Call
.State
:= Was_Abortable
;
421 Object
.Call_In_Progress
:= Entry_Call
;
424 if Runtime_Traces
then
425 Send_Trace_Info
(PO_Run
, Self_ID
,
426 Entry_Call
.Self
, Entry_Index
(E
));
430 (Debug
.Trace
(Self_ID
, "POSE: start entry body", 'P'));
433 (Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).Action
434 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
438 Queuing
.Broadcast_Program_Error
439 (Self_ID
, Object
, Entry_Call
);
442 if Object
.Call_In_Progress
= null then
443 Requeue_Call
(Self_ID
, Object
, Entry_Call
);
444 exit when Entry_Call
.State
= Cancelled
;
447 Object
.Call_In_Progress
:= null;
448 Caller
:= Entry_Call
.Self
;
454 STPO
.Write_Lock
(Caller
);
455 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
456 STPO
.Unlock
(Caller
);
464 if Unlock_Object
then
465 Unlock_Entries
(Object
);
467 end PO_Service_Entries
;
469 ---------------------
470 -- Protected_Count --
471 ---------------------
473 function Protected_Count
474 (Object
: Protection_Entries
'Class;
475 E
: Protected_Entry_Index
) return Natural
478 return Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
));
481 --------------------------
482 -- Protected_Entry_Call --
483 --------------------------
485 -- Compiler interface only (do not call from within the RTS)
494 -- X : protected_entry_index := 1;
495 -- B85b : communication_block;
496 -- communication_blockIP (B85b);
499 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
500 -- null_address, conditional_call, B85b, objectF => 0);
502 -- if cancelled (B85b) then
509 -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous
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
517 -- If this is a call made inside of an abort deferred region, the call
518 -- should be never abortable.
520 -- If the call was not queued abortably, we need to wait until it is before
521 -- proceeding with the abortable part.
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.
528 -- Another heuristic uses the Block.Enqueued to try to avoid calling
529 -- Cancel_Protected_Entry_Call if the call can be served immediately.
531 procedure Protected_Entry_Call
532 (Object
: Protection_Entries_Access
;
533 E
: Protected_Entry_Index
;
534 Uninterpreted_Data
: System
.Address
;
536 Block
: out Communication_Block
)
538 Self_ID
: constant Task_Id
:= STPO
.Self
;
539 Entry_Call
: Entry_Call_Link
;
540 Initially_Abortable
: Boolean;
541 Ceiling_Violation
: Boolean;
545 (Debug
.Trace
(Self_ID
, "Protected_Entry_Call", 'P'));
547 if Runtime_Traces
then
548 Send_Trace_Info
(PO_Call
, Entry_Index
(E
));
551 if Self_ID
.ATC_Nesting_Level
= ATC_Level
'Last then
552 raise Storage_Error
with "not enough ATC nesting levels";
555 -- If pragma Detect_Blocking is active then Program_Error must be
556 -- raised if this potentially blocking operation is called from a
560 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
562 raise Program_Error
with "potentially blocking operation";
565 -- Self_ID.Deferral_Level should be 0, except when called from Finalize,
566 -- where abort is already deferred.
568 Initialization
.Defer_Abort_Nestable
(Self_ID
);
569 Lock_Entries_With_Status
(Object
, Ceiling_Violation
);
571 if Ceiling_Violation
then
573 -- Failed ceiling check
575 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
579 Block
.Self
:= Self_ID
;
580 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
+ 1;
582 (Debug
.Trace
(Self_ID
, "PEC: entered ATC level: " &
583 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
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;
591 (if Self_ID
.Deferral_Level
> 1
592 then Never_Abortable
else Now_Abortable
);
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;
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
);
606 -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
607 -- for completed or cancelled calls. (This is a heuristic, only.)
609 if Entry_Call
.State
>= Done
then
611 -- Once State >= Done it will not change any more
617 STPO
.Write_Lock
(Self_ID
);
618 Utilities
.Exit_One_ATC_Level
(Self_ID
);
619 STPO
.Unlock
(Self_ID
);
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
);
632 -- In this case we cannot conclude anything, since State can change
638 -- Now for the general case
640 if Mode
= Asynchronous_Call
then
642 -- Try to avoid an expensive call
644 if not Initially_Abortable
then
647 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
650 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
656 when Simple_Call | Conditional_Call
=>
659 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
663 STPO
.Write_Lock
(Self_ID
);
664 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
665 STPO
.Unlock
(Self_ID
);
668 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
670 when Asynchronous_Call | Timed_Call
=>
671 pragma Assert
(False);
676 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
677 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
678 end Protected_Entry_Call
;
684 procedure Requeue_Call
686 Object
: Protection_Entries_Access
;
687 Entry_Call
: Entry_Call_Link
)
689 New_Object
: Protection_Entries_Access
;
690 Ceiling_Violation
: Boolean;
692 E
: Protected_Entry_Index
;
695 New_Object
:= To_Protection
(Entry_Call
.Called_PO
);
697 if New_Object
= null then
699 -- Call is to be requeued to a task entry
705 Result
:= Rendezvous
.Task_Do_Or_Queue
(Self_Id
, Entry_Call
);
708 Queuing
.Broadcast_Program_Error
709 (Self_Id
, Object
, Entry_Call
, RTS_Locked
=> True);
717 -- Call should be requeued to a PO
719 if Object
/= New_Object
then
721 -- Requeue is to different PO
723 Lock_Entries_With_Status
(New_Object
, Ceiling_Violation
);
725 if Ceiling_Violation
then
726 Object
.Call_In_Progress
:= null;
727 Queuing
.Broadcast_Program_Error
(Self_Id
, Object
, Entry_Call
);
730 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
);
731 PO_Service_Entries
(Self_Id
, New_Object
);
735 -- Requeue is to same protected object
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
741 STPO
.Yield
(Do_Yield
=> False);
743 if Entry_Call
.With_Abort
744 and then Entry_Call
.Cancellation_Attempted
746 -- If this is a requeue with abort and someone tried to cancel
747 -- this call, cancel it at this point.
749 Entry_Call
.State
:= Cancelled
;
753 if not Entry_Call
.With_Abort
754 or else Entry_Call
.Mode
/= Conditional_Call
756 E
:= Protected_Entry_Index
(Entry_Call
.E
);
758 if Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
760 Run_Time_Restrictions
.Value
(Max_Entry_Queue_Length
) <=
761 Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
))
763 -- This violates the Max_Entry_Queue_Length restriction,
764 -- raise Program_Error.
766 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
772 STPO
.Write_Lock
(Entry_Call
.Self
);
773 Initialization
.Wakeup_Entry_Caller
774 (Self_Id
, Entry_Call
, Done
);
775 STPO
.Unlock
(Entry_Call
.Self
);
783 (New_Object
.Entry_Queues
(E
), Entry_Call
);
784 Update_For_Queue_To_PO
(Entry_Call
, Entry_Call
.With_Abort
);
788 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
);
794 ----------------------------
795 -- Protected_Entry_Caller --
796 ----------------------------
798 function Protected_Entry_Caller
799 (Object
: Protection_Entries
'Class) return Task_Id
is
801 return Object
.Call_In_Progress
.Self
;
802 end Protected_Entry_Caller
;
804 -----------------------------
805 -- Requeue_Protected_Entry --
806 -----------------------------
808 -- Compiler interface only (do not call from within the RTS)
817 -- procedure rPT__E10b (O : address; P : address; E :
818 -- protected_entry_index) is
819 -- type rTVP is access rTV;
821 -- _object : rTVP := rTVP!(O);
824 -- rR : protection renames _object._object;
825 -- vP : integer renames _object.v;
826 -- bP : boolean renames _object.b;
830 -- requeue_protected_entry (rR'unchecked_access, rR'
831 -- unchecked_access, 2, false, objectF => 0, new_objectF =>
835 -- complete_entry_body (_object._object'unchecked_access, objectF =>
840 -- abort_undefer.all;
841 -- exceptional_complete_entry_body (_object._object'
842 -- unchecked_access, current_exception, objectF => 0);
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)
852 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
856 (Debug
.Trace
(STPO
.Self
, "Requeue_Protected_Entry", 'P'));
857 pragma Assert
(STPO
.Self
.Deferral_Level
> 0);
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
;
866 -------------------------------------
867 -- Requeue_Task_To_Protected_Entry --
868 -------------------------------------
870 -- Compiler interface only (do not call from within the RTS)
881 -- accept_call (1, A79b);
883 -- requeue_task_to_protected_entry (rTV!(r)._object'
884 -- unchecked_access, 2, false, new_objectF => 0);
887 -- complete_rendezvous;
890 -- when all others =>
891 -- exceptional_complete_rendezvous (get_gnat_exception);
894 procedure Requeue_Task_To_Protected_Entry
895 (New_Object
: Protection_Entries_Access
;
896 E
: Protected_Entry_Index
;
897 With_Abort
: Boolean)
899 Self_ID
: constant Task_Id
:= STPO
.Self
;
900 Entry_Call
: constant Entry_Call_Link
:= Self_ID
.Common
.Call
;
903 Initialization
.Defer_Abort
(Self_ID
);
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.
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
;
916 ---------------------
917 -- Service_Entries --
918 ---------------------
920 procedure Service_Entries
(Object
: Protection_Entries_Access
) is
921 Self_ID
: constant Task_Id
:= STPO
.Self
;
923 PO_Service_Entries
(Self_ID
, Object
);
926 --------------------------------
927 -- Timed_Protected_Entry_Call --
928 --------------------------------
930 -- Compiler interface only (do not call from within the RTS)
932 procedure Timed_Protected_Entry_Call
933 (Object
: Protection_Entries_Access
;
934 E
: Protected_Entry_Index
;
935 Uninterpreted_Data
: System
.Address
;
938 Entry_Call_Successful
: out Boolean)
940 Self_Id
: constant Task_Id
:= STPO
.Self
;
941 Entry_Call
: Entry_Call_Link
;
942 Ceiling_Violation
: Boolean;
945 pragma Unreferenced
(Yielded
);
948 if Self_Id
.ATC_Nesting_Level
= ATC_Level
'Last then
949 raise Storage_Error
with "not enough ATC nesting levels";
952 -- If pragma Detect_Blocking is active then Program_Error must be
953 -- raised if this potentially blocking operation is called from a
957 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
959 raise Program_Error
with "potentially blocking operation";
962 if Runtime_Traces
then
963 Send_Trace_Info
(POT_Call
, Entry_Index
(E
), Timeout
);
966 Initialization
.Defer_Abort_Nestable
(Self_Id
);
967 Lock_Entries_With_Status
(Object
, Ceiling_Violation
);
969 if Ceiling_Violation
then
970 Initialization
.Undefer_Abort
(Self_Id
);
974 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
+ 1;
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;
984 (if Self_Id
.Deferral_Level
> 1
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;
996 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
);
997 PO_Service_Entries
(Self_Id
, Object
);
1002 STPO
.Write_Lock
(Self_Id
);
1005 -- Try to avoid waiting for completed or cancelled calls
1007 if Entry_Call
.State
>= Done
then
1008 Utilities
.Exit_One_ATC_Level
(Self_Id
);
1013 STPO
.Unlock
(Self_Id
);
1016 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
1017 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
1018 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
1022 Entry_Calls
.Wait_For_Completion_With_Timeout
1023 (Entry_Call
, Timeout
, Mode
, Yielded
);
1028 STPO
.Unlock
(Self_Id
);
1031 -- ??? Do we need to yield in case Yielded is False
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
;
1038 ----------------------------
1039 -- Update_For_Queue_To_PO --
1040 ----------------------------
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.
1047 New_State
: constant array (Boolean, Entry_Call_State
)
1048 of Entry_Call_State
:=
1050 (Never_Abortable
=> Never_Abortable
,
1051 Not_Yet_Abortable
=> Now_Abortable
,
1052 Was_Abortable
=> Now_Abortable
,
1053 Now_Abortable
=> Now_Abortable
,
1055 Cancelled
=> Cancelled
),
1057 (Never_Abortable
=> Never_Abortable
,
1058 Not_Yet_Abortable
=> Not_Yet_Abortable
,
1059 Was_Abortable
=> Was_Abortable
,
1060 Now_Abortable
=> Now_Abortable
,
1062 Cancelled
=> Cancelled
)
1065 procedure Update_For_Queue_To_PO
1066 (Entry_Call
: Entry_Call_Link
;
1067 With_Abort
: Boolean)
1069 Old
: constant Entry_Call_State
:= Entry_Call
.State
;
1072 pragma Assert
(Old
< Done
);
1074 Entry_Call
.State
:= New_State
(With_Abort
, Entry_Call
.State
);
1076 if Entry_Call
.Mode
= Asynchronous_Call
then
1077 if Old
< Was_Abortable
and then
1078 Entry_Call
.State
= Now_Abortable
1084 STPO
.Write_Lock
(Entry_Call
.Self
);
1086 if Entry_Call
.Self
.Common
.State
= Async_Select_Sleep
then
1087 STPO
.Wakeup
(Entry_Call
.Self
, Async_Select_Sleep
);
1090 STPO
.Unlock
(Entry_Call
.Self
);
1098 elsif Entry_Call
.Mode
= Conditional_Call
then
1099 pragma Assert
(Entry_Call
.State
< Was_Abortable
);
1102 end Update_For_Queue_To_PO
;
1104 end System
.Tasking
.Protected_Objects
.Operations
;