1 ------------------------------------------------------------------------------
3 -- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
10 -- Copyright (C) 1998-2002, 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, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, 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. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
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 have 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;
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;
352 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
354 if Ceiling_Violation
then
359 --------------------------
360 -- Lock_Read_Only_Entry --
361 --------------------------
363 -- Compiler interface only.
364 -- Do not call this procedure from within the runtime system.
366 procedure Lock_Read_Only_Entry
(Object
: Protection_Entry_Access
) is
367 Ceiling_Violation
: Boolean;
369 STPO
.Read_Lock
(Object
.L
'Access, Ceiling_Violation
);
371 if Ceiling_Violation
then
374 end Lock_Read_Only_Entry
;
380 procedure PO_Do_Or_Queue
382 Object
: Protection_Entry_Access
;
383 Entry_Call
: Entry_Call_Link
)
385 Barrier_Value
: Boolean;
387 -- When the Action procedure for an entry body returns, it must be
388 -- completed (having called [Exceptional_]Complete_Entry_Body).
390 Barrier_Value
:= Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1);
392 if Barrier_Value
then
393 if Object
.Call_In_Progress
/= null then
394 -- This violates the No_Entry_Queue restriction, send
395 -- Program_Error to the caller.
397 Send_Program_Error
(Self_Id
, Entry_Call
);
401 Object
.Call_In_Progress
:= Entry_Call
;
402 Object
.Entry_Body
.Action
403 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
404 Object
.Call_In_Progress
:= null;
410 STPO
.Write_Lock
(Entry_Call
.Self
);
411 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
412 STPO
.Unlock
(Entry_Call
.Self
);
418 elsif Entry_Call
.Mode
/= Conditional_Call
then
419 Object
.Entry_Queue
:= Entry_Call
;
427 STPO
.Write_Lock
(Entry_Call
.Self
);
428 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Cancelled
);
429 STPO
.Unlock
(Entry_Call
.Self
);
439 (Self_Id
, Entry_Call
);
442 ----------------------------
443 -- Protected_Single_Count --
444 ----------------------------
446 function Protected_Count_Entry
(Object
: Protection_Entry
) return Natural is
448 if Object
.Call_In_Progress
/= null then
453 end Protected_Count_Entry
;
455 ---------------------------------
456 -- Protected_Single_Entry_Call --
457 ---------------------------------
459 procedure Protected_Single_Entry_Call
460 (Object
: Protection_Entry_Access
;
461 Uninterpreted_Data
: System
.Address
;
464 Self_Id
: constant Task_ID
:= STPO
.Self
;
465 Entry_Call
: Entry_Call_Record
renames Self_Id
.Entry_Calls
(1);
466 Ceiling_Violation
: Boolean;
469 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
471 if Ceiling_Violation
then
475 Entry_Call
.Mode
:= Mode
;
476 Entry_Call
.State
:= Now_Abortable
;
477 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
478 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
480 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
'Access);
481 Unlock_Entry
(Object
);
483 -- The call is either `Done' or not. It cannot be cancelled since there
484 -- is no ATC construct.
486 pragma Assert
(Entry_Call
.State
/= Cancelled
);
488 if Entry_Call
.State
/= Done
then
493 STPO
.Write_Lock
(Self_Id
);
494 Wait_For_Completion
(Entry_Call
'Access);
495 STPO
.Unlock
(Self_Id
);
502 Check_Exception
(Self_Id
, Entry_Call
'Access);
503 end Protected_Single_Entry_Call
;
505 -----------------------------------
506 -- Protected_Single_Entry_Caller --
507 -----------------------------------
509 function Protected_Single_Entry_Caller
510 (Object
: Protection_Entry
) return Task_ID
is
512 return Object
.Call_In_Progress
.Self
;
513 end Protected_Single_Entry_Caller
;
519 procedure Service_Entry
(Object
: Protection_Entry_Access
) is
520 Self_Id
: constant Task_ID
:= STPO
.Self
;
521 Entry_Call
: constant Entry_Call_Link
:= Object
.Entry_Queue
;
523 Barrier_Value
: Boolean;
526 if Entry_Call
/= null then
527 Barrier_Value
:= Object
.Entry_Body
.Barrier
(Object
.Compiler_Info
, 1);
529 if Barrier_Value
then
530 if Object
.Call_In_Progress
/= null then
531 -- This violates the No_Entry_Queue restriction, send
532 -- Program_Error to the caller.
534 Send_Program_Error
(Self_Id
, Entry_Call
);
538 Object
.Call_In_Progress
:= Entry_Call
;
539 Object
.Entry_Body
.Action
540 (Object
.Compiler_Info
, Entry_Call
.Uninterpreted_Data
, 1);
541 Object
.Call_In_Progress
:= null;
542 Caller
:= Entry_Call
.Self
;
548 STPO
.Write_Lock
(Caller
);
549 Wakeup_Entry_Caller
(Self_Id
, Entry_Call
, Done
);
550 STPO
.Unlock
(Caller
);
560 Send_Program_Error
(Self_Id
, Entry_Call
);
563 ---------------------------------------
564 -- Timed_Protected_Single_Entry_Call --
565 ---------------------------------------
567 -- Compiler interface only. Do not call from within the RTS.
569 procedure Timed_Protected_Single_Entry_Call
570 (Object
: Protection_Entry_Access
;
571 Uninterpreted_Data
: System
.Address
;
574 Entry_Call_Successful
: out Boolean)
576 Self_Id
: constant Task_ID
:= STPO
.Self
;
577 Entry_Call
: Entry_Call_Record
renames Self_Id
.Entry_Calls
(1);
578 Ceiling_Violation
: Boolean;
581 STPO
.Write_Lock
(Object
.L
'Access, Ceiling_Violation
);
583 if Ceiling_Violation
then
587 Entry_Call
.Mode
:= Timed_Call
;
588 Entry_Call
.State
:= Now_Abortable
;
589 Entry_Call
.Uninterpreted_Data
:= Uninterpreted_Data
;
590 Entry_Call
.Exception_To_Raise
:= Ada
.Exceptions
.Null_Id
;
592 PO_Do_Or_Queue
(Self_Id
, Object
, Entry_Call
'Access);
593 Unlock_Entry
(Object
);
595 -- Try to avoid waiting for completed calls.
596 -- The call is either `Done' or not. It cannot be cancelled since there
597 -- is no ATC construct and the timed wait has not started yet.
599 pragma Assert
(Entry_Call
.State
/= Cancelled
);
601 if Entry_Call
.State
= Done
then
602 Check_Exception
(Self_Id
, Entry_Call
'Access);
603 Entry_Call_Successful
:= True;
610 STPO
.Write_Lock
(Self_Id
);
613 Wait_For_Completion_With_Timeout
(Entry_Call
'Access, Timeout
, Mode
);
618 STPO
.Unlock
(Self_Id
);
621 pragma Assert
(Entry_Call
.State
>= Done
);
623 Check_Exception
(Self_Id
, Entry_Call
'Access);
624 Entry_Call_Successful
:= Entry_Call
.State
= Done
;
625 end Timed_Protected_Single_Entry_Call
;
631 procedure Unlock_Entry
(Object
: Protection_Entry_Access
) is
633 STPO
.Unlock
(Object
.L
'Access);
636 end System
.Tasking
.Protected_Objects
.Single_Entry
;