1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . --
6 -- O P E R A T I O N S --
10 -- Copyright (C) 1998-2006, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. --
31 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
33 ------------------------------------------------------------------------------
35 -- This package contains all the extended primitives related to
36 -- Protected_Objects with entries.
38 -- The handling of protected objects with no entries is done in
39 -- System.Tasking.Protected_Objects, the simple routines for protected
40 -- objects with entries in System.Tasking.Protected_Objects.Entries.
42 -- The split between Entries and Operations is needed to break circular
43 -- dependencies inside the run time.
45 -- This package contains all primitives related to Protected_Objects.
46 -- Note: the compiler generates direct calls to this interface, via Rtsfind.
48 with System
.Task_Primitives
.Operations
;
49 -- used for Initialize_Lock
55 with System
.Tasking
.Entry_Calls
;
56 -- used for Wait_For_Completion
57 -- Wait_Until_Abortable
58 -- Wait_For_Completion_With_Timeout
60 with System
.Tasking
.Initialization
;
61 -- Used for Defer_Abort,
63 -- Change_Base_Priority
65 pragma Elaborate_All
(System
.Tasking
.Initialization
);
66 -- This insures that tasking is initialized if any protected objects are
69 with System
.Tasking
.Queuing
;
71 -- Broadcast_Program_Error
72 -- Select_Protected_Entry_Call
76 with System
.Tasking
.Rendezvous
;
77 -- used for Task_Do_Or_Queue
79 with System
.Tasking
.Utilities
;
80 -- used for Exit_One_ATC_Level
82 with System
.Tasking
.Debug
;
85 with System
.Parameters
;
86 -- used for Single_Lock
89 with System
.Traces
.Tasking
;
90 -- used for Send_Trace_Info
92 with System
.Restrictions
;
93 -- used for Run_Time_Restrictions
95 package body System
.Tasking
.Protected_Objects
.Operations
is
97 package STPO
renames System
.Task_Primitives
.Operations
;
104 use System
.Restrictions
;
105 use System
.Restrictions
.Rident
;
107 use System
.Traces
.Tasking
;
109 -----------------------
110 -- Local Subprograms --
111 -----------------------
113 procedure Update_For_Queue_To_PO
114 (Entry_Call
: Entry_Call_Link
;
115 With_Abort
: Boolean);
116 pragma Inline
(Update_For_Queue_To_PO
);
117 -- Update the state of an existing entry call to reflect
118 -- the fact that it is being enqueued, based on
119 -- whether the current queuing action is with or without abort.
120 -- Call this only while holding the PO's lock.
121 -- It returns with the PO's lock still held.
123 procedure Requeue_Call
125 Object
: Protection_Entries_Access
;
126 Entry_Call
: Entry_Call_Link
;
127 With_Abort
: Boolean);
128 -- Handle requeue of Entry_Call.
129 -- In particular, queue the call if needed, or service it immediately
132 ---------------------------------
133 -- Cancel_Protected_Entry_Call --
134 ---------------------------------
136 -- Compiler interface only. Do not call from within the RTS.
137 -- This should have analogous effect to Cancel_Task_Entry_Call,
138 -- setting the value of Block.Cancelled instead of returning
139 -- the parameter value Cancelled.
141 -- The effect should be idempotent, since the call may already
142 -- have been dequeued.
155 -- X : protected_entry_index := 1;
156 -- B80b : communication_block;
157 -- communication_blockIP (B80b);
162 -- procedure _clean is
164 -- if enqueued (B80b) then
165 -- cancel_protected_entry_call (B80b);
170 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
171 -- null_address, asynchronous_call, B80b, objectF => 0);
172 -- if enqueued (B80b) then
179 -- when _abort_signal =>
180 -- abort_undefer.all;
183 -- if not cancelled (B80b) then
188 -- If the entry call completes after we get into the abortable part,
189 -- Abort_Signal should be raised and ATC will take us to the at-end
190 -- handler, which will call _clean.
192 -- If the entry call returns with the call already completed,
193 -- we can skip this, and use the "if enqueued()" to go past
194 -- the at-end handler, but we will still call _clean.
196 -- If the abortable part completes before the entry call is Done,
197 -- it will call _clean.
199 -- If the entry call or the abortable part raises an exception,
200 -- we will still call _clean, but the value of Cancelled should not matter.
202 -- Whoever calls _clean first gets to decide whether the call
203 -- has been "cancelled".
205 -- Enqueued should be true if there is any chance that the call
206 -- is still on a queue. It seems to be safe to make it True if
207 -- the call was Onqueue at some point before return from
208 -- Protected_Entry_Call.
210 -- Cancelled should be true iff the abortable part completed
211 -- and succeeded in cancelling the entry call before it completed.
214 -- The need for Enqueued is less obvious.
215 -- The "if enqueued ()" tests are not necessary, since both
216 -- Cancel_Protected_Entry_Call and Protected_Entry_Call must
217 -- do the same test internally, with locking. The one that
218 -- makes cancellation conditional may be a useful heuristic
219 -- since at least 1/2 the time the call should be off-queue
220 -- by that point. The other one seems totally useless, since
221 -- Protected_Entry_Call must do the same check and then
222 -- possibly wait for the call to be abortable, internally.
224 -- We can check Call.State here without locking the caller's mutex,
225 -- since the call must be over after returning from Wait_For_Completion.
226 -- No other task can access the call record at this point.
228 procedure Cancel_Protected_Entry_Call
229 (Block
: in out Communication_Block
) is
231 Entry_Calls
.Try_To_Cancel_Entry_Call
(Block
.Cancelled
);
232 end Cancel_Protected_Entry_Call
;
238 function Cancelled
(Block
: Communication_Block
) return Boolean is
240 return Block
.Cancelled
;
243 -------------------------
244 -- Complete_Entry_Body --
245 -------------------------
247 procedure Complete_Entry_Body
(Object
: Protection_Entries_Access
) is
249 Exceptional_Complete_Entry_Body
(Object
, Ada
.Exceptions
.Null_Id
);
250 end Complete_Entry_Body
;
256 function Enqueued
(Block
: Communication_Block
) return Boolean is
258 return Block
.Enqueued
;
261 -------------------------------------
262 -- Exceptional_Complete_Entry_Body --
263 -------------------------------------
265 procedure Exceptional_Complete_Entry_Body
266 (Object
: Protection_Entries_Access
;
267 Ex
: Ada
.Exceptions
.Exception_Id
)
269 procedure Transfer_Occurrence
270 (Target
: Ada
.Exceptions
.Exception_Occurrence_Access
;
271 Source
: Ada
.Exceptions
.Exception_Occurrence
);
272 pragma Import
(C
, Transfer_Occurrence
, "__gnat_transfer_occurrence");
274 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
277 (Debug
.Trace
(STPO
.Self
, "Exceptional_Complete_Entry_Body", 'P'));
279 -- We must have abort deferred, since we are inside
280 -- a protected operation.
282 if Entry_Call
/= null then
283 -- The call was not requeued.
285 Entry_Call
.Exception_To_Raise
:= Ex
;
287 if Ex
/= Ada
.Exceptions
.Null_Id
then
289 (Entry_Call
.Self
.Common
.Compiler_Data
.Current_Excep
'Access,
290 STPO
.Self
.Common
.Compiler_Data
.Current_Excep
);
293 -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
294 -- PO_Service_Entries on return.
297 if Runtime_Traces
then
298 Send_Trace_Info
(PO_Done
, Entry_Call
.Self
);
300 end Exceptional_Complete_Entry_Body
;
306 procedure PO_Do_Or_Queue
308 Object
: Protection_Entries_Access
;
309 Entry_Call
: Entry_Call_Link
;
310 With_Abort
: Boolean)
312 E
: constant Protected_Entry_Index
:=
313 Protected_Entry_Index
(Entry_Call
.E
);
314 Barrier_Value
: Boolean;
317 -- When the Action procedure for an entry body returns, it is either
318 -- completed (having called [Exceptional_]Complete_Entry_Body) or it
319 -- is queued, having executed a requeue statement.
322 Object
.Entry_Bodies
(
323 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).
324 Barrier
(Object
.Compiler_Info
, E
);
326 if Barrier_Value
then
328 -- Not abortable while service is in progress.
330 if Entry_Call
.State
= Now_Abortable
then
331 Entry_Call
.State
:= Was_Abortable
;
334 Object
.Call_In_Progress
:= Entry_Call
;
337 (Debug
.Trace
(Self_ID
, "PODOQ: start entry body", 'P'));
338 Object
.Entry_Bodies
(
339 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).Action
(
340 Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
342 if Object
.Call_In_Progress
/= null then
344 -- Body of current entry served call to completion
346 Object
.Call_In_Progress
:= null;
352 STPO
.Write_Lock
(Entry_Call
.Self
);
353 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
354 STPO
.Unlock
(Entry_Call
.Self
);
361 Requeue_Call
(Self_ID
, Object
, Entry_Call
, With_Abort
);
364 elsif Entry_Call
.Mode
/= Conditional_Call
365 or else not With_Abort
368 if Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
370 Run_Time_Restrictions
.Value
(Max_Entry_Queue_Length
) <=
371 Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
))
373 -- This violates the Max_Entry_Queue_Length restriction,
374 -- raise Program_Error.
376 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
382 STPO
.Write_Lock
(Entry_Call
.Self
);
383 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
384 STPO
.Unlock
(Entry_Call
.Self
);
390 Queuing
.Enqueue
(Object
.Entry_Queues
(E
), Entry_Call
);
391 Update_For_Queue_To_PO
(Entry_Call
, With_Abort
);
394 -- Conditional_Call and With_Abort
400 STPO
.Write_Lock
(Entry_Call
.Self
);
401 pragma Assert
(Entry_Call
.State
>= Was_Abortable
);
402 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Cancelled
);
403 STPO
.Unlock
(Entry_Call
.Self
);
412 Queuing
.Broadcast_Program_Error
(Self_ID
, Object
, Entry_Call
);
415 ------------------------
416 -- PO_Service_Entries --
417 ------------------------
419 procedure PO_Service_Entries
421 Object
: Entries
.Protection_Entries_Access
;
422 Unlock_Object
: Boolean := True)
424 E
: Protected_Entry_Index
;
426 Entry_Call
: Entry_Call_Link
;
430 Queuing
.Select_Protected_Entry_Call
(Self_ID
, Object
, Entry_Call
);
432 exit when Entry_Call
= null;
434 E
:= Protected_Entry_Index
(Entry_Call
.E
);
436 -- Not abortable while service is in progress.
438 if Entry_Call
.State
= Now_Abortable
then
439 Entry_Call
.State
:= Was_Abortable
;
442 Object
.Call_In_Progress
:= Entry_Call
;
445 if Runtime_Traces
then
446 Send_Trace_Info
(PO_Run
, Self_ID
,
447 Entry_Call
.Self
, Entry_Index
(E
));
451 (Debug
.Trace
(Self_ID
, "POSE: start entry body", 'P'));
452 Object
.Entry_Bodies
(
453 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).Action
(
454 Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
457 Queuing
.Broadcast_Program_Error
458 (Self_ID
, Object
, Entry_Call
);
461 if Object
.Call_In_Progress
= null then
463 (Self_ID
, Object
, Entry_Call
, Entry_Call
.Requeue_With_Abort
);
464 exit when Entry_Call
.State
= Cancelled
;
467 Object
.Call_In_Progress
:= null;
468 Caller
:= Entry_Call
.Self
;
474 STPO
.Write_Lock
(Caller
);
475 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
476 STPO
.Unlock
(Caller
);
484 if Unlock_Object
then
485 Unlock_Entries
(Object
);
487 end PO_Service_Entries
;
489 ---------------------
490 -- Protected_Count --
491 ---------------------
493 function Protected_Count
494 (Object
: Protection_Entries
'Class;
495 E
: Protected_Entry_Index
)
499 return Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
));
502 --------------------------
503 -- Protected_Entry_Call --
504 --------------------------
506 -- Compiler interface only. Do not call from within the RTS.
515 -- X : protected_entry_index := 1;
516 -- B85b : communication_block;
517 -- communication_blockIP (B85b);
519 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
520 -- null_address, conditional_call, B85b, objectF => 0);
521 -- if cancelled (B85b) then
528 -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous
531 -- The initial part of this procedure does not need to lock the the calling
532 -- task's ATCB, up to the point where the call record first may be queued
533 -- (PO_Do_Or_Queue), since before that no other task will have access to
536 -- If this is a call made inside of an abort deferred region, the call
537 -- should be never abortable.
539 -- If the call was not queued abortably, we need to wait until it is before
540 -- proceeding with the abortable part.
542 -- There are some heuristics here, just to save time for frequently
543 -- occurring cases. For example, we check Initially_Abortable to try to
544 -- avoid calling the procedure Wait_Until_Abortable, since the normal case
545 -- for async. entry calls is to be queued abortably.
547 -- Another heuristic uses the Block.Enqueued to try to avoid calling
548 -- Cancel_Protected_Entry_Call if the call can be served immediately.
550 procedure Protected_Entry_Call
551 (Object
: Protection_Entries_Access
;
552 E
: Protected_Entry_Index
;
553 Uninterpreted_Data
: System
.Address
;
555 Block
: out Communication_Block
)
557 Self_ID
: constant Task_Id
:= STPO
.Self
;
558 Entry_Call
: Entry_Call_Link
;
559 Initially_Abortable
: Boolean;
560 Ceiling_Violation
: Boolean;
564 (Debug
.Trace
(Self_ID
, "Protected_Entry_Call", 'P'));
566 if Runtime_Traces
then
567 Send_Trace_Info
(PO_Call
, Entry_Index
(E
));
570 if Self_ID
.ATC_Nesting_Level
= ATC_Level
'Last then
572 (Storage_Error
'Identity, "not enough ATC nesting levels");
575 -- If pragma Detect_Blocking is active then Program_Error must be
576 -- raised if this potentially blocking operation is called from a
580 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
582 Ada
.Exceptions
.Raise_Exception
583 (Program_Error
'Identity, "potentially blocking operation");
586 Initialization
.Defer_Abort
(Self_ID
);
587 Lock_Entries
(Object
, Ceiling_Violation
);
589 if Ceiling_Violation
then
591 -- Failed ceiling check
593 Initialization
.Undefer_Abort
(Self_ID
);
597 Block
.Self
:= Self_ID
;
598 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
+ 1;
600 (Debug
.Trace
(Self_ID
, "PEC: entered ATC level: " &
601 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
603 Self_ID
.Entry_Calls
(Self_ID
.ATC_Nesting_Level
)'Access;
604 Entry_Call
.Next
:= null;
605 Entry_Call
.Mode
:= Mode
;
606 Entry_Call
.Cancellation_Attempted
:= False;
608 if Self_ID
.Deferral_Level
> 1 then
609 Entry_Call
.State
:= Never_Abortable
;
611 Entry_Call
.State
:= Now_Abortable
;
614 Entry_Call
.E
:= Entry_Index
(E
);
615 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_ID
);
616 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
617 Entry_Call
.Called_PO
:= To_Address
(Object
);
618 Entry_Call
.Called_Task
:= null;
619 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
621 PO_Do_Or_Queue
(Self_ID
, Object
, Entry_Call
, With_Abort
=> True);
622 Initially_Abortable
:= Entry_Call
.State
= Now_Abortable
;
623 PO_Service_Entries
(Self_ID
, Object
);
625 -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
626 -- for completed or cancelled calls. (This is a heuristic, only.)
628 if Entry_Call
.State
>= Done
then
630 -- Once State >= Done it will not change any more.
636 STPO
.Write_Lock
(Self_ID
);
637 Utilities
.Exit_One_ATC_Level
(Self_ID
);
638 STPO
.Unlock
(Self_ID
);
644 Block
.Enqueued
:= False;
645 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
646 Initialization
.Undefer_Abort
(Self_ID
);
647 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
651 -- In this case we cannot conclude anything,
652 -- since State can change concurrently.
656 -- Now for the general case.
658 if Mode
= Asynchronous_Call
then
660 -- Try to avoid an expensive call.
662 if not Initially_Abortable
then
665 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
668 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
672 elsif Mode
< Asynchronous_Call
then
674 -- Simple_Call or Conditional_Call
678 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
681 STPO
.Write_Lock
(Self_ID
);
682 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
683 STPO
.Unlock
(Self_ID
);
686 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
689 pragma Assert
(False);
693 Initialization
.Undefer_Abort
(Self_ID
);
694 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
695 end Protected_Entry_Call
;
701 procedure Requeue_Call
703 Object
: Protection_Entries_Access
;
704 Entry_Call
: Entry_Call_Link
;
705 With_Abort
: Boolean)
707 New_Object
: Protection_Entries_Access
;
708 Ceiling_Violation
: Boolean;
710 E
: Protected_Entry_Index
;
713 New_Object
:= To_Protection
(Entry_Call
.Called_PO
);
715 if New_Object
= null then
717 -- Call is to be requeued to a task entry
723 Result
:= Rendezvous
.Task_Do_Or_Queue
724 (Self_Id
, Entry_Call
,
725 With_Abort
=> Entry_Call
.Requeue_With_Abort
);
728 Queuing
.Broadcast_Program_Error
729 (Self_Id
, Object
, Entry_Call
, RTS_Locked
=> True);
737 -- Call should be requeued to a PO
739 if Object
/= New_Object
then
741 -- Requeue is to different PO
743 Lock_Entries
(New_Object
, Ceiling_Violation
);
745 if Ceiling_Violation
then
746 Object
.Call_In_Progress
:= null;
747 Queuing
.Broadcast_Program_Error
748 (Self_Id
, Object
, Entry_Call
);
751 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
, With_Abort
);
752 PO_Service_Entries
(Self_Id
, New_Object
);
756 -- Requeue is to same protected object
758 if Entry_Call
.Requeue_With_Abort
759 and then Entry_Call
.Cancellation_Attempted
761 -- If this is a requeue with abort and someone tried
762 -- to cancel this call, cancel it at this point.
764 Entry_Call
.State
:= Cancelled
;
769 or else Entry_Call
.Mode
/= Conditional_Call
771 E
:= Protected_Entry_Index
(Entry_Call
.E
);
773 if Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
775 Run_Time_Restrictions
.Value
(Max_Entry_Queue_Length
) <=
776 Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
))
778 -- This violates the Max_Entry_Queue_Length restriction,
779 -- raise Program_Error.
781 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
787 STPO
.Write_Lock
(Entry_Call
.Self
);
788 Initialization
.Wakeup_Entry_Caller
789 (Self_Id
, Entry_Call
, Done
);
790 STPO
.Unlock
(Entry_Call
.Self
);
797 (New_Object
.Entry_Queues
(E
), Entry_Call
);
798 Update_For_Queue_To_PO
(Entry_Call
, With_Abort
);
802 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
, With_Abort
);
808 ----------------------------
809 -- Protected_Entry_Caller --
810 ----------------------------
812 function Protected_Entry_Caller
813 (Object
: Protection_Entries
'Class) return Task_Id
is
815 return Object
.Call_In_Progress
.Self
;
816 end Protected_Entry_Caller
;
818 -----------------------------
819 -- Requeue_Protected_Entry --
820 -----------------------------
822 -- Compiler interface only. Do not call from within the RTS.
831 -- procedure rPT__E10b (O : address; P : address; E :
832 -- protected_entry_index) is
833 -- type rTVP is access rTV;
835 -- _object : rTVP := rTVP!(O);
838 -- rR : protection renames _object._object;
839 -- vP : integer renames _object.v;
840 -- bP : boolean renames _object.b;
844 -- requeue_protected_entry (rR'unchecked_access, rR'
845 -- unchecked_access, 2, false, objectF => 0, new_objectF =>
849 -- complete_entry_body (_object._object'unchecked_access, objectF =>
854 -- abort_undefer.all;
855 -- exceptional_complete_entry_body (_object._object'
856 -- unchecked_access, current_exception, objectF => 0);
860 procedure Requeue_Protected_Entry
861 (Object
: Protection_Entries_Access
;
862 New_Object
: Protection_Entries_Access
;
863 E
: Protected_Entry_Index
;
864 With_Abort
: Boolean)
866 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
870 (Debug
.Trace
(STPO
.Self
, "Requeue_Protected_Entry", 'P'));
871 pragma Assert
(STPO
.Self
.Deferral_Level
> 0);
873 Entry_Call
.E
:= Entry_Index
(E
);
874 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
875 Entry_Call
.Called_Task
:= null;
876 Entry_Call
.Requeue_With_Abort
:= With_Abort
;
877 Object
.Call_In_Progress
:= null;
878 end Requeue_Protected_Entry
;
880 -------------------------------------
881 -- Requeue_Task_To_Protected_Entry --
882 -------------------------------------
884 -- Compiler interface only.
894 -- accept_call (1, A79b);
896 -- requeue_task_to_protected_entry (rTV!(r)._object'
897 -- unchecked_access, 2, false, new_objectF => 0);
900 -- complete_rendezvous;
902 -- when all others =>
903 -- exceptional_complete_rendezvous (get_gnat_exception);
906 procedure Requeue_Task_To_Protected_Entry
907 (New_Object
: Protection_Entries_Access
;
908 E
: Protected_Entry_Index
;
909 With_Abort
: Boolean)
911 Self_ID
: constant Task_Id
:= STPO
.Self
;
912 Entry_Call
: constant Entry_Call_Link
:= Self_ID
.Common
.Call
;
915 Initialization
.Defer_Abort
(Self_ID
);
917 -- We do not need to lock Self_ID here since the call is not abortable
918 -- at this point, and therefore, the caller cannot cancel the call.
920 Entry_Call
.Needs_Requeue
:= True;
921 Entry_Call
.Requeue_With_Abort
:= With_Abort
;
922 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
923 Entry_Call
.Called_Task
:= null;
924 Entry_Call
.E
:= Entry_Index
(E
);
925 Initialization
.Undefer_Abort
(Self_ID
);
926 end Requeue_Task_To_Protected_Entry
;
928 ---------------------
929 -- Service_Entries --
930 ---------------------
932 procedure Service_Entries
(Object
: Protection_Entries_Access
) is
933 Self_ID
: constant Task_Id
:= STPO
.Self
;
935 PO_Service_Entries
(Self_ID
, Object
);
938 --------------------------------
939 -- Timed_Protected_Entry_Call --
940 --------------------------------
942 -- Compiler interface only. Do not call from within the RTS.
944 procedure Timed_Protected_Entry_Call
945 (Object
: Protection_Entries_Access
;
946 E
: Protected_Entry_Index
;
947 Uninterpreted_Data
: System
.Address
;
950 Entry_Call_Successful
: out Boolean)
952 Self_Id
: constant Task_Id
:= STPO
.Self
;
953 Entry_Call
: Entry_Call_Link
;
954 Ceiling_Violation
: Boolean;
958 if Self_Id
.ATC_Nesting_Level
= ATC_Level
'Last then
959 Raise_Exception
(Storage_Error
'Identity,
960 "not enough ATC nesting levels");
963 -- If pragma Detect_Blocking is active then Program_Error must be
964 -- raised if this potentially blocking operation is called from a
968 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
970 Ada
.Exceptions
.Raise_Exception
971 (Program_Error
'Identity, "potentially blocking operation");
974 if Runtime_Traces
then
975 Send_Trace_Info
(POT_Call
, Entry_Index
(E
), Timeout
);
978 Initialization
.Defer_Abort
(Self_Id
);
979 Lock_Entries
(Object
, Ceiling_Violation
);
981 if Ceiling_Violation
then
982 Initialization
.Undefer_Abort
(Self_Id
);
986 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
+ 1;
988 (Debug
.Trace
(Self_Id
, "TPEC: exited to ATC level: " &
989 ATC_Level
'Image (Self_Id
.ATC_Nesting_Level
), 'A'));
991 Self_Id
.Entry_Calls
(Self_Id
.ATC_Nesting_Level
)'Access;
992 Entry_Call
.Next
:= null;
993 Entry_Call
.Mode
:= Timed_Call
;
994 Entry_Call
.Cancellation_Attempted
:= False;
996 if Self_Id
.Deferral_Level
> 1 then
997 Entry_Call
.State
:= Never_Abortable
;
999 Entry_Call
.State
:= Now_Abortable
;
1002 Entry_Call
.E
:= Entry_Index
(E
);
1003 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_Id
);
1004 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
1005 Entry_Call
.Called_PO
:= To_Address
(Object
);
1006 Entry_Call
.Called_Task
:= null;
1007 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
1009 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
, With_Abort
=> True);
1010 PO_Service_Entries
(Self_Id
, Object
);
1015 STPO
.Write_Lock
(Self_Id
);
1018 -- Try to avoid waiting for completed or cancelled calls.
1020 if Entry_Call
.State
>= Done
then
1021 Utilities
.Exit_One_ATC_Level
(Self_Id
);
1026 STPO
.Unlock
(Self_Id
);
1029 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
1030 Initialization
.Undefer_Abort
(Self_Id
);
1031 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
1035 Entry_Calls
.Wait_For_Completion_With_Timeout
1036 (Entry_Call
, Timeout
, Mode
, Yielded
);
1041 STPO
.Unlock
(Self_Id
);
1044 -- ??? Do we need to yield in case Yielded is False
1046 Initialization
.Undefer_Abort
(Self_Id
);
1047 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
1048 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
1049 end Timed_Protected_Entry_Call
;
1051 ----------------------------
1052 -- Update_For_Queue_To_PO --
1053 ----------------------------
1055 -- Update the state of an existing entry call, based on
1056 -- whether the current queuing action is with or without abort.
1057 -- Call this only while holding the server's lock.
1058 -- It returns with the server's lock released.
1060 New_State
: constant array (Boolean, Entry_Call_State
)
1061 of Entry_Call_State
:=
1063 (Never_Abortable
=> Never_Abortable
,
1064 Not_Yet_Abortable
=> Now_Abortable
,
1065 Was_Abortable
=> Now_Abortable
,
1066 Now_Abortable
=> Now_Abortable
,
1068 Cancelled
=> Cancelled
),
1070 (Never_Abortable
=> Never_Abortable
,
1071 Not_Yet_Abortable
=> Not_Yet_Abortable
,
1072 Was_Abortable
=> Was_Abortable
,
1073 Now_Abortable
=> Now_Abortable
,
1075 Cancelled
=> Cancelled
)
1078 procedure Update_For_Queue_To_PO
1079 (Entry_Call
: Entry_Call_Link
;
1080 With_Abort
: Boolean)
1082 Old
: constant Entry_Call_State
:= Entry_Call
.State
;
1085 pragma Assert
(Old
< Done
);
1087 Entry_Call
.State
:= New_State
(With_Abort
, Entry_Call
.State
);
1089 if Entry_Call
.Mode
= Asynchronous_Call
then
1090 if Old
< Was_Abortable
and then
1091 Entry_Call
.State
= Now_Abortable
1097 STPO
.Write_Lock
(Entry_Call
.Self
);
1099 if Entry_Call
.Self
.Common
.State
= Async_Select_Sleep
then
1100 STPO
.Wakeup
(Entry_Call
.Self
, Async_Select_Sleep
);
1103 STPO
.Unlock
(Entry_Call
.Self
);
1111 elsif Entry_Call
.Mode
= Conditional_Call
then
1112 pragma Assert
(Entry_Call
.State
< Was_Abortable
);
1115 end Update_For_Queue_To_PO
;
1117 end System
.Tasking
.Protected_Objects
.Operations
;