1 ------------------------------------------------------------------------------
3 -- GNU ADA 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 --
12 -- Copyright (C) 1991-2001, Florida State University --
14 -- GNARL is free software; you can redistribute it and/or modify it under --
15 -- terms of the GNU General Public License as published by the Free Soft- --
16 -- ware Foundation; either version 2, or (at your option) any later ver- --
17 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
18 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
19 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
20 -- for more details. You should have received a copy of the GNU General --
21 -- Public License distributed with GNARL; see file COPYING. If not, write --
22 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
23 -- MA 02111-1307, USA. --
25 -- As a special exception, if other files instantiate generics from this --
26 -- unit, or you link this unit with other files to produce an executable, --
27 -- this unit does not by itself cause the resulting executable to be --
28 -- covered by the GNU General Public License. This exception does not --
29 -- however invalidate any other reasons why the executable file might be --
30 -- covered by the GNU Public License. --
32 -- GNARL was developed by the GNARL team at Florida State University. It is --
33 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
34 -- State University (http://www.gnat.com). --
36 ------------------------------------------------------------------------------
38 -- This package contains all the extended primitives related to
39 -- Protected_Objects with entries.
41 -- The handling of protected objects with no entries is done in
42 -- System.Tasking.Protected_Objects, the simple routines for protected
43 -- objects with entries in System.Tasking.Protected_Objects.Entries.
45 -- The split between Entries and Operations is needed to break circular
46 -- dependencies inside the run time.
48 -- This package contains all primitives related to Protected_Objects.
49 -- Note: the compiler generates direct calls to this interface, via Rtsfind.
52 -- Used for Exception_ID
56 with System
.Task_Primitives
.Operations
;
57 -- used for Initialize_Lock
63 with System
.Tasking
.Entry_Calls
;
64 -- used for Wait_For_Completion
65 -- Wait_Until_Abortable
67 with System
.Tasking
.Initialization
;
68 -- Used for Defer_Abort,
70 -- Change_Base_Priority
72 pragma Elaborate_All
(System
.Tasking
.Initialization
);
73 -- This insures that tasking is initialized if any protected objects are
76 with System
.Tasking
.Queuing
;
78 -- Broadcast_Program_Error
79 -- Select_Protected_Entry_Call
83 with System
.Tasking
.Rendezvous
;
84 -- used for Task_Do_Or_Queue
86 with System
.Tasking
.Debug
;
89 package body System
.Tasking
.Protected_Objects
.Operations
is
91 package STPO
renames System
.Task_Primitives
.Operations
;
98 -----------------------
99 -- Local Subprograms --
100 -----------------------
102 procedure Update_For_Queue_To_PO
103 (Entry_Call
: Entry_Call_Link
;
104 With_Abort
: Boolean);
105 pragma Inline
(Update_For_Queue_To_PO
);
106 -- Update the state of an existing entry call to reflect
107 -- the fact that it is being enqueued, based on
108 -- whether the current queuing action is with or without abort.
109 -- Call this only while holding the PO's lock.
110 -- It returns with the PO's lock still held.
112 ---------------------------------
113 -- Cancel_Protected_Entry_Call --
114 ---------------------------------
116 -- Compiler interface only. Do not call from within the RTS.
117 -- This should have analogous effect to Cancel_Task_Entry_Call,
118 -- setting the value of Block.Cancelled instead of returning
119 -- the parameter value Cancelled.
121 -- The effect should be idempotent, since the call may already
122 -- have been dequeued.
135 -- X : protected_entry_index := 1;
136 -- B80b : communication_block;
137 -- _init_proc (B80b);
142 -- procedure _clean is
144 -- if enqueued (B80b) then
145 -- cancel_protected_entry_call (B80b);
150 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
151 -- null_address, asynchronous_call, B80b, objectF => 0);
152 -- if enqueued (B80b) then
159 -- when _abort_signal =>
160 -- abort_undefer.all;
163 -- if not cancelled (B80b) then
168 -- If the entry call completes after we get into the abortable part,
169 -- Abort_Signal should be raised and ATC will take us to the at-end
170 -- handler, which will call _clean.
172 -- If the entry call returns with the call already completed,
173 -- we can skip this, and use the "if enqueued()" to go past
174 -- the at-end handler, but we will still call _clean.
176 -- If the abortable part completes before the entry call is Done,
177 -- it will call _clean.
179 -- If the entry call or the abortable part raises an exception,
180 -- we will still call _clean, but the value of Cancelled should not matter.
182 -- Whoever calls _clean first gets to decide whether the call
183 -- has been "cancelled".
185 -- Enqueued should be true if there is any chance that the call
186 -- is still on a queue. It seems to be safe to make it True if
187 -- the call was Onqueue at some point before return from
188 -- Protected_Entry_Call.
190 -- Cancelled should be true iff the abortable part completed
191 -- and succeeded in cancelling the entry call before it completed.
194 -- The need for Enqueued is less obvious.
195 -- The "if enqueued()" tests are not necessary, since both
196 -- Cancel_Protected_Entry_Call and Protected_Entry_Call must
197 -- do the same test internally, with locking. The one that
198 -- makes cancellation conditional may be a useful heuristic
199 -- since at least 1/2 the time the call should be off-queue
200 -- by that point. The other one seems totally useless, since
201 -- Protected_Entry_Call must do the same check and then
202 -- possibly wait for the call to be abortable, internally.
204 -- We can check Call.State here without locking the caller's mutex,
205 -- since the call must be over after returning from Wait_For_Completion.
206 -- No other task can access the call record at this point.
208 procedure Cancel_Protected_Entry_Call
209 (Block
: in out Communication_Block
)
212 Entry_Calls
.Try_To_Cancel_Entry_Call
(Block
.Cancelled
);
213 end Cancel_Protected_Entry_Call
;
219 function Cancelled
(Block
: Communication_Block
) return Boolean is
221 return Block
.Cancelled
;
224 -------------------------
225 -- Complete_Entry_Body --
226 -------------------------
228 procedure Complete_Entry_Body
(Object
: Protection_Entries_Access
) is
230 Exceptional_Complete_Entry_Body
(Object
, Ada
.Exceptions
.Null_Id
);
231 end Complete_Entry_Body
;
237 function Enqueued
(Block
: Communication_Block
) return Boolean is
239 return Block
.Enqueued
;
242 -------------------------------------
243 -- Exceptional_Complete_Entry_Body --
244 -------------------------------------
246 procedure Exceptional_Complete_Entry_Body
247 (Object
: Protection_Entries_Access
;
248 Ex
: Ada
.Exceptions
.Exception_Id
)
250 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
254 (Debug
.Trace
(STPO
.Self
, "Exceptional_Complete_Entry_Body", 'P'));
256 -- We must have abort deferred, since we are inside
257 -- a protected operation.
259 if Entry_Call
/= null then
261 -- The call was not requeued.
263 Entry_Call
.Exception_To_Raise
:= Ex
;
266 -- The caller should do the following, after return from this
267 -- procedure, if Call_In_Progress /= null
268 -- Write_Lock (Entry_Call.Self);
269 -- Initialization.Wakeup_Entry_Caller (STPO.Self, Entry_Call, Done);
270 -- Unlock (Entry_Call.Self);
273 end Exceptional_Complete_Entry_Body
;
279 procedure PO_Do_Or_Queue
281 Object
: Protection_Entries_Access
;
282 Entry_Call
: Entry_Call_Link
;
283 With_Abort
: Boolean)
285 E
: Protected_Entry_Index
:= Protected_Entry_Index
(Entry_Call
.E
);
286 New_Object
: Protection_Entries_Access
;
287 Ceiling_Violation
: Boolean;
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;
321 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
324 -- Body of current entry requeued the call
325 New_Object
:= To_Protection
(Entry_Call
.Called_PO
);
327 if New_Object
= null then
329 -- Call was requeued to a task
331 if not Rendezvous
.Task_Do_Or_Queue
332 (Self_ID
, Entry_Call
,
333 With_Abort
=> Entry_Call
.Requeue_With_Abort
)
335 Queuing
.Broadcast_Program_Error
336 (Self_ID
, Object
, Entry_Call
);
341 if Object
/= New_Object
then
342 -- Requeue is on a different object
344 Lock_Entries
(New_Object
, Ceiling_Violation
);
346 if Ceiling_Violation
then
347 Object
.Call_In_Progress
:= null;
348 Queuing
.Broadcast_Program_Error
349 (Self_ID
, Object
, Entry_Call
);
352 PO_Do_Or_Queue
(Self_ID
, New_Object
, Entry_Call
, With_Abort
);
353 PO_Service_Entries
(Self_ID
, New_Object
);
354 Unlock_Entries
(New_Object
);
358 -- Requeue is on same protected object
360 if Entry_Call
.Requeue_With_Abort
361 and then Entry_Call
.Cancellation_Attempted
363 -- If this is a requeue with abort and someone tried
364 -- to cancel this call, cancel it at this point.
366 Entry_Call
.State
:= Cancelled
;
370 if not With_Abort
or else
371 Entry_Call
.Mode
/= Conditional_Call
373 E
:= Protected_Entry_Index
(Entry_Call
.E
);
375 (New_Object
.Entry_Queues
(E
), Entry_Call
);
376 Update_For_Queue_To_PO
(Entry_Call
, With_Abort
);
380 -- Can we convert this recursion to a loop?
382 PO_Do_Or_Queue
(Self_ID
, New_Object
, Entry_Call
, With_Abort
);
387 elsif Entry_Call
.Mode
/= Conditional_Call
or else
389 Queuing
.Enqueue
(Object
.Entry_Queues
(E
), Entry_Call
);
390 Update_For_Queue_To_PO
(Entry_Call
, With_Abort
);
393 -- Conditional_Call and With_Abort
395 STPO
.Write_Lock
(Entry_Call
.Self
);
396 pragma Assert
(Entry_Call
.State
>= Was_Abortable
);
397 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Cancelled
);
398 STPO
.Unlock
(Entry_Call
.Self
);
403 Queuing
.Broadcast_Program_Error
(Self_ID
, Object
, Entry_Call
);
406 ------------------------
407 -- PO_Service_Entries --
408 ------------------------
410 procedure PO_Service_Entries
412 Object
: Protection_Entries_Access
)
414 Entry_Call
: Entry_Call_Link
;
415 E
: Protected_Entry_Index
;
417 New_Object
: Protection_Entries_Access
;
418 Ceiling_Violation
: Boolean;
422 Queuing
.Select_Protected_Entry_Call
(Self_ID
, Object
, Entry_Call
);
424 if Entry_Call
/= null then
425 E
:= Protected_Entry_Index
(Entry_Call
.E
);
427 -- Not abortable while service is in progress.
429 if Entry_Call
.State
= Now_Abortable
then
430 Entry_Call
.State
:= Was_Abortable
;
433 Object
.Call_In_Progress
:= Entry_Call
;
437 (Debug
.Trace
(Self_ID
, "POSE: start entry body", 'P'));
438 Object
.Entry_Bodies
(
439 Object
.Find_Body_Index
(Object
.Compiler_Info
, E
)).Action
(
440 Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, E
);
443 Queuing
.Broadcast_Program_Error
444 (Self_ID
, Object
, Entry_Call
);
447 if Object
.Call_In_Progress
/= null then
448 Object
.Call_In_Progress
:= null;
449 Caller
:= Entry_Call
.Self
;
450 STPO
.Write_Lock
(Caller
);
451 Initialization
.Wakeup_Entry_Caller
(Self_ID
, Entry_Call
, Done
);
452 STPO
.Unlock
(Caller
);
455 -- Call needs to be requeued
457 New_Object
:= To_Protection
(Entry_Call
.Called_PO
);
459 if New_Object
= null then
461 -- Call is to be requeued to a task entry
463 if not Rendezvous
.Task_Do_Or_Queue
464 (Self_ID
, Entry_Call
,
465 With_Abort
=> Entry_Call
.Requeue_With_Abort
)
467 Queuing
.Broadcast_Program_Error
468 (Self_ID
, Object
, Entry_Call
);
472 -- Call should be requeued to a PO
474 if Object
/= New_Object
then
475 -- Requeue is to different PO
477 Lock_Entries
(New_Object
, Ceiling_Violation
);
479 if Ceiling_Violation
then
480 Object
.Call_In_Progress
:= null;
481 Queuing
.Broadcast_Program_Error
482 (Self_ID
, Object
, Entry_Call
);
485 PO_Do_Or_Queue
(Self_ID
, New_Object
, Entry_Call
,
486 Entry_Call
.Requeue_With_Abort
);
487 PO_Service_Entries
(Self_ID
, New_Object
);
488 Unlock_Entries
(New_Object
);
492 -- Requeue is to same protected object
494 -- ??? Try to compensate apparent failure of the
495 -- scheduler on some OS (e.g VxWorks) to give higher
496 -- priority tasks a chance to run (see CXD6002).
500 if Entry_Call
.Requeue_With_Abort
501 and then Entry_Call
.Cancellation_Attempted
503 -- If this is a requeue with abort and someone tried
504 -- to cancel this call, cancel it at this point.
506 Entry_Call
.State
:= Cancelled
;
510 if not Entry_Call
.Requeue_With_Abort
or else
511 Entry_Call
.Mode
/= Conditional_Call
513 E
:= Protected_Entry_Index
(Entry_Call
.E
);
515 (New_Object
.Entry_Queues
(E
), Entry_Call
);
516 Update_For_Queue_To_PO
(Entry_Call
,
517 Entry_Call
.Requeue_With_Abort
);
520 PO_Do_Or_Queue
(Self_ID
, New_Object
, Entry_Call
,
521 Entry_Call
.Requeue_With_Abort
);
531 end PO_Service_Entries
;
533 ---------------------
534 -- Protected_Count --
535 ---------------------
537 function Protected_Count
538 (Object
: Protection_Entries
'Class;
539 E
: Protected_Entry_Index
)
543 return Queuing
.Count_Waiting
(Object
.Entry_Queues
(E
));
546 --------------------------
547 -- Protected_Entry_Call --
548 --------------------------
550 -- Compiler interface only. Do not call from within the RTS.
559 -- X : protected_entry_index := 1;
560 -- B85b : communication_block;
561 -- _init_proc (B85b);
563 -- protected_entry_call (rTV!(r)._object'unchecked_access, X,
564 -- null_address, conditional_call, B85b, objectF => 0);
565 -- if cancelled (B85b) then
572 -- See also Cancel_Protected_Entry_Call for code expansion of
573 -- asynchronous entry call.
575 -- The initial part of this procedure does not need to lock the
576 -- the calling task's ATCB, up to the point where the call record
577 -- first may be queued (PO_Do_Or_Queue), since before that no
578 -- other task will have access to the record.
580 -- If this is a call made inside of an abort deferred region,
581 -- the call should be never abortable.
583 -- If the call was not queued abortably, we need to wait
584 -- until it is before proceeding with the abortable part.
586 -- There are some heuristics here, just to save time for
587 -- frequently occurring cases. For example, we check
588 -- Initially_Abortable to try to avoid calling the procedure
589 -- Wait_Until_Abortable, since the normal case for async.
590 -- entry calls is to be queued abortably.
592 -- Another heuristic uses the Block.Enqueued to try to avoid
593 -- calling Cancel_Protected_Entry_Call if the call can be
594 -- served immediately.
596 procedure Protected_Entry_Call
597 (Object
: Protection_Entries_Access
;
598 E
: Protected_Entry_Index
;
599 Uninterpreted_Data
: System
.Address
;
601 Block
: out Communication_Block
)
603 Self_ID
: Task_ID
:= STPO
.Self
;
604 Entry_Call
: Entry_Call_Link
;
605 Initially_Abortable
: Boolean;
606 Ceiling_Violation
: Boolean;
610 (Debug
.Trace
(Self_ID
, "Protected_Entry_Call", 'P'));
612 if Self_ID
.ATC_Nesting_Level
= ATC_Level
'Last then
613 Raise_Exception
(Storage_Error
'Identity,
614 "not enough ATC nesting levels");
617 Initialization
.Defer_Abort
(Self_ID
);
618 Lock_Entries
(Object
, Ceiling_Violation
);
620 if Ceiling_Violation
then
622 -- Failed ceiling check
624 Initialization
.Undefer_Abort
(Self_ID
);
628 Block
.Self
:= Self_ID
;
629 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
+ 1;
631 (Debug
.Trace
(Self_ID
, "PEC: entered ATC level: " &
632 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
634 Self_ID
.Entry_Calls
(Self_ID
.ATC_Nesting_Level
)'Access;
635 Entry_Call
.Next
:= null;
636 Entry_Call
.Mode
:= Mode
;
637 Entry_Call
.Cancellation_Attempted
:= False;
639 if Self_ID
.Deferral_Level
> 1 then
640 Entry_Call
.State
:= Never_Abortable
;
642 Entry_Call
.State
:= Now_Abortable
;
645 Entry_Call
.E
:= Entry_Index
(E
);
646 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_ID
);
647 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
648 Entry_Call
.Called_PO
:= To_Address
(Object
);
649 Entry_Call
.Called_Task
:= null;
650 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
652 PO_Do_Or_Queue
(Self_ID
, Object
, Entry_Call
, With_Abort
=> True);
653 Initially_Abortable
:= Entry_Call
.State
= Now_Abortable
;
654 PO_Service_Entries
(Self_ID
, Object
);
656 Unlock_Entries
(Object
);
658 -- Try to prevent waiting later (in Cancel_Protected_Entry_Call)
659 -- for completed or cancelled calls. (This is a heuristic, only.)
661 if Entry_Call
.State
>= Done
then
663 -- Once State >= Done it will not change any more.
665 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
- 1;
667 (Debug
.Trace
(Self_ID
, "PEC: exited to ATC level: " &
668 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
669 Block
.Enqueued
:= False;
670 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
671 Initialization
.Undefer_Abort
(Self_ID
);
672 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
676 -- In this case we cannot conclude anything,
677 -- since State can change concurrently.
681 -- Now for the general case.
683 if Mode
= Asynchronous_Call
then
685 -- Try to avoid an expensive call.
687 if not Initially_Abortable
then
688 Entry_Calls
.Wait_Until_Abortable
(Self_ID
, Entry_Call
);
691 elsif Mode
< Asynchronous_Call
then
693 -- Simple_Call or Conditional_Call
695 STPO
.Write_Lock
(Self_ID
);
696 Entry_Calls
.Wait_For_Completion
(Self_ID
, Entry_Call
);
697 STPO
.Unlock
(Self_ID
);
698 Block
.Cancelled
:= Entry_Call
.State
= Cancelled
;
701 pragma Assert
(False);
705 Initialization
.Undefer_Abort
(Self_ID
);
706 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
708 end Protected_Entry_Call
;
710 ----------------------------
711 -- Protected_Entry_Caller --
712 ----------------------------
714 function Protected_Entry_Caller
(Object
: Protection_Entries
'Class)
717 return Object
.Call_In_Progress
.Self
;
718 end Protected_Entry_Caller
;
720 -----------------------------
721 -- Requeue_Protected_Entry --
722 -----------------------------
724 -- Compiler interface only. Do not call from within the RTS.
733 -- procedure rPT__E10b (O : address; P : address; E :
734 -- protected_entry_index) is
735 -- type rTVP is access rTV;
737 -- _object : rTVP := rTVP!(O);
740 -- rR : protection renames _object._object;
741 -- vP : integer renames _object.v;
742 -- bP : boolean renames _object.b;
746 -- requeue_protected_entry (rR'unchecked_access, rR'
747 -- unchecked_access, 2, false, objectF => 0, new_objectF =>
751 -- complete_entry_body (_object._object'unchecked_access, objectF =>
756 -- abort_undefer.all;
757 -- exceptional_complete_entry_body (_object._object'
758 -- unchecked_access, current_exception, objectF => 0);
762 procedure Requeue_Protected_Entry
763 (Object
: Protection_Entries_Access
;
764 New_Object
: Protection_Entries_Access
;
765 E
: Protected_Entry_Index
;
766 With_Abort
: Boolean)
768 Entry_Call
: constant Entry_Call_Link
:= Object
.Call_In_Progress
;
772 (Debug
.Trace
(STPO
.Self
, "Requeue_Protected_Entry", 'P'));
773 pragma Assert
(STPO
.Self
.Deferral_Level
> 0);
775 Entry_Call
.E
:= Entry_Index
(E
);
776 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
777 Entry_Call
.Called_Task
:= null;
778 Entry_Call
.Requeue_With_Abort
:= With_Abort
;
779 Object
.Call_In_Progress
:= null;
780 end Requeue_Protected_Entry
;
782 -------------------------------------
783 -- Requeue_Task_To_Protected_Entry --
784 -------------------------------------
786 -- Compiler interface only.
796 -- accept_call (1, A79b);
798 -- requeue_task_to_protected_entry (rTV!(r)._object'
799 -- unchecked_access, 2, false, new_objectF => 0);
802 -- complete_rendezvous;
804 -- when all others =>
805 -- exceptional_complete_rendezvous (get_gnat_exception);
808 procedure Requeue_Task_To_Protected_Entry
809 (New_Object
: Protection_Entries_Access
;
810 E
: Protected_Entry_Index
;
811 With_Abort
: Boolean)
813 Self_ID
: constant Task_ID
:= STPO
.Self
;
814 Entry_Call
: constant Entry_Call_Link
:= Self_ID
.Common
.Call
;
817 Initialization
.Defer_Abort
(Self_ID
);
818 STPO
.Write_Lock
(Self_ID
);
819 Entry_Call
.Needs_Requeue
:= True;
820 Entry_Call
.Requeue_With_Abort
:= With_Abort
;
821 Entry_Call
.Called_PO
:= To_Address
(New_Object
);
822 Entry_Call
.Called_Task
:= null;
823 STPO
.Unlock
(Self_ID
);
824 Entry_Call
.E
:= Entry_Index
(E
);
825 Initialization
.Undefer_Abort
(Self_ID
);
826 end Requeue_Task_To_Protected_Entry
;
829 -- Do we really need to lock Self_ID above?
830 -- Might the caller be trying to cancel?
831 -- If so, it should fail, since the call state should not be
832 -- abortable while the call is in service.
834 ---------------------
835 -- Service_Entries --
836 ---------------------
838 procedure Service_Entries
(Object
: Protection_Entries_Access
) is
839 Self_ID
: constant Task_ID
:= STPO
.Self
;
841 PO_Service_Entries
(Self_ID
, Object
);
844 --------------------------------
845 -- Timed_Protected_Entry_Call --
846 --------------------------------
848 -- Compiler interface only. Do not call from within the RTS.
850 procedure Timed_Protected_Entry_Call
851 (Object
: Protection_Entries_Access
;
852 E
: Protected_Entry_Index
;
853 Uninterpreted_Data
: System
.Address
;
856 Entry_Call_Successful
: out Boolean)
858 Self_ID
: Task_ID
:= STPO
.Self
;
859 Entry_Call
: Entry_Call_Link
;
860 Ceiling_Violation
: Boolean;
863 if Self_ID
.ATC_Nesting_Level
= ATC_Level
'Last then
864 Raise_Exception
(Storage_Error
'Identity,
865 "not enough ATC nesting levels");
868 Initialization
.Defer_Abort
(Self_ID
);
869 Lock_Entries
(Object
, Ceiling_Violation
);
871 if Ceiling_Violation
then
872 Initialization
.Undefer_Abort
(Self_ID
);
876 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
+ 1;
878 (Debug
.Trace
(Self_ID
, "TPEC: exited to ATC level: " &
879 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
881 Self_ID
.Entry_Calls
(Self_ID
.ATC_Nesting_Level
)'Access;
882 Entry_Call
.Next
:= null;
883 Entry_Call
.Mode
:= Timed_Call
;
884 Entry_Call
.Cancellation_Attempted
:= False;
886 if Self_ID
.Deferral_Level
> 1 then
887 Entry_Call
.State
:= Never_Abortable
;
889 Entry_Call
.State
:= Now_Abortable
;
892 Entry_Call
.E
:= Entry_Index
(E
);
893 Entry_Call
.Prio
:= STPO
.Get_Priority
(Self_ID
);
894 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
895 Entry_Call
.Called_PO
:= To_Address
(Object
);
896 Entry_Call
.Called_Task
:= null;
897 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
899 PO_Do_Or_Queue
(Self_ID
, Object
, Entry_Call
, With_Abort
=> True);
900 PO_Service_Entries
(Self_ID
, Object
);
902 Unlock_Entries
(Object
);
904 -- Try to avoid waiting for completed or cancelled calls.
906 if Entry_Call
.State
>= Done
then
907 Self_ID
.ATC_Nesting_Level
:= Self_ID
.ATC_Nesting_Level
- 1;
909 (Debug
.Trace
(Self_ID
, "TPEC: exited to ATC level: " &
910 ATC_Level
'Image (Self_ID
.ATC_Nesting_Level
), 'A'));
911 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
912 Initialization
.Undefer_Abort
(Self_ID
);
913 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
917 Entry_Calls
.Wait_For_Completion_With_Timeout
918 (Self_ID
, Entry_Call
, Timeout
, Mode
);
919 Initialization
.Undefer_Abort
(Self_ID
);
920 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
921 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
922 end Timed_Protected_Entry_Call
;
924 ----------------------------
925 -- Update_For_Queue_To_PO --
926 ----------------------------
928 -- Update the state of an existing entry call, based on
929 -- whether the current queuing action is with or without abort.
930 -- Call this only while holding the server's lock.
931 -- It returns with the server's lock released.
933 New_State
: constant array (Boolean, Entry_Call_State
)
934 of Entry_Call_State
:=
936 (Never_Abortable
=> Never_Abortable
,
937 Not_Yet_Abortable
=> Now_Abortable
,
938 Was_Abortable
=> Now_Abortable
,
939 Now_Abortable
=> Now_Abortable
,
941 Cancelled
=> Cancelled
),
943 (Never_Abortable
=> Never_Abortable
,
944 Not_Yet_Abortable
=> Not_Yet_Abortable
,
945 Was_Abortable
=> Was_Abortable
,
946 Now_Abortable
=> Now_Abortable
,
948 Cancelled
=> Cancelled
)
951 procedure Update_For_Queue_To_PO
952 (Entry_Call
: Entry_Call_Link
;
953 With_Abort
: Boolean)
955 Old
: Entry_Call_State
:= Entry_Call
.State
;
958 pragma Assert
(Old
< Done
);
960 Entry_Call
.State
:= New_State
(With_Abort
, Entry_Call
.State
);
962 if Entry_Call
.Mode
= Asynchronous_Call
then
963 if Old
< Was_Abortable
and then
964 Entry_Call
.State
= Now_Abortable
966 STPO
.Write_Lock
(Entry_Call
.Self
);
968 if Entry_Call
.Self
.Common
.State
= Async_Select_Sleep
then
969 STPO
.Wakeup
(Entry_Call
.Self
, Async_Select_Sleep
);
972 STPO
.Unlock
(Entry_Call
.Self
);
975 elsif Entry_Call
.Mode
= Conditional_Call
then
976 pragma Assert
(Entry_Call
.State
< Was_Abortable
);
979 end Update_For_Queue_To_PO
;
981 end System
.Tasking
.Protected_Objects
.Operations
;