1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
9 -- Copyright (C) 1998-2004, 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 pragma Style_Checks
(All_Checks
);
35 -- Turn off subprogram ordering check, since restricted GNARLI
36 -- subprograms are gathered together at end.
38 -- This package provides an optimized version of Protected_Objects.Operations
39 -- and Protected_Objects.Entries making the following assumptions:
41 -- PO have only one entry
42 -- There is only one caller at a time (No_Entry_Queue)
43 -- There is no dynamic priority support (No_Dynamic_Priorities)
44 -- No Abort Statements
45 -- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0)
46 -- PO are at library level
48 -- None of the tasks will terminate (no need for finalization)
50 -- This interface is intended to be used in the ravenscar and restricted
51 -- profiles, the compiler is responsible for ensuring that the conditions
52 -- mentioned above are respected, except for the No_Entry_Queue restriction
53 -- that is checked dynamically in this package, since the check cannot be
54 -- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue,
58 -- Turn off polling, we do not want polling to take place during tasking
59 -- operations. It can cause infinite loops and other problems.
61 pragma Suppress
(All_Checks
);
63 with System
.Task_Primitives
.Operations
;
70 -- used for Exception_Id
73 with System
.Parameters
;
74 -- used for Single_Lock
76 package body System
.Tasking
.Protected_Objects
.Single_Entry
is
78 package STPO
renames System
.Task_Primitives
.Operations
;
82 -----------------------
83 -- Local Subprograms --
84 -----------------------
86 procedure Send_Program_Error
88 Entry_Call
: Entry_Call_Link
);
89 pragma Inline
(Send_Program_Error
);
90 -- Raise Program_Error in the caller of the specified entry call
92 --------------------------
93 -- Entry Calls Handling --
94 --------------------------
96 procedure Wakeup_Entry_Caller
98 Entry_Call
: Entry_Call_Link
;
99 New_State
: Entry_Call_State
);
100 pragma Inline
(Wakeup_Entry_Caller
);
101 -- This is called at the end of service of an entry call,
102 -- to abort the caller if he is in an abortable part, and
103 -- to wake up the caller if he is on Entry_Caller_Sleep.
104 -- Call it holding the lock of Entry_Call.Self.
106 -- Timed_Call or Simple_Call:
107 -- The caller is waiting on Entry_Caller_Sleep, in
108 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
110 procedure Wait_For_Completion
(Entry_Call
: Entry_Call_Link
);
111 pragma Inline
(Wait_For_Completion
);
112 -- This procedure suspends the calling task until the specified entry call
113 -- has either been completed or cancelled. On exit, the call will not be
114 -- queued. This waits for calls on protected entries.
115 -- Call this only when holding Self_ID locked.
117 procedure Wait_For_Completion_With_Timeout
118 (Entry_Call
: Entry_Call_Link
;
119 Wakeup_Time
: Duration;
121 -- Same as Wait_For_Completion but it waits for a timeout with the value
122 -- specified in Wakeup_Time as well.
124 procedure Check_Exception
126 Entry_Call
: Entry_Call_Link
);
127 pragma Inline
(Check_Exception
);
128 -- Raise any pending exception from the Entry_Call.
129 -- This should be called at the end of every compiler interface procedure
130 -- that implements an entry call.
131 -- The caller should not be holding any locks, or there will be deadlock.
133 procedure PO_Do_Or_Queue
135 Object
: Protection_Entry_Access
;
136 Entry_Call
: Entry_Call_Link
);
137 -- This procedure executes or queues an entry call, depending
138 -- on the status of the corresponding barrier. It assumes that the
139 -- specified object is locked.
141 ---------------------
142 -- Check_Exception --
143 ---------------------
145 procedure Check_Exception
147 Entry_Call
: Entry_Call_Link
)
149 pragma Warnings
(Off
, Self_ID
);
151 procedure Internal_Raise
(X
: Ada
.Exceptions
.Exception_Id
);
152 pragma Import
(C
, Internal_Raise
, "__gnat_raise_with_msg");
154 use type Ada
.Exceptions
.Exception_Id
;
156 E
: constant Ada
.Exceptions
.Exception_Id
:=
157 Entry_Call
.Exception_To_Raise
;
160 if E
/= Ada
.Exceptions
.Null_Id
then
165 ------------------------
166 -- Send_Program_Error --
167 ------------------------
169 procedure Send_Program_Error
171 Entry_Call
: Entry_Call_Link
)
173 Caller
: constant Task_Id
:= Entry_Call
.Self
;
175 Entry_Call
.Exception_To_Raise
:= Program_Error
'Identity;
181 STPO
.Write_Lock
(Caller
);
182 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
183 STPO
.Unlock
(Caller
);
188 end Send_Program_Error
;
190 -------------------------
191 -- Wait_For_Completion --
192 -------------------------
194 procedure Wait_For_Completion
(Entry_Call
: Entry_Call_Link
) is
195 Self_Id
: constant Task_Id
:= Entry_Call
.Self
;
197 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
198 STPO
.Sleep
(Self_Id
, Entry_Caller_Sleep
);
199 Self_Id
.Common
.State
:= Runnable
;
200 end Wait_For_Completion
;
202 --------------------------------------
203 -- Wait_For_Completion_With_Timeout --
204 --------------------------------------
206 procedure Wait_For_Completion_With_Timeout
207 (Entry_Call
: Entry_Call_Link
;
208 Wakeup_Time
: Duration;
211 Self_Id
: constant Task_Id
:= Entry_Call
.Self
;
215 use type Ada
.Exceptions
.Exception_Id
;
218 -- This procedure waits for the entry call to be served, with a timeout.
219 -- It tries to cancel the call if the timeout expires before the call is
222 -- If we wake up from the timed sleep operation here, it may be for the
223 -- following possible reasons:
225 -- 1) The entry call is done being served.
226 -- 2) The timeout has expired (Timedout = True)
228 -- Once the timeout has expired we may need to continue to wait if the
229 -- call is already being serviced. In that case, we want to go back to
230 -- sleep, but without any timeout. The variable Timedout is used to
231 -- control this. If the Timedout flag is set, we do not need to Sleep
232 -- with a timeout. We just sleep until we get a wakeup for some status
235 pragma Assert
(Entry_Call
.Mode
= Timed_Call
);
236 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
239 (Self_Id
, Wakeup_Time
, Mode
, Entry_Caller_Sleep
, Timedout
, Yielded
);
242 Entry_Call
.State
:= Cancelled
;
244 Entry_Call
.State
:= Done
;
247 Self_Id
.Common
.State
:= Runnable
;
248 end Wait_For_Completion_With_Timeout
;
250 -------------------------
251 -- Wakeup_Entry_Caller --
252 -------------------------
254 -- This is called at the end of service of an entry call, to abort the
255 -- caller if he is in an abortable part, and to wake up the caller if it
256 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
258 -- (This enforces the rule that a task must be off-queue if its state is
259 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
261 -- Timed_Call or Simple_Call:
262 -- The caller is waiting on Entry_Caller_Sleep, in
263 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
266 -- The caller might be in Wait_For_Completion,
267 -- waiting for a rendezvous (possibly requeued without abort)
270 procedure Wakeup_Entry_Caller
272 Entry_Call
: Entry_Call_Link
;
273 New_State
: Entry_Call_State
)
275 pragma Warnings
(Off
, Self_ID
);
277 Caller
: constant Task_Id
:= Entry_Call
.Self
;
280 pragma Assert
(New_State
= Done
or else New_State
= Cancelled
);
282 (Caller
.Common
.State
/= Terminated
and then
283 Caller
.Common
.State
/= Unactivated
);
285 Entry_Call
.State
:= New_State
;
286 STPO
.Wakeup
(Caller
, Entry_Caller_Sleep
);
287 end Wakeup_Entry_Caller
;
289 -----------------------
290 -- Restricted GNARLI --
291 -----------------------
293 --------------------------------
294 -- Complete_Single_Entry_Body --
295 --------------------------------
297 procedure Complete_Single_Entry_Body
(Object
: Protection_Entry_Access
) is
298 pragma Warnings
(Off
, Object
);
301 -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise
302 -- has already been set to Null_Id).
305 end Complete_Single_Entry_Body
;
307 --------------------------------------------
308 -- Exceptional_Complete_Single_Entry_Body --
309 --------------------------------------------
311 procedure Exceptional_Complete_Single_Entry_Body
312 (Object
: Protection_Entry_Access
;
313 Ex
: Ada
.Exceptions
.Exception_Id
) is
315 Object
.Call_In_Progress
.Exception_To_Raise
:= Ex
;
316 end Exceptional_Complete_Single_Entry_Body
;
318 ---------------------------------
319 -- Initialize_Protection_Entry --
320 ---------------------------------
322 procedure Initialize_Protection_Entry
323 (Object
: Protection_Entry_Access
;
324 Ceiling_Priority
: Integer;
325 Compiler_Info
: System
.Address
;
326 Entry_Body
: Entry_Body_Access
)
328 Init_Priority
: Integer := Ceiling_Priority
;
330 if Init_Priority
= Unspecified_Priority
then
331 Init_Priority
:= System
.Priority
'Last;
334 STPO
.Initialize_Lock
(Init_Priority
, Object
.L
'Access);
335 Object
.Ceiling
:= System
.Any_Priority
(Init_Priority
);
336 Object
.Compiler_Info
:= Compiler_Info
;
337 Object
.Call_In_Progress
:= null;
338 Object
.Entry_Body
:= Entry_Body
;
339 Object
.Entry_Queue
:= null;
340 end Initialize_Protection_Entry
;
346 -- Compiler interface only.
347 -- Do not call this procedure from within the run-time system.
349 procedure Lock_Entry
(Object
: Protection_Entry_Access
) is
350 Ceiling_Violation
: Boolean;
353 -- If pragma Detect_Blocking is active then Program_Error must
354 -- be raised if this potentially blocking operation is called from
355 -- a protected action, and the protected object nesting level
356 -- must be increased.
358 if Detect_Blocking
then
360 Self_Id
: constant Task_Id
:= STPO
.Self
;
362 if Self_Id
.Common
.Protected_Action_Nesting
> 0 then
363 Ada
.Exceptions
.Raise_Exception
364 (Program_Error
'Identity, "potentially blocking operation");
366 -- We are entering in a protected action, so that we
367 -- increase the protected object nesting level.
369 Self_Id
.Common
.Protected_Action_Nesting
:=
370 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
375 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
377 if Ceiling_Violation
then
382 --------------------------
383 -- Lock_Read_Only_Entry --
384 --------------------------
386 -- Compiler interface only.
387 -- Do not call this procedure from within the runtime system.
389 procedure Lock_Read_Only_Entry
(Object
: Protection_Entry_Access
) is
390 Ceiling_Violation
: Boolean;
393 -- If pragma Detect_Blocking is active then Program_Error must be
394 -- raised if this potentially blocking operation is called from a
395 -- protected action, and the protected object nesting level must
398 if Detect_Blocking
then
400 Self_Id
: constant Task_Id
:= STPO
.Self
;
402 if Self_Id
.Common
.Protected_Action_Nesting
> 0 then
403 Ada
.Exceptions
.Raise_Exception
404 (Program_Error
'Identity, "potentially blocking operation");
406 -- We are entering in a protected action, so that we
407 -- increase the protected object nesting level.
409 Self_Id
.Common
.Protected_Action_Nesting
:=
410 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
415 STPO
.Read_Lock
(Object
.L
'Access, Ceiling_Violation
);
417 if Ceiling_Violation
then
420 end Lock_Read_Only_Entry
;
426 procedure PO_Do_Or_Queue
428 Object
: Protection_Entry_Access
;
429 Entry_Call
: Entry_Call_Link
)
431 Barrier_Value
: Boolean;
433 -- When the Action procedure for an entry body returns, it must be
434 -- completed (having called [Exceptional_]Complete_Entry_Body).
436 Barrier_Value
:= Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1);
438 if Barrier_Value
then
439 if Object
.Call_In_Progress
/= null then
440 -- This violates the No_Entry_Queue restriction, send
441 -- Program_Error to the caller.
443 Send_Program_Error
(Self_Id
, Entry_Call
);
447 Object
.Call_In_Progress
:= Entry_Call
;
448 Object
.Entry_Body
.Action
449 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
450 Object
.Call_In_Progress
:= null;
456 STPO
.Write_Lock
(Entry_Call
.Self
);
457 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
458 STPO
.Unlock
(Entry_Call
.Self
);
464 elsif Entry_Call
.Mode
/= Conditional_Call
then
465 Object
.Entry_Queue
:= Entry_Call
;
473 STPO
.Write_Lock
(Entry_Call
.Self
);
474 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Cancelled
);
475 STPO
.Unlock
(Entry_Call
.Self
);
485 (Self_Id
, Entry_Call
);
488 ----------------------------
489 -- Protected_Single_Count --
490 ----------------------------
492 function Protected_Count_Entry
(Object
: Protection_Entry
) return Natural is
494 if Object
.Entry_Queue
/= null then
499 end Protected_Count_Entry
;
501 ---------------------------------
502 -- Protected_Single_Entry_Call --
503 ---------------------------------
505 procedure Protected_Single_Entry_Call
506 (Object
: Protection_Entry_Access
;
507 Uninterpreted_Data
: System
.Address
;
510 Self_Id
: constant Task_Id
:= STPO
.Self
;
511 Entry_Call
: Entry_Call_Record
renames Self_Id
.Entry_Calls
(1);
512 Ceiling_Violation
: Boolean;
515 -- If pragma Detect_Blocking is active then Program_Error must be
516 -- raised if this potentially blocking operation is called from a
520 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
522 Ada
.Exceptions
.Raise_Exception
523 (Program_Error
'Identity, "potentially blocking operation");
526 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
528 if Ceiling_Violation
then
532 Entry_Call
.Mode
:= Mode
;
533 Entry_Call
.State
:= Now_Abortable
;
534 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
535 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
537 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
'Access);
538 Unlock_Entry
(Object
);
540 -- The call is either `Done' or not. It cannot be cancelled since there
541 -- is no ATC construct.
543 pragma Assert
(Entry_Call
.State
/= Cancelled
);
545 if Entry_Call
.State
/= Done
then
550 STPO
.Write_Lock
(Self_Id
);
551 Wait_For_Completion
(Entry_Call
'Access);
552 STPO
.Unlock
(Self_Id
);
559 Check_Exception
(Self_Id
, Entry_Call
'Access);
560 end Protected_Single_Entry_Call
;
562 -----------------------------------
563 -- Protected_Single_Entry_Caller --
564 -----------------------------------
566 function Protected_Single_Entry_Caller
567 (Object
: Protection_Entry
) return Task_Id
is
569 return Object
.Call_In_Progress
.Self
;
570 end Protected_Single_Entry_Caller
;
576 procedure Service_Entry
(Object
: Protection_Entry_Access
) is
577 Self_Id
: constant Task_Id
:= STPO
.Self
;
578 Entry_Call
: constant Entry_Call_Link
:= Object
.Entry_Queue
;
582 if Entry_Call
/= null then
583 if Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1) then
584 Object
.Entry_Queue
:= null;
586 if Object
.Call_In_Progress
/= null then
587 -- This violates the No_Entry_Queue restriction, send
588 -- Program_Error to the caller.
590 Send_Program_Error
(Self_Id
, Entry_Call
);
591 Unlock_Entry
(Object
);
595 Object
.Call_In_Progress
:= Entry_Call
;
596 Object
.Entry_Body
.Action
597 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
598 Object
.Call_In_Progress
:= null;
599 Caller
:= Entry_Call
.Self
;
600 Unlock_Entry
(Object
);
606 STPO
.Write_Lock
(Caller
);
607 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
608 STPO
.Unlock
(Caller
);
618 Send_Program_Error
(Self_Id
, Entry_Call
);
619 Unlock_Entry
(Object
);
622 ---------------------------------------
623 -- Timed_Protected_Single_Entry_Call --
624 ---------------------------------------
626 -- Compiler interface only. Do not call from within the RTS.
628 procedure Timed_Protected_Single_Entry_Call
629 (Object
: Protection_Entry_Access
;
630 Uninterpreted_Data
: System
.Address
;
633 Entry_Call_Successful
: out Boolean)
635 Self_Id
: constant Task_Id
:= STPO
.Self
;
636 Entry_Call
: Entry_Call_Record
renames Self_Id
.Entry_Calls
(1);
637 Ceiling_Violation
: Boolean;
640 -- If pragma Detect_Blocking is active then Program_Error must be
641 -- raised if this potentially blocking operation is called from a
645 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
647 Ada
.Exceptions
.Raise_Exception
648 (Program_Error
'Identity, "potentially blocking operation");
651 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
653 if Ceiling_Violation
then
657 Entry_Call
.Mode
:= Timed_Call
;
658 Entry_Call
.State
:= Now_Abortable
;
659 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
660 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
662 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
'Access);
663 Unlock_Entry
(Object
);
665 -- Try to avoid waiting for completed calls.
666 -- The call is either `Done' or not. It cannot be cancelled since there
667 -- is no ATC construct and the timed wait has not started yet.
669 pragma Assert
(Entry_Call
.State
/= Cancelled
);
671 if Entry_Call
.State
= Done
then
672 Check_Exception
(Self_Id
, Entry_Call
'Access);
673 Entry_Call_Successful
:= True;
680 STPO
.Write_Lock
(Self_Id
);
683 Wait_For_Completion_With_Timeout
(Entry_Call
'Access, Timeout
, Mode
);
688 STPO
.Unlock
(Self_Id
);
691 pragma Assert
(Entry_Call
.State
>= Done
);
693 Check_Exception
(Self_Id
, Entry_Call
'Access);
694 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
695 end Timed_Protected_Single_Entry_Call
;
701 procedure Unlock_Entry
(Object
: Protection_Entry_Access
) is
703 -- We are exiting from a protected action, so that we decrease the
704 -- protected object nesting level (if pragma Detect_Blocking is active).
706 if Detect_Blocking
then
708 Self_Id
: constant Task_Id
:= Self
;
711 -- Cannot call Unlock_Entry without being within protected action
713 pragma Assert
(Self_Id
.Common
.Protected_Action_Nesting
> 0);
715 Self_Id
.Common
.Protected_Action_Nesting
:=
716 Self_Id
.Common
.Protected_Action_Nesting
- 1;
720 STPO
.Unlock
(Object
.L
'Access);
723 end System
.Tasking
.Protected_Objects
.Single_Entry
;