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 -- S I N G L E _ E N T R Y --
10 -- Copyright (C) 1998-2007, 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 pragma Style_Checks
(All_Checks
);
36 -- Turn off subprogram ordering check, since restricted GNARLI
37 -- subprograms are gathered together at end.
39 -- This package provides an optimized version of Protected_Objects.Operations
40 -- and Protected_Objects.Entries making the following assumptions:
42 -- PO has only one entry
43 -- There is only one caller at a time (No_Entry_Queue)
44 -- There is no dynamic priority support (No_Dynamic_Priorities)
45 -- No Abort Statements
46 -- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0)
47 -- PO are at library level
49 -- None of the tasks will terminate (no need for finalization)
51 -- This interface is intended to be used in the ravenscar and restricted
52 -- profiles, the compiler is responsible for ensuring that the conditions
53 -- mentioned above are respected, except for the No_Entry_Queue restriction
54 -- that is checked dynamically in this package, since the check cannot be
55 -- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue,
59 -- Turn off polling, we do not want polling to take place during tasking
60 -- operations. It can cause infinite loops and other problems.
62 pragma Suppress
(All_Checks
);
64 with System
.Task_Primitives
.Operations
;
71 -- used for Exception_Id
74 with System
.Parameters
;
75 -- used for Single_Lock
77 package body System
.Tasking
.Protected_Objects
.Single_Entry
is
79 package STPO
renames System
.Task_Primitives
.Operations
;
83 -----------------------
84 -- Local Subprograms --
85 -----------------------
87 procedure Send_Program_Error
89 Entry_Call
: Entry_Call_Link
);
90 pragma Inline
(Send_Program_Error
);
91 -- Raise Program_Error in the caller of the specified entry call
93 --------------------------
94 -- Entry Calls Handling --
95 --------------------------
97 procedure Wakeup_Entry_Caller
99 Entry_Call
: Entry_Call_Link
;
100 New_State
: Entry_Call_State
);
101 pragma Inline
(Wakeup_Entry_Caller
);
102 -- This is called at the end of service of an entry call,
103 -- to abort the caller if he is in an abortable part, and
104 -- to wake up the caller if he is on Entry_Caller_Sleep.
105 -- Call it holding the lock of Entry_Call.Self.
107 -- Timed_Call or Simple_Call:
108 -- The caller is waiting on Entry_Caller_Sleep, in
109 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
111 procedure Wait_For_Completion
(Entry_Call
: Entry_Call_Link
);
112 pragma Inline
(Wait_For_Completion
);
113 -- This procedure suspends the calling task until the specified entry call
114 -- has either been completed or cancelled. On exit, the call will not be
115 -- queued. This waits for calls on protected entries.
116 -- Call this only when holding Self_ID locked.
118 procedure Wait_For_Completion_With_Timeout
119 (Entry_Call
: Entry_Call_Link
;
120 Wakeup_Time
: Duration;
122 -- Same as Wait_For_Completion but it waits for a timeout with the value
123 -- specified in Wakeup_Time as well.
125 procedure Check_Exception
127 Entry_Call
: Entry_Call_Link
);
128 pragma Inline
(Check_Exception
);
129 -- Raise any pending exception from the Entry_Call.
130 -- This should be called at the end of every compiler interface procedure
131 -- that implements an entry call.
132 -- The caller should not be holding any locks, or there will be deadlock.
134 procedure PO_Do_Or_Queue
136 Object
: Protection_Entry_Access
;
137 Entry_Call
: Entry_Call_Link
);
138 -- This procedure executes or queues an entry call, depending
139 -- on the status of the corresponding barrier. It assumes that the
140 -- specified object is locked.
142 ---------------------
143 -- Check_Exception --
144 ---------------------
146 procedure Check_Exception
148 Entry_Call
: Entry_Call_Link
)
150 pragma Warnings
(Off
, Self_ID
);
152 procedure Internal_Raise
(X
: Ada
.Exceptions
.Exception_Id
);
153 pragma Import
(C
, Internal_Raise
, "__gnat_raise_with_msg");
155 use type Ada
.Exceptions
.Exception_Id
;
157 E
: constant Ada
.Exceptions
.Exception_Id
:=
158 Entry_Call
.Exception_To_Raise
;
161 if E
/= Ada
.Exceptions
.Null_Id
then
166 ------------------------
167 -- Send_Program_Error --
168 ------------------------
170 procedure Send_Program_Error
172 Entry_Call
: Entry_Call_Link
)
174 Caller
: constant Task_Id
:= Entry_Call
.Self
;
176 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
182 STPO
.Write_Lock
(Caller
);
183 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
184 STPO
.Unlock
(Caller
);
189 end Send_Program_Error
;
191 -------------------------
192 -- Wait_For_Completion --
193 -------------------------
195 procedure Wait_For_Completion
(Entry_Call
: Entry_Call_Link
) is
196 Self_Id
: constant Task_Id
:= Entry_Call
.Self
;
198 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
199 STPO
.Sleep
(Self_Id
, Entry_Caller_Sleep
);
200 Self_Id
.Common
.State
:= Runnable
;
201 end Wait_For_Completion
;
203 --------------------------------------
204 -- Wait_For_Completion_With_Timeout --
205 --------------------------------------
207 procedure Wait_For_Completion_With_Timeout
208 (Entry_Call
: Entry_Call_Link
;
209 Wakeup_Time
: Duration;
212 Self_Id
: constant Task_Id
:= Entry_Call
.Self
;
216 pragma Unreferenced
(Yielded
);
218 use type Ada
.Exceptions
.Exception_Id
;
221 -- This procedure waits for the entry call to be served, with a timeout.
222 -- It tries to cancel the call if the timeout expires before the call is
225 -- If we wake up from the timed sleep operation here, it may be for the
226 -- following possible reasons:
228 -- 1) The entry call is done being served.
229 -- 2) The timeout has expired (Timedout = True)
231 -- Once the timeout has expired we may need to continue to wait if the
232 -- call is already being serviced. In that case, we want to go back to
233 -- sleep, but without any timeout. The variable Timedout is used to
234 -- control this. If the Timedout flag is set, we do not need to Sleep
235 -- with a timeout. We just sleep until we get a wakeup for some status
238 pragma Assert
(Entry_Call
.Mode
= Timed_Call
);
239 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
242 (Self_Id
, Wakeup_Time
, Mode
, Entry_Caller_Sleep
, Timedout
, Yielded
);
245 Entry_Call
.State
:= Cancelled
;
247 Entry_Call
.State
:= Done
;
250 Self_Id
.Common
.State
:= Runnable
;
251 end Wait_For_Completion_With_Timeout
;
253 -------------------------
254 -- Wakeup_Entry_Caller --
255 -------------------------
257 -- This is called at the end of service of an entry call, to abort the
258 -- caller if he is in an abortable part, and to wake up the caller if it
259 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
261 -- (This enforces the rule that a task must be off-queue if its state is
262 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
264 -- Timed_Call or Simple_Call:
265 -- The caller is waiting on Entry_Caller_Sleep, in
266 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
269 -- The caller might be in Wait_For_Completion,
270 -- waiting for a rendezvous (possibly requeued without abort)
273 procedure Wakeup_Entry_Caller
275 Entry_Call
: Entry_Call_Link
;
276 New_State
: Entry_Call_State
)
278 pragma Warnings
(Off
, Self_ID
);
280 Caller
: constant Task_Id
:= Entry_Call
.Self
;
283 pragma Assert
(New_State
= Done
or else New_State
= Cancelled
);
285 (Caller
.Common
.State
/= Terminated
and then
286 Caller
.Common
.State
/= Unactivated
);
288 Entry_Call
.State
:= New_State
;
289 STPO
.Wakeup
(Caller
, Entry_Caller_Sleep
);
290 end Wakeup_Entry_Caller
;
292 -----------------------
293 -- Restricted GNARLI --
294 -----------------------
296 --------------------------------
297 -- Complete_Single_Entry_Body --
298 --------------------------------
300 procedure Complete_Single_Entry_Body
(Object
: Protection_Entry_Access
) is
301 pragma Warnings
(Off
, Object
);
304 -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise
305 -- has already been set to Null_Id).
308 end Complete_Single_Entry_Body
;
310 --------------------------------------------
311 -- Exceptional_Complete_Single_Entry_Body --
312 --------------------------------------------
314 procedure Exceptional_Complete_Single_Entry_Body
315 (Object
: Protection_Entry_Access
;
316 Ex
: Ada
.Exceptions
.Exception_Id
) is
318 Object
.Call_In_Progress
.Exception_To_Raise
:= Ex
;
319 end Exceptional_Complete_Single_Entry_Body
;
321 ---------------------------------
322 -- Initialize_Protection_Entry --
323 ---------------------------------
325 procedure Initialize_Protection_Entry
326 (Object
: Protection_Entry_Access
;
327 Ceiling_Priority
: Integer;
328 Compiler_Info
: System
.Address
;
329 Entry_Body
: Entry_Body_Access
)
331 Init_Priority
: Integer := Ceiling_Priority
;
333 if Init_Priority
= Unspecified_Priority
then
334 Init_Priority
:= System
.Priority
'Last;
337 STPO
.Initialize_Lock
(Init_Priority
, Object
.L
'Access);
338 Object
.Ceiling
:= System
.Any_Priority
(Init_Priority
);
339 Object
.Owner
:= Null_Task
;
340 Object
.Compiler_Info
:= Compiler_Info
;
341 Object
.Call_In_Progress
:= null;
342 Object
.Entry_Body
:= Entry_Body
;
343 Object
.Entry_Queue
:= null;
344 end Initialize_Protection_Entry
;
350 -- Compiler interface only.
351 -- Do not call this procedure from within the run-time system.
353 procedure Lock_Entry
(Object
: Protection_Entry_Access
) is
354 Ceiling_Violation
: Boolean;
357 -- If pragma Detect_Blocking is active then, as described in the ARM
358 -- 9.5.1, par. 15, we must check whether this is an external call on a
359 -- protected subprogram with the same target object as that of the
360 -- protected action that is currently in progress (i.e., if the caller
361 -- is already the protected object's owner). If this is the case hence
362 -- Program_Error must be raised.
364 if Detect_Blocking
and then Object
.Owner
= Self
then
368 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
370 if Ceiling_Violation
then
374 -- We are entering in a protected action, so that we increase the
375 -- protected object nesting level (if pragma Detect_Blocking is
376 -- active), and update the protected object's owner.
378 if Detect_Blocking
then
380 Self_Id
: constant Task_Id
:= Self
;
383 -- Update the protected object's owner
385 Object
.Owner
:= Self_Id
;
387 -- Increase protected object nesting level
389 Self_Id
.Common
.Protected_Action_Nesting
:=
390 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
395 --------------------------
396 -- Lock_Read_Only_Entry --
397 --------------------------
399 -- Compiler interface only
401 -- Do not call this procedure from within the runtime system
403 procedure Lock_Read_Only_Entry
(Object
: Protection_Entry_Access
) is
404 Ceiling_Violation
: Boolean;
407 -- If pragma Detect_Blocking is active then, as described in the ARM
408 -- 9.5.1, par. 15, we must check whether this is an external call on a
409 -- protected subprogram with the same target object as that of the
410 -- protected action that is currently in progress (i.e., if the caller
411 -- is already the protected object's owner). If this is the case hence
412 -- Program_Error must be raised.
414 -- Note that in this case (getting read access), several tasks may
415 -- have read ownership of the protected object, so that this method of
416 -- storing the (single) protected object's owner does not work
417 -- reliably for read locks. However, this is the approach taken for two
418 -- major reasosn: first, this function is not currently being used (it
419 -- is provided for possible future use), and second, it largely
420 -- simplifies the implementation.
422 if Detect_Blocking
and then Object
.Owner
= Self
then
426 STPO
.Read_Lock
(Object
.L
'Access, Ceiling_Violation
);
428 if Ceiling_Violation
then
432 -- We are entering in a protected action, so that we increase the
433 -- protected object nesting level (if pragma Detect_Blocking is
434 -- active), and update the protected object's owner.
436 if Detect_Blocking
then
438 Self_Id
: constant Task_Id
:= Self
;
441 -- Update the protected object's owner
443 Object
.Owner
:= Self_Id
;
445 -- Increase protected object nesting level
447 Self_Id
.Common
.Protected_Action_Nesting
:=
448 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
451 end Lock_Read_Only_Entry
;
457 procedure PO_Do_Or_Queue
459 Object
: Protection_Entry_Access
;
460 Entry_Call
: Entry_Call_Link
)
462 Barrier_Value
: Boolean;
465 -- When the Action procedure for an entry body returns, it must be
466 -- completed (having called [Exceptional_]Complete_Entry_Body).
468 Barrier_Value
:= Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1);
470 if Barrier_Value
then
471 if Object
.Call_In_Progress
/= null then
473 -- This violates the No_Entry_Queue restriction, send
474 -- Program_Error to the caller.
476 Send_Program_Error
(Self_Id
, Entry_Call
);
480 Object
.Call_In_Progress
:= Entry_Call
;
481 Object
.Entry_Body
.Action
482 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
483 Object
.Call_In_Progress
:= null;
489 STPO
.Write_Lock
(Entry_Call
.Self
);
490 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
491 STPO
.Unlock
(Entry_Call
.Self
);
497 elsif Entry_Call
.Mode
/= Conditional_Call
then
498 if Object
.Entry_Queue
/= null then
500 -- This violates the No_Entry_Queue restriction, send
501 -- Program_Error to the caller.
503 Send_Program_Error
(Self_Id
, Entry_Call
);
506 Object
.Entry_Queue
:= Entry_Call
;
516 STPO
.Write_Lock
(Entry_Call
.Self
);
517 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Cancelled
);
518 STPO
.Unlock
(Entry_Call
.Self
);
528 (Self_Id
, Entry_Call
);
531 ----------------------------
532 -- Protected_Single_Count --
533 ----------------------------
535 function Protected_Count_Entry
(Object
: Protection_Entry
) return Natural is
537 if Object
.Entry_Queue
/= null then
542 end Protected_Count_Entry
;
544 ---------------------------------
545 -- Protected_Single_Entry_Call --
546 ---------------------------------
548 procedure Protected_Single_Entry_Call
549 (Object
: Protection_Entry_Access
;
550 Uninterpreted_Data
: System
.Address
;
553 Self_Id
: constant Task_Id
:= STPO
.Self
;
554 Entry_Call
: Entry_Call_Record
renames Self_Id
.Entry_Calls
(1);
556 -- If pragma Detect_Blocking is active then Program_Error must be
557 -- raised if this potentially blocking operation is called from a
561 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
563 Ada
.Exceptions
.Raise_Exception
564 (Program_Error
'Identity, "potentially blocking operation");
569 Entry_Call
.Mode
:= Mode
;
570 Entry_Call
.State
:= Now_Abortable
;
571 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
572 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
574 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
'Access);
575 Unlock_Entry
(Object
);
577 -- The call is either `Done' or not. It cannot be cancelled since there
578 -- is no ATC construct.
580 pragma Assert
(Entry_Call
.State
/= Cancelled
);
582 if Entry_Call
.State
/= Done
then
587 STPO
.Write_Lock
(Self_Id
);
588 Wait_For_Completion
(Entry_Call
'Access);
589 STPO
.Unlock
(Self_Id
);
596 Check_Exception
(Self_Id
, Entry_Call
'Access);
597 end Protected_Single_Entry_Call
;
599 -----------------------------------
600 -- Protected_Single_Entry_Caller --
601 -----------------------------------
603 function Protected_Single_Entry_Caller
604 (Object
: Protection_Entry
) return Task_Id
is
606 return Object
.Call_In_Progress
.Self
;
607 end Protected_Single_Entry_Caller
;
613 procedure Service_Entry
(Object
: Protection_Entry_Access
) is
614 Self_Id
: constant Task_Id
:= STPO
.Self
;
615 Entry_Call
: constant Entry_Call_Link
:= Object
.Entry_Queue
;
619 if Entry_Call
/= null
620 and then Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1)
622 Object
.Entry_Queue
:= null;
624 if Object
.Call_In_Progress
/= null then
626 -- Violation of No_Entry_Queue restriction, raise exception
628 Send_Program_Error
(Self_Id
, Entry_Call
);
629 Unlock_Entry
(Object
);
633 Object
.Call_In_Progress
:= Entry_Call
;
634 Object
.Entry_Body
.Action
635 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
636 Object
.Call_In_Progress
:= null;
637 Caller
:= Entry_Call
.Self
;
638 Unlock_Entry
(Object
);
644 STPO
.Write_Lock
(Caller
);
645 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
646 STPO
.Unlock
(Caller
);
653 -- Just unlock the entry
655 Unlock_Entry
(Object
);
660 Send_Program_Error
(Self_Id
, Entry_Call
);
661 Unlock_Entry
(Object
);
664 ---------------------------------------
665 -- Timed_Protected_Single_Entry_Call --
666 ---------------------------------------
668 -- Compiler interface only (do not call from within the RTS)
670 procedure Timed_Protected_Single_Entry_Call
671 (Object
: Protection_Entry_Access
;
672 Uninterpreted_Data
: System
.Address
;
675 Entry_Call_Successful
: out Boolean)
677 Self_Id
: constant Task_Id
:= STPO
.Self
;
678 Entry_Call
: Entry_Call_Record
renames Self_Id
.Entry_Calls
(1);
679 Ceiling_Violation
: Boolean;
682 -- If pragma Detect_Blocking is active then Program_Error must be
683 -- raised if this potentially blocking operation is called from a
687 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
689 Ada
.Exceptions
.Raise_Exception
690 (Program_Error
'Identity, "potentially blocking operation");
693 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
695 if Ceiling_Violation
then
699 Entry_Call
.Mode
:= Timed_Call
;
700 Entry_Call
.State
:= Now_Abortable
;
701 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
702 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
704 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
'Access);
705 Unlock_Entry
(Object
);
707 -- Try to avoid waiting for completed calls.
708 -- The call is either `Done' or not. It cannot be cancelled since there
709 -- is no ATC construct and the timed wait has not started yet.
711 pragma Assert
(Entry_Call
.State
/= Cancelled
);
713 if Entry_Call
.State
= Done
then
714 Check_Exception
(Self_Id
, Entry_Call
'Access);
715 Entry_Call_Successful
:= True;
722 STPO
.Write_Lock
(Self_Id
);
725 Wait_For_Completion_With_Timeout
(Entry_Call
'Access, Timeout
, Mode
);
730 STPO
.Unlock
(Self_Id
);
733 pragma Assert
(Entry_Call
.State
>= Done
);
735 Check_Exception
(Self_Id
, Entry_Call
'Access);
736 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
737 end Timed_Protected_Single_Entry_Call
;
743 procedure Unlock_Entry
(Object
: Protection_Entry_Access
) is
745 -- We are exiting from a protected action, so that we decrease the
746 -- protected object nesting level (if pragma Detect_Blocking is
747 -- active), and remove ownership of the protected object.
749 if Detect_Blocking
then
751 Self_Id
: constant Task_Id
:= Self
;
754 -- Calls to this procedure can only take place when being within
755 -- a protected action and when the caller is the protected
758 pragma Assert
(Self_Id
.Common
.Protected_Action_Nesting
> 0
759 and then Object
.Owner
= Self_Id
);
761 -- Remove ownership of the protected object
763 Object
.Owner
:= Null_Task
;
765 Self_Id
.Common
.Protected_Action_Nesting
:=
766 Self_Id
.Common
.Protected_Action_Nesting
- 1;
770 STPO
.Unlock
(Object
.L
'Access);
773 end System
.Tasking
.Protected_Objects
.Single_Entry
;