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 the protected object
354 -- nesting level must be increased.
356 if Detect_Blocking
then
358 Self_Id
: constant Task_Id
:= STPO
.Self
;
360 -- We are entering in a protected action, so that we
361 -- increase the protected object nesting level.
363 Self_Id
.Common
.Protected_Action_Nesting
:=
364 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
368 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
370 if Ceiling_Violation
then
375 --------------------------
376 -- Lock_Read_Only_Entry --
377 --------------------------
379 -- Compiler interface only.
380 -- Do not call this procedure from within the runtime system.
382 procedure Lock_Read_Only_Entry
(Object
: Protection_Entry_Access
) is
383 Ceiling_Violation
: Boolean;
386 -- If pragma Detect_Blocking is active then the protected object
387 -- nesting level must be increased.
389 if Detect_Blocking
then
391 Self_Id
: constant Task_Id
:= STPO
.Self
;
393 -- We are entering in a protected action, so that we
394 -- increase the protected object nesting level.
396 Self_Id
.Common
.Protected_Action_Nesting
:=
397 Self_Id
.Common
.Protected_Action_Nesting
+ 1;
401 STPO
.Read_Lock
(Object
.L
'Access, Ceiling_Violation
);
403 if Ceiling_Violation
then
406 end Lock_Read_Only_Entry
;
412 procedure PO_Do_Or_Queue
414 Object
: Protection_Entry_Access
;
415 Entry_Call
: Entry_Call_Link
)
417 Barrier_Value
: Boolean;
419 -- When the Action procedure for an entry body returns, it must be
420 -- completed (having called [Exceptional_]Complete_Entry_Body).
422 Barrier_Value
:= Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1);
424 if Barrier_Value
then
425 if Object
.Call_In_Progress
/= null then
426 -- This violates the No_Entry_Queue restriction, send
427 -- Program_Error to the caller.
429 Send_Program_Error
(Self_Id
, Entry_Call
);
433 Object
.Call_In_Progress
:= Entry_Call
;
434 Object
.Entry_Body
.Action
435 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
436 Object
.Call_In_Progress
:= null;
442 STPO
.Write_Lock
(Entry_Call
.Self
);
443 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
444 STPO
.Unlock
(Entry_Call
.Self
);
450 elsif Entry_Call
.Mode
/= Conditional_Call
then
451 Object
.Entry_Queue
:= Entry_Call
;
459 STPO
.Write_Lock
(Entry_Call
.Self
);
460 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Cancelled
);
461 STPO
.Unlock
(Entry_Call
.Self
);
471 (Self_Id
, Entry_Call
);
474 ----------------------------
475 -- Protected_Single_Count --
476 ----------------------------
478 function Protected_Count_Entry
(Object
: Protection_Entry
) return Natural is
480 if Object
.Entry_Queue
/= null then
485 end Protected_Count_Entry
;
487 ---------------------------------
488 -- Protected_Single_Entry_Call --
489 ---------------------------------
491 procedure Protected_Single_Entry_Call
492 (Object
: Protection_Entry_Access
;
493 Uninterpreted_Data
: System
.Address
;
496 Self_Id
: constant Task_Id
:= STPO
.Self
;
497 Entry_Call
: Entry_Call_Record
renames Self_Id
.Entry_Calls
(1);
498 Ceiling_Violation
: Boolean;
501 -- If pragma Detect_Blocking is active then Program_Error must be
502 -- raised if this potentially blocking operation is called from a
506 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
508 Ada
.Exceptions
.Raise_Exception
509 (Program_Error
'Identity, "potentially blocking operation");
512 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
514 if Ceiling_Violation
then
518 Entry_Call
.Mode
:= Mode
;
519 Entry_Call
.State
:= Now_Abortable
;
520 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
521 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
523 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
'Access);
524 Unlock_Entry
(Object
);
526 -- The call is either `Done' or not. It cannot be cancelled since there
527 -- is no ATC construct.
529 pragma Assert
(Entry_Call
.State
/= Cancelled
);
531 if Entry_Call
.State
/= Done
then
536 STPO
.Write_Lock
(Self_Id
);
537 Wait_For_Completion
(Entry_Call
'Access);
538 STPO
.Unlock
(Self_Id
);
545 Check_Exception
(Self_Id
, Entry_Call
'Access);
546 end Protected_Single_Entry_Call
;
548 -----------------------------------
549 -- Protected_Single_Entry_Caller --
550 -----------------------------------
552 function Protected_Single_Entry_Caller
553 (Object
: Protection_Entry
) return Task_Id
is
555 return Object
.Call_In_Progress
.Self
;
556 end Protected_Single_Entry_Caller
;
562 procedure Service_Entry
(Object
: Protection_Entry_Access
) is
563 Self_Id
: constant Task_Id
:= STPO
.Self
;
564 Entry_Call
: constant Entry_Call_Link
:= Object
.Entry_Queue
;
568 if Entry_Call
/= null
569 and then Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1)
571 Object
.Entry_Queue
:= null;
573 if Object
.Call_In_Progress
/= null then
575 -- Violation of No_Entry_Queue restriction, raise exception
577 Send_Program_Error
(Self_Id
, Entry_Call
);
578 Unlock_Entry
(Object
);
582 Object
.Call_In_Progress
:= Entry_Call
;
583 Object
.Entry_Body
.Action
584 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
585 Object
.Call_In_Progress
:= null;
586 Caller
:= Entry_Call
.Self
;
587 Unlock_Entry
(Object
);
593 STPO
.Write_Lock
(Caller
);
594 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
595 STPO
.Unlock
(Caller
);
602 -- Just unlock the entry
604 Unlock_Entry
(Object
);
609 Send_Program_Error
(Self_Id
, Entry_Call
);
610 Unlock_Entry
(Object
);
613 ---------------------------------------
614 -- Timed_Protected_Single_Entry_Call --
615 ---------------------------------------
617 -- Compiler interface only. Do not call from within the RTS.
619 procedure Timed_Protected_Single_Entry_Call
620 (Object
: Protection_Entry_Access
;
621 Uninterpreted_Data
: System
.Address
;
624 Entry_Call_Successful
: out Boolean)
626 Self_Id
: constant Task_Id
:= STPO
.Self
;
627 Entry_Call
: Entry_Call_Record
renames Self_Id
.Entry_Calls
(1);
628 Ceiling_Violation
: Boolean;
631 -- If pragma Detect_Blocking is active then Program_Error must be
632 -- raised if this potentially blocking operation is called from a
636 and then Self_Id
.Common
.Protected_Action_Nesting
> 0
638 Ada
.Exceptions
.Raise_Exception
639 (Program_Error
'Identity, "potentially blocking operation");
642 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
644 if Ceiling_Violation
then
648 Entry_Call
.Mode
:= Timed_Call
;
649 Entry_Call
.State
:= Now_Abortable
;
650 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
651 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
653 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
'Access);
654 Unlock_Entry
(Object
);
656 -- Try to avoid waiting for completed calls.
657 -- The call is either `Done' or not. It cannot be cancelled since there
658 -- is no ATC construct and the timed wait has not started yet.
660 pragma Assert
(Entry_Call
.State
/= Cancelled
);
662 if Entry_Call
.State
= Done
then
663 Check_Exception
(Self_Id
, Entry_Call
'Access);
664 Entry_Call_Successful
:= True;
671 STPO
.Write_Lock
(Self_Id
);
674 Wait_For_Completion_With_Timeout
(Entry_Call
'Access, Timeout
, Mode
);
679 STPO
.Unlock
(Self_Id
);
682 pragma Assert
(Entry_Call
.State
>= Done
);
684 Check_Exception
(Self_Id
, Entry_Call
'Access);
685 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
686 end Timed_Protected_Single_Entry_Call
;
692 procedure Unlock_Entry
(Object
: Protection_Entry_Access
) is
694 -- We are exiting from a protected action, so that we decrease the
695 -- protected object nesting level (if pragma Detect_Blocking is active).
697 if Detect_Blocking
then
699 Self_Id
: constant Task_Id
:= Self
;
702 -- Cannot call Unlock_Entry without being within protected action
704 pragma Assert
(Self_Id
.Common
.Protected_Action_Nesting
> 0);
706 Self_Id
.Common
.Protected_Action_Nesting
:=
707 Self_Id
.Common
.Protected_Action_Nesting
- 1;
711 STPO
.Unlock
(Object
.L
'Access);
714 end System
.Tasking
.Protected_Objects
.Single_Entry
;