1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
9 -- Copyright (C) 1998-2008, 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 2, or (at your option) any later ver- --
14 -- sion. GNARL 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This package contains all extended primitives related to Protected_Objects
37 -- The handling of protected objects with no entries is done in
38 -- System.Tasking.Protected_Objects, the simple routines for protected
39 -- objects with entries in System.Tasking.Protected_Objects.Entries.
41 -- The split between Entries and Operations is needed to break circular
42 -- dependencies inside the run time.
44 -- This package contains all primitives related to Protected_Objects.
45 -- Note: the compiler generates direct calls to this interface, via Rtsfind.
47 with System
.Task_Primitives
.Operations
;
48 with System
.Tasking
.Entry_Calls
;
49 with System
.Tasking
.Queuing
;
50 with System
.Tasking
.Rendezvous
;
51 with System
.Tasking
.Utilities
;
52 with System
.Tasking
.Debug
;
53 with System
.Parameters
;
54 with System
.Traces
.Tasking
;
55 with System
.Restrictions
;
57 with System
.Tasking
.Initialization
;
58 pragma Elaborate_All
(System
.Tasking
.Initialization
);
59 -- Insures that tasking is initialized if any protected objects are created
61 package body System
.Tasking
.Protected_Objects
.Operations
is
63 package STPO
renames System
.Task_Primitives
.Operations
;
70 use System
.Restrictions
;
71 use System
.Restrictions
.Rident
;
73 use System
.Traces
.Tasking
;
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 procedure Update_For_Queue_To_PO
80 (Entry_Call
: Entry_Call_Link
;
81 With_Abort
: Boolean);
82 pragma Inline
(Update_For_Queue_To_PO
);
83 -- Update the state of an existing entry call to reflect the fact that it
84 -- is being enqueued, based on whether the current queuing action is with
85 -- or without abort. Call this only while holding the PO's lock. It returns
86 -- with the PO's lock still held.
88 procedure Requeue_Call
90 Object
: Protection_Entries_Access
;
91 Entry_Call
: Entry_Call_Link
);
92 -- Handle requeue of Entry_Call.
93 -- In particular, queue the call if needed, or service it immediately
96 ---------------------------------
97 -- Cancel_Protected_Entry_Call --
98 ---------------------------------
100 -- Compiler interface only (do not call from within the RTS)
102 -- This should have analogous effect to Cancel_Task_Entry_Call, setting
103 -- the value of Block.Cancelled instead of returning the parameter value
106 -- The effect should be idempotent, since the call may already have been
120 -- X : protected_entry_index := 1;
121 -- B80b : communication_block;
122 -- communication_blockIP (B80b);
128 -- procedure _clean is
130 -- if enqueued (B80b) then
131 -- cancel_protected_entry_call (B80b);
137 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
138 -- null_address, asynchronous_call, B80b, objectF => 0);
139 -- if enqueued (B80b) then
147 -- when _abort_signal =>
148 -- abort_undefer.all;
152 -- if not cancelled (B80b) then
157 -- If the entry call completes after we get into the abortable part,
158 -- Abort_Signal should be raised and ATC will take us to the at-end
159 -- handler, which will call _clean.
161 -- If the entry call returns with the call already completed, we can skip
162 -- this, and use the "if enqueued()" to go past the at-end handler, but we
163 -- will still call _clean.
165 -- If the abortable part completes before the entry call is Done, it will
168 -- If the entry call or the abortable part raises an exception,
169 -- we will still call _clean, but the value of Cancelled should not matter.
171 -- Whoever calls _clean first gets to decide whether the call
172 -- has been "cancelled".
174 -- Enqueued should be true if there is any chance that the call is still on
175 -- a queue. It seems to be safe to make it True if the call was Onqueue at
176 -- some point before return from Protected_Entry_Call.
178 -- Cancelled should be true iff the abortable part completed
179 -- and succeeded in cancelling the entry call before it completed.
182 -- The need for Enqueued is less obvious. The "if enqueued ()" tests are
183 -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call
184 -- must do the same test internally, with locking. The one that makes
185 -- cancellation conditional may be a useful heuristic since at least 1/2
186 -- the time the call should be off-queue by that point. The other one seems
187 -- totally useless, since Protected_Entry_Call must do the same check and
188 -- then possibly wait for the call to be abortable, internally.
190 -- We can check Call.State here without locking the caller's mutex,
191 -- since the call must be over after returning from Wait_For_Completion.
192 -- No other task can access the call record at this point.
194 procedure Cancel_Protected_Entry_Call
195 (Block
: in out Communication_Block
) is
197 Entry_Calls
.Try_To_Cancel_Entry_Call
(Block
.Cancelled
);
198 end Cancel_Protected_Entry_Call
;
204 function Cancelled
(Block
: Communication_Block
) return Boolean is
206 return Block
.Cancelled
;
209 -------------------------
210 -- Complete_Entry_Body --
211 -------------------------
213 procedure Complete_Entry_Body
(Object
: Protection_Entries_Access
) is
215 Exceptional_Complete_Entry_Body
(Object
, Ada
.Exceptions
.Null_Id
);
216 end Complete_Entry_Body
;
222 function Enqueued
(Block
: Communication_Block
) return Boolean is
224 return Block
.Enqueued
;
227 -------------------------------------
228 -- Exceptional_Complete_Entry_Body --
229 -------------------------------------
231 procedure Exceptional_Complete_Entry_Body
232 (Object
: Protection_Entries_Access
;
233 Ex
: Ada
.Exceptions
.Exception_Id
)
235 procedure Transfer_Occurrence
236 (Target
: Ada
.Exceptions
.Exception_Occurrence_Access
;
237 Source
: Ada
.Exceptions
.Exception_Occurrence
);
238 pragma Import
(C
, Transfer_Occurrence
, "__gnat_transfer_occurrence");
240 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
245 (Debug
.Trace
(STPO
.Self
, "Exceptional_Complete_Entry_Body", 'P'));
247 -- We must have abort deferred, since we are inside a protected
250 if Entry_Call
/= null then
252 -- The call was not requeued
254 Entry_Call
.Exception_To_Raise
:= Ex
;
256 if Ex
/= Ada
.Exceptions
.Null_Id
then
258 -- An exception was raised and abort was deferred, so adjust
259 -- before propagating, otherwise the task will stay with deferral
260 -- enabled for its remaining life.
262 Self_Id
:= STPO
.Self
;
263 Initialization
.Undefer_Abort_Nestable
(Self_Id
);
265 (Entry_Call
.Self
.Common
.Compiler_Data
.Current_Excep
'Access,
266 Self_Id
.Common
.Compiler_Data
.Current_Excep
);
269 -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or
270 -- PO_Service_Entries on return.
274 if Runtime_Traces
then
275 Send_Trace_Info
(PO_Done
, Entry_Call
.Self
);
277 end Exceptional_Complete_Entry_Body
;
283 procedure PO_Do_Or_Queue
285 Object
: Protection_Entries_Access
;
286 Entry_Call
: Entry_Call_Link
)
288 E
: constant Protected_Entry_Index
:=
289 Protected_Entry_Index
(Entry_Call
.E
);
290 Barrier_Value
: Boolean;
293 -- When the Action procedure for an entry body returns, it is either
294 -- completed (having called [Exceptional_]Complete_Entry_Body) or it
295 -- is queued, having executed a requeue statement.
298 Object
.Entry_Bodies
(
299 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).
300 Barrier
(Object
.Compiler_Info
, E
);
302 if Barrier_Value
then
304 -- Not abortable while service is in progress
306 if Entry_Call
.State
= Now_Abortable
then
307 Entry_Call
.State
:= Was_Abortable
;
310 Object
.Call_In_Progress
:= Entry_Call
;
313 (Debug
.Trace
(Self_ID
, "PODOQ: start entry body", 'P'));
314 Object
.Entry_Bodies
(
315 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).Action
(
316 Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
318 if Object
.Call_In_Progress
/= null then
320 -- Body of current entry served call to completion
322 Object
.Call_In_Progress
:= null;
328 STPO
.Write_Lock
(Entry_Call
.Self
);
329 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
330 STPO
.Unlock
(Entry_Call
.Self
);
337 Requeue_Call
(Self_ID
, Object
, Entry_Call
);
340 elsif Entry_Call
.Mode
/= Conditional_Call
341 or else not Entry_Call
.With_Abort
344 if Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
346 Run_Time_Restrictions
.Value
(Max_Entry_Queue_Length
) <=
347 Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
))
349 -- This violates the Max_Entry_Queue_Length restriction,
350 -- raise Program_Error.
352 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
358 STPO
.Write_Lock
(Entry_Call
.Self
);
359 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
360 STPO
.Unlock
(Entry_Call
.Self
);
366 Queuing
.Enqueue
(Object
.Entry_Queues
(E
), Entry_Call
);
367 Update_For_Queue_To_PO
(Entry_Call
, Entry_Call
.With_Abort
);
370 -- Conditional_Call and With_Abort
376 STPO
.Write_Lock
(Entry_Call
.Self
);
377 pragma Assert
(Entry_Call
.State
>= Was_Abortable
);
378 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Cancelled
);
379 STPO
.Unlock
(Entry_Call
.Self
);
388 Queuing
.Broadcast_Program_Error
(Self_ID
, Object
, Entry_Call
);
391 ------------------------
392 -- PO_Service_Entries --
393 ------------------------
395 procedure PO_Service_Entries
397 Object
: Entries
.Protection_Entries_Access
;
398 Unlock_Object
: Boolean := True)
400 E
: Protected_Entry_Index
;
402 Entry_Call
: Entry_Call_Link
;
406 Queuing
.Select_Protected_Entry_Call
(Self_ID
, Object
, Entry_Call
);
408 exit when Entry_Call
= null;
410 E
:= Protected_Entry_Index
(Entry_Call
.E
);
412 -- Not abortable while service is in progress
414 if Entry_Call
.State
= Now_Abortable
then
415 Entry_Call
.State
:= Was_Abortable
;
418 Object
.Call_In_Progress
:= Entry_Call
;
421 if Runtime_Traces
then
422 Send_Trace_Info
(PO_Run
, Self_ID
,
423 Entry_Call
.Self
, Entry_Index
(E
));
427 (Debug
.Trace
(Self_ID
, "POSE: start entry body", 'P'));
430 (Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).Action
431 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
435 Queuing
.Broadcast_Program_Error
436 (Self_ID
, Object
, Entry_Call
);
439 if Object
.Call_In_Progress
= null then
440 Requeue_Call
(Self_ID
, Object
, Entry_Call
);
441 exit when Entry_Call
.State
= Cancelled
;
444 Object
.Call_In_Progress
:= null;
445 Caller
:= Entry_Call
.Self
;
451 STPO
.Write_Lock
(Caller
);
452 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
453 STPO
.Unlock
(Caller
);
461 if Unlock_Object
then
462 Unlock_Entries
(Object
);
464 end PO_Service_Entries
;
466 ---------------------
467 -- Protected_Count --
468 ---------------------
470 function Protected_Count
471 (Object
: Protection_Entries
'Class;
472 E
: Protected_Entry_Index
) return Natural
475 return Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
));
478 --------------------------
479 -- Protected_Entry_Call --
480 --------------------------
482 -- Compiler interface only (do not call from within the RTS)
491 -- X : protected_entry_index := 1;
492 -- B85b : communication_block;
493 -- communication_blockIP (B85b);
496 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
497 -- null_address, conditional_call, B85b, objectF => 0);
499 -- if cancelled (B85b) then
506 -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous
509 -- The initial part of this procedure does not need to lock the calling
510 -- task's ATCB, up to the point where the call record first may be queued
511 -- (PO_Do_Or_Queue), since before that no other task will have access to
514 -- If this is a call made inside of an abort deferred region, the call
515 -- should be never abortable.
517 -- If the call was not queued abortably, we need to wait until it is before
518 -- proceeding with the abortable part.
520 -- There are some heuristics here, just to save time for frequently
521 -- occurring cases. For example, we check Initially_Abortable to try to
522 -- avoid calling the procedure Wait_Until_Abortable, since the normal case
523 -- for async. entry calls is to be queued abortably.
525 -- Another heuristic uses the Block.Enqueued to try to avoid calling
526 -- Cancel_Protected_Entry_Call if the call can be served immediately.
528 procedure Protected_Entry_Call
529 (Object
: Protection_Entries_Access
;
530 E
: Protected_Entry_Index
;
531 Uninterpreted_Data
: System
.Address
;
533 Block
: out Communication_Block
)
535 Self_ID
: constant Task_Id
:= STPO
.Self
;
536 Entry_Call
: Entry_Call_Link
;
537 Initially_Abortable
: Boolean;
538 Ceiling_Violation
: Boolean;
542 (Debug
.Trace
(Self_ID
, "Protected_Entry_Call", 'P'));
544 if Runtime_Traces
then
545 Send_Trace_Info
(PO_Call
, Entry_Index
(E
));
548 if Self_ID
.ATC_Nesting_Level
= ATC_Level
'Last then
549 raise Storage_Error
with "not enough ATC nesting levels";
552 -- If pragma Detect_Blocking is active then Program_Error must be
553 -- raised if this potentially blocking operation is called from a
557 and then Self_ID
.Common
.Protected_Action_Nesting
> 0
559 raise Program_Error
with "potentially blocking operation";
562 -- Self_ID.Deferral_Level should be 0, except when called from Finalize,
563 -- where abort is already deferred.
565 Initialization
.Defer_Abort_Nestable
(Self_ID
);
566 Lock_Entries
(Object
, Ceiling_Violation
);
568 if Ceiling_Violation
then
570 -- Failed ceiling check
572 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
576 Block
.Self
:= Self_ID
;
577 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
+ 1;
579 (Debug
.Trace
(Self_ID
, "PEC: entered ATC level: " &
580 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
582 Self_ID
.Entry_Calls
(Self_ID
.ATC_Nesting_Level
)'Access;
583 Entry_Call
.Next
:= null;
584 Entry_Call
.Mode
:= Mode
;
585 Entry_Call
.Cancellation_Attempted
:= False;
587 if Self_ID
.Deferral_Level
> 1 then
588 Entry_Call
.State
:= Never_Abortable
;
590 Entry_Call
.State
:= Now_Abortable
;
593 Entry_Call
.E
:= Entry_Index
(E
);
594 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_ID
);
595 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
596 Entry_Call
.Called_PO
:= To_Address
(Object
);
597 Entry_Call
.Called_Task
:= null;
598 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
599 Entry_Call
.With_Abort
:= True;
601 PO_Do_Or_Queue
(Self_ID
, Object
, Entry_Call
);
602 Initially_Abortable
:= Entry_Call
.State
= Now_Abortable
;
603 PO_Service_Entries
(Self_ID
, Object
);
605 -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)
606 -- for completed or cancelled calls. (This is a heuristic, only.)
608 if Entry_Call
.State
>= Done
then
610 -- Once State >= Done it will not change any more
616 STPO
.Write_Lock
(Self_ID
);
617 Utilities
.Exit_One_ATC_Level
(Self_ID
);
618 STPO
.Unlock
(Self_ID
);
624 Block
.Enqueued
:= False;
625 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
626 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
627 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
631 -- In this case we cannot conclude anything, since State can change
637 -- Now for the general case
639 if Mode
= Asynchronous_Call
then
641 -- Try to avoid an expensive call
643 if not Initially_Abortable
then
646 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
649 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
653 elsif Mode
< Asynchronous_Call
then
655 -- Simple_Call or 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
;
671 pragma Assert
(False);
675 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
676 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
677 end Protected_Entry_Call
;
683 procedure Requeue_Call
685 Object
: Protection_Entries_Access
;
686 Entry_Call
: Entry_Call_Link
)
688 New_Object
: Protection_Entries_Access
;
689 Ceiling_Violation
: Boolean;
691 E
: Protected_Entry_Index
;
694 New_Object
:= To_Protection
(Entry_Call
.Called_PO
);
696 if New_Object
= null then
698 -- Call is to be requeued to a task entry
704 Result
:= Rendezvous
.Task_Do_Or_Queue
(Self_Id
, Entry_Call
);
707 Queuing
.Broadcast_Program_Error
708 (Self_Id
, Object
, Entry_Call
, RTS_Locked
=> True);
716 -- Call should be requeued to a PO
718 if Object
/= New_Object
then
720 -- Requeue is to different PO
722 Lock_Entries
(New_Object
, Ceiling_Violation
);
724 if Ceiling_Violation
then
725 Object
.Call_In_Progress
:= null;
726 Queuing
.Broadcast_Program_Error
(Self_Id
, Object
, Entry_Call
);
729 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
);
730 PO_Service_Entries
(Self_Id
, New_Object
);
734 -- Requeue is to same protected object
736 -- ??? Try to compensate apparent failure of the scheduler on some
737 -- OS (e.g VxWorks) to give higher priority tasks a chance to run
742 if Entry_Call
.With_Abort
743 and then Entry_Call
.Cancellation_Attempted
745 -- If this is a requeue with abort and someone tried to cancel
746 -- this call, cancel it at this point.
748 Entry_Call
.State
:= Cancelled
;
752 if not Entry_Call
.With_Abort
753 or else Entry_Call
.Mode
/= Conditional_Call
755 E
:= Protected_Entry_Index
(Entry_Call
.E
);
757 if Run_Time_Restrictions
.Set
(Max_Entry_Queue_Length
)
759 Run_Time_Restrictions
.Value
(Max_Entry_Queue_Length
) <=
760 Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
))
762 -- This violates the Max_Entry_Queue_Length restriction,
763 -- raise Program_Error.
765 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
771 STPO
.Write_Lock
(Entry_Call
.Self
);
772 Initialization
.Wakeup_Entry_Caller
773 (Self_Id
, Entry_Call
, Done
);
774 STPO
.Unlock
(Entry_Call
.Self
);
782 (New_Object
.Entry_Queues
(E
), Entry_Call
);
783 Update_For_Queue_To_PO
(Entry_Call
, Entry_Call
.With_Abort
);
787 PO_Do_Or_Queue
(Self_Id
, New_Object
, Entry_Call
);
793 ----------------------------
794 -- Protected_Entry_Caller --
795 ----------------------------
797 function Protected_Entry_Caller
798 (Object
: Protection_Entries
'Class) return Task_Id
is
800 return Object
.Call_In_Progress
.Self
;
801 end Protected_Entry_Caller
;
803 -----------------------------
804 -- Requeue_Protected_Entry --
805 -----------------------------
807 -- Compiler interface only (do not call from within the RTS)
816 -- procedure rPT__E10b (O : address; P : address; E :
817 -- protected_entry_index) is
818 -- type rTVP is access rTV;
820 -- _object : rTVP := rTVP!(O);
823 -- rR : protection renames _object._object;
824 -- vP : integer renames _object.v;
825 -- bP : boolean renames _object.b;
829 -- requeue_protected_entry (rR'unchecked_access, rR'
830 -- unchecked_access, 2, false, objectF => 0, new_objectF =>
834 -- complete_entry_body (_object._object'unchecked_access, objectF =>
839 -- abort_undefer.all;
840 -- exceptional_complete_entry_body (_object._object'
841 -- unchecked_access, current_exception, objectF => 0);
845 procedure Requeue_Protected_Entry
846 (Object
: Protection_Entries_Access
;
847 New_Object
: Protection_Entries_Access
;
848 E
: Protected_Entry_Index
;
849 With_Abort
: Boolean)
851 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
855 (Debug
.Trace
(STPO
.Self
, "Requeue_Protected_Entry", 'P'));
856 pragma Assert
(STPO
.Self
.Deferral_Level
> 0);
858 Entry_Call
.E
:= Entry_Index
(E
);
859 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
860 Entry_Call
.Called_Task
:= null;
861 Entry_Call
.With_Abort
:= With_Abort
;
862 Object
.Call_In_Progress
:= null;
863 end Requeue_Protected_Entry
;
865 -------------------------------------
866 -- Requeue_Task_To_Protected_Entry --
867 -------------------------------------
869 -- Compiler interface only (do not call from within the RTS)
880 -- accept_call (1, A79b);
882 -- requeue_task_to_protected_entry (rTV!(r)._object'
883 -- unchecked_access, 2, false, new_objectF => 0);
886 -- complete_rendezvous;
889 -- when all others =>
890 -- exceptional_complete_rendezvous (get_gnat_exception);
893 procedure Requeue_Task_To_Protected_Entry
894 (New_Object
: Protection_Entries_Access
;
895 E
: Protected_Entry_Index
;
896 With_Abort
: Boolean)
898 Self_ID
: constant Task_Id
:= STPO
.Self
;
899 Entry_Call
: constant Entry_Call_Link
:= Self_ID
.Common
.Call
;
902 Initialization
.Defer_Abort
(Self_ID
);
904 -- We do not need to lock Self_ID here since the call is not abortable
905 -- at this point, and therefore, the caller cannot cancel the call.
907 Entry_Call
.Needs_Requeue
:= True;
908 Entry_Call
.With_Abort
:= With_Abort
;
909 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
910 Entry_Call
.Called_Task
:= null;
911 Entry_Call
.E
:= Entry_Index
(E
);
912 Initialization
.Undefer_Abort
(Self_ID
);
913 end Requeue_Task_To_Protected_Entry
;
915 ---------------------
916 -- Service_Entries --
917 ---------------------
919 procedure Service_Entries
(Object
: Protection_Entries_Access
) is
920 Self_ID
: constant Task_Id
:= STPO
.Self
;
922 PO_Service_Entries
(Self_ID
, Object
);
925 --------------------------------
926 -- Timed_Protected_Entry_Call --
927 --------------------------------
929 -- Compiler interface only (do not call from within the RTS)
931 procedure Timed_Protected_Entry_Call
932 (Object
: Protection_Entries_Access
;
933 E
: Protected_Entry_Index
;
934 Uninterpreted_Data
: System
.Address
;
937 Entry_Call_Successful
: out Boolean)
939 Self_Id
: constant Task_Id
:= STPO
.Self
;
940 Entry_Call
: Entry_Call_Link
;
941 Ceiling_Violation
: Boolean;
944 pragma Unreferenced
(Yielded
);
947 if Self_Id
.ATC_Nesting_Level
= ATC_Level
'Last then
948 raise Storage_Error
with "not enough ATC nesting levels";
951 -- If pragma Detect_Blocking is active then Program_Error must be
952 -- raised if this potentially blocking operation is called from a
956 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
958 raise Program_Error
with "potentially blocking operation";
961 if Runtime_Traces
then
962 Send_Trace_Info
(POT_Call
, Entry_Index
(E
), Timeout
);
965 Initialization
.Defer_Abort
(Self_Id
);
966 Lock_Entries
(Object
, Ceiling_Violation
);
968 if Ceiling_Violation
then
969 Initialization
.Undefer_Abort
(Self_Id
);
973 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
+ 1;
975 (Debug
.Trace
(Self_Id
, "TPEC: exited to ATC level: " &
976 ATC_Level
'Image (Self_Id
.ATC_Nesting_Level
), 'A'));
978 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;
983 if Self_Id
.Deferral_Level
> 1 then
984 Entry_Call
.State
:= Never_Abortable
;
986 Entry_Call
.State
:= Now_Abortable
;
989 Entry_Call
.E
:= Entry_Index
(E
);
990 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_Id
);
991 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
992 Entry_Call
.Called_PO
:= To_Address
(Object
);
993 Entry_Call
.Called_Task
:= null;
994 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
995 Entry_Call
.With_Abort
:= True;
997 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
);
998 PO_Service_Entries
(Self_Id
, Object
);
1003 STPO
.Write_Lock
(Self_Id
);
1006 -- Try to avoid waiting for completed or cancelled calls
1008 if Entry_Call
.State
>= Done
then
1009 Utilities
.Exit_One_ATC_Level
(Self_Id
);
1014 STPO
.Unlock
(Self_Id
);
1017 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
1018 Initialization
.Undefer_Abort
(Self_Id
);
1019 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
1023 Entry_Calls
.Wait_For_Completion_With_Timeout
1024 (Entry_Call
, Timeout
, Mode
, Yielded
);
1029 STPO
.Unlock
(Self_Id
);
1032 -- ??? Do we need to yield in case Yielded is False
1034 Initialization
.Undefer_Abort
(Self_Id
);
1035 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
1036 Entry_Calls
.Check_Exception
(Self_Id
, Entry_Call
);
1037 end Timed_Protected_Entry_Call
;
1039 ----------------------------
1040 -- Update_For_Queue_To_PO --
1041 ----------------------------
1043 -- Update the state of an existing entry call, based on
1044 -- whether the current queuing action is with or without abort.
1045 -- Call this only while holding the server's lock.
1046 -- It returns with the server's lock released.
1048 New_State
: constant array (Boolean, Entry_Call_State
)
1049 of Entry_Call_State
:=
1051 (Never_Abortable
=> Never_Abortable
,
1052 Not_Yet_Abortable
=> Now_Abortable
,
1053 Was_Abortable
=> Now_Abortable
,
1054 Now_Abortable
=> Now_Abortable
,
1056 Cancelled
=> Cancelled
),
1058 (Never_Abortable
=> Never_Abortable
,
1059 Not_Yet_Abortable
=> Not_Yet_Abortable
,
1060 Was_Abortable
=> Was_Abortable
,
1061 Now_Abortable
=> Now_Abortable
,
1063 Cancelled
=> Cancelled
)
1066 procedure Update_For_Queue_To_PO
1067 (Entry_Call
: Entry_Call_Link
;
1068 With_Abort
: Boolean)
1070 Old
: constant Entry_Call_State
:= Entry_Call
.State
;
1073 pragma Assert
(Old
< Done
);
1075 Entry_Call
.State
:= New_State
(With_Abort
, Entry_Call
.State
);
1077 if Entry_Call
.Mode
= Asynchronous_Call
then
1078 if Old
< Was_Abortable
and then
1079 Entry_Call
.State
= Now_Abortable
1085 STPO
.Write_Lock
(Entry_Call
.Self
);
1087 if Entry_Call
.Self
.Common
.State
= Async_Select_Sleep
then
1088 STPO
.Wakeup
(Entry_Call
.Self
, Async_Select_Sleep
);
1091 STPO
.Unlock
(Entry_Call
.Self
);
1099 elsif Entry_Call
.Mode
= Conditional_Call
then
1100 pragma Assert
(Entry_Call
.State
< Was_Abortable
);
1103 end Update_For_Queue_To_PO
;
1105 end System
.Tasking
.Protected_Objects
.Operations
;