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-2005, 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 use type Ada.Exceptions.Exception_Id;
219 -- This procedure waits for the entry call to be served, with a timeout.
220 -- It tries to cancel the call if the timeout expires before the call is
223 -- If we wake up from the timed sleep operation here, it may be for the
224 -- following possible reasons:
226 -- 1) The entry call is done being served.
227 -- 2) The timeout has expired (Timedout = True)
229 -- Once the timeout has expired we may need to continue to wait if the
230 -- call is already being serviced. In that case, we want to go back to
231 -- sleep, but without any timeout. The variable Timedout is used to
232 -- control this. If the Timedout flag is set, we do not need to Sleep
233 -- with a timeout. We just sleep until we get a wakeup for some status
236 pragma Assert (Entry_Call.Mode = Timed_Call);
237 Self_Id.Common.State := Entry_Caller_Sleep;
240 (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded);
243 Entry_Call.State := Cancelled;
245 Entry_Call.State := Done;
248 Self_Id.Common.State := Runnable;
249 end Wait_For_Completion_With_Timeout;
251 -------------------------
252 -- Wakeup_Entry_Caller --
253 -------------------------
255 -- This is called at the end of service of an entry call, to abort the
256 -- caller if he is in an abortable part, and to wake up the caller if it
257 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
259 -- (This enforces the rule that a task must be off-queue if its state is
260 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
262 -- Timed_Call or Simple_Call:
263 -- The caller is waiting on Entry_Caller_Sleep, in
264 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
267 -- The caller might be in Wait_For_Completion,
268 -- waiting for a rendezvous (possibly requeued without abort)
271 procedure Wakeup_Entry_Caller
273 Entry_Call : Entry_Call_Link;
274 New_State : Entry_Call_State)
276 pragma Warnings (Off, Self_ID);
278 Caller : constant Task_Id := Entry_Call.Self;
281 pragma Assert (New_State = Done or else New_State = Cancelled);
283 (Caller.Common.State /= Terminated and then
284 Caller.Common.State /= Unactivated);
286 Entry_Call.State := New_State;
287 STPO.Wakeup (Caller, Entry_Caller_Sleep);
288 end Wakeup_Entry_Caller;
290 -----------------------
291 -- Restricted GNARLI --
292 -----------------------
294 --------------------------------
295 -- Complete_Single_Entry_Body --
296 --------------------------------
298 procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is
299 pragma Warnings (Off, Object);
302 -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise
303 -- has already been set to Null_Id).
306 end Complete_Single_Entry_Body;
308 --------------------------------------------
309 -- Exceptional_Complete_Single_Entry_Body --
310 --------------------------------------------
312 procedure Exceptional_Complete_Single_Entry_Body
313 (Object : Protection_Entry_Access;
314 Ex : Ada.Exceptions.Exception_Id) is
316 Object.Call_In_Progress.Exception_To_Raise := Ex;
317 end Exceptional_Complete_Single_Entry_Body;
319 ---------------------------------
320 -- Initialize_Protection_Entry --
321 ---------------------------------
323 procedure Initialize_Protection_Entry
324 (Object : Protection_Entry_Access;
325 Ceiling_Priority : Integer;
326 Compiler_Info : System.Address;
327 Entry_Body : Entry_Body_Access)
329 Init_Priority : Integer := Ceiling_Priority;
331 if Init_Priority = Unspecified_Priority then
332 Init_Priority := System.Priority'Last;
335 STPO.Initialize_Lock (Init_Priority, Object.L'Access);
336 Object.Ceiling := System.Any_Priority (Init_Priority);
337 Object.Owner := Null_Task;
338 Object.Compiler_Info := Compiler_Info;
339 Object.Call_In_Progress := null;
340 Object.Entry_Body := Entry_Body;
341 Object.Entry_Queue := null;
342 end Initialize_Protection_Entry;
348 -- Compiler interface only.
349 -- Do not call this procedure from within the run-time system.
351 procedure Lock_Entry (Object : Protection_Entry_Access) is
352 Ceiling_Violation : Boolean;
355 -- If pragma Detect_Blocking is active then, as described in the ARM
356 -- 9.5.1, par. 15, we must check whether this is an external call on a
357 -- protected subprogram with the same target object as that of the
358 -- protected action that is currently in progress (i.e., if the caller
359 -- is already the protected object's owner). If this is the case hence
360 -- Program_Error must be raised.
362 if Detect_Blocking and then Object.Owner = Self then
366 STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
368 if Ceiling_Violation then
372 -- We are entering in a protected action, so that we increase the
373 -- protected object nesting level (if pragma Detect_Blocking is
374 -- active), and update the protected object's owner.
376 if Detect_Blocking then
378 Self_Id : constant Task_Id := Self;
381 -- Update the protected object's owner
383 Object.Owner := Self_Id;
385 -- Increase protected object nesting level
387 Self_Id.Common.Protected_Action_Nesting :=
388 Self_Id.Common.Protected_Action_Nesting + 1;
393 --------------------------
394 -- Lock_Read_Only_Entry --
395 --------------------------
397 -- Compiler interface only
399 -- Do not call this procedure from within the runtime system
401 procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
402 Ceiling_Violation : Boolean;
405 -- If pragma Detect_Blocking is active then, as described in the ARM
406 -- 9.5.1, par. 15, we must check whether this is an external call on a
407 -- protected subprogram with the same target object as that of the
408 -- protected action that is currently in progress (i.e., if the caller
409 -- is already the protected object's owner). If this is the case hence
410 -- Program_Error must be raised.
412 -- Note that in this case (getting read access), several tasks may
413 -- have read ownership of the protected object, so that this method of
414 -- storing the (single) protected object's owner does not work
415 -- reliably for read locks. However, this is the approach taken for two
416 -- major reasosn: first, this function is not currently being used (it
417 -- is provided for possible future use), and second, it largely
418 -- simplifies the implementation.
420 if Detect_Blocking and then Object.Owner = Self then
424 STPO.Read_Lock (Object.L'Access, Ceiling_Violation);
426 if Ceiling_Violation then
430 -- We are entering in a protected action, so that we increase the
431 -- protected object nesting level (if pragma Detect_Blocking is
432 -- active), and update the protected object's owner.
434 if Detect_Blocking then
436 Self_Id : constant Task_Id := Self;
439 -- Update the protected object's owner
441 Object.Owner := Self_Id;
443 -- Increase protected object nesting level
445 Self_Id.Common.Protected_Action_Nesting :=
446 Self_Id.Common.Protected_Action_Nesting + 1;
449 end Lock_Read_Only_Entry;
455 procedure PO_Do_Or_Queue
457 Object : Protection_Entry_Access;
458 Entry_Call : Entry_Call_Link)
460 Barrier_Value : Boolean;
463 -- When the Action procedure for an entry body returns, it must be
464 -- completed (having called [Exceptional_]Complete_Entry_Body).
466 Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
468 if Barrier_Value then
469 if Object.Call_In_Progress /= null then
471 -- This violates the No_Entry_Queue restriction, send
472 -- Program_Error to the caller.
474 Send_Program_Error (Self_Id, Entry_Call);
478 Object.Call_In_Progress := Entry_Call;
479 Object.Entry_Body.Action
480 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
481 Object.Call_In_Progress := null;
487 STPO.Write_Lock (Entry_Call.Self);
488 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
489 STPO.Unlock (Entry_Call.Self);
495 elsif Entry_Call.Mode /= Conditional_Call then
496 if Object.Entry_Queue /= null then
498 -- This violates the No_Entry_Queue restriction, send
499 -- Program_Error to the caller.
501 Send_Program_Error (Self_Id, Entry_Call);
504 Object.Entry_Queue := Entry_Call;
514 STPO.Write_Lock (Entry_Call.Self);
515 Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled);
516 STPO.Unlock (Entry_Call.Self);
526 (Self_Id, Entry_Call);
529 ----------------------------
530 -- Protected_Single_Count --
531 ----------------------------
533 function Protected_Count_Entry (Object : Protection_Entry) return Natural is
535 if Object.Entry_Queue /= null then
540 end Protected_Count_Entry;
542 ---------------------------------
543 -- Protected_Single_Entry_Call --
544 ---------------------------------
546 procedure Protected_Single_Entry_Call
547 (Object : Protection_Entry_Access;
548 Uninterpreted_Data : System.Address;
551 Self_Id : constant Task_Id := STPO.Self;
552 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
553 Ceiling_Violation : Boolean;
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");
567 STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
569 if Ceiling_Violation then
573 Entry_Call.Mode := Mode;
574 Entry_Call.State := Now_Abortable;
575 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
576 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
578 PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
579 Unlock_Entry (Object);
581 -- The call is either `Done' or not. It cannot be cancelled since there
582 -- is no ATC construct.
584 pragma Assert (Entry_Call.State /= Cancelled);
586 if Entry_Call.State /= Done then
591 STPO.Write_Lock (Self_Id);
592 Wait_For_Completion (Entry_Call'Access);
593 STPO.Unlock (Self_Id);
600 Check_Exception (Self_Id, Entry_Call'Access);
601 end Protected_Single_Entry_Call;
603 -----------------------------------
604 -- Protected_Single_Entry_Caller --
605 -----------------------------------
607 function Protected_Single_Entry_Caller
608 (Object : Protection_Entry) return Task_Id is
610 return Object.Call_In_Progress.Self;
611 end Protected_Single_Entry_Caller;
617 procedure Service_Entry (Object : Protection_Entry_Access) is
618 Self_Id : constant Task_Id := STPO.Self;
619 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
623 if Entry_Call /= null
624 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
626 Object.Entry_Queue := null;
628 if Object.Call_In_Progress /= null then
630 -- Violation of No_Entry_Queue restriction, raise exception
632 Send_Program_Error (Self_Id, Entry_Call);
633 Unlock_Entry (Object);
637 Object.Call_In_Progress := Entry_Call;
638 Object.Entry_Body.Action
639 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
640 Object.Call_In_Progress := null;
641 Caller := Entry_Call.Self;
642 Unlock_Entry (Object);
648 STPO.Write_Lock (Caller);
649 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
650 STPO.Unlock (Caller);
657 -- Just unlock the entry
659 Unlock_Entry (Object);
664 Send_Program_Error (Self_Id, Entry_Call);
665 Unlock_Entry (Object);
668 ---------------------------------------
669 -- Timed_Protected_Single_Entry_Call --
670 ---------------------------------------
672 -- Compiler interface only. Do not call from within the RTS.
674 procedure Timed_Protected_Single_Entry_Call
675 (Object : Protection_Entry_Access;
676 Uninterpreted_Data : System.Address;
679 Entry_Call_Successful : out Boolean)
681 Self_Id : constant Task_Id := STPO.Self;
682 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
683 Ceiling_Violation : Boolean;
686 -- If pragma Detect_Blocking is active then Program_Error must be
687 -- raised if this potentially blocking operation is called from a
691 and then Self_Id.Common.Protected_Action_Nesting > 0
693 Ada.Exceptions.Raise_Exception
694 (Program_Error'Identity, "potentially blocking operation");
697 STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
699 if Ceiling_Violation then
703 Entry_Call.Mode := Timed_Call;
704 Entry_Call.State := Now_Abortable;
705 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
706 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
708 PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
709 Unlock_Entry (Object);
711 -- Try to avoid waiting for completed calls.
712 -- The call is either `Done' or not. It cannot be cancelled since there
713 -- is no ATC construct and the timed wait has not started yet.
715 pragma Assert (Entry_Call.State /= Cancelled);
717 if Entry_Call.State = Done then
718 Check_Exception (Self_Id, Entry_Call'Access);
719 Entry_Call_Successful := True;
726 STPO.Write_Lock (Self_Id);
729 Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode);
734 STPO.Unlock (Self_Id);
737 pragma Assert (Entry_Call.State >= Done);
739 Check_Exception (Self_Id, Entry_Call'Access);
740 Entry_Call_Successful := Entry_Call.State = Done;
741 end Timed_Protected_Single_Entry_Call;
747 procedure Unlock_Entry (Object : Protection_Entry_Access) is
749 -- We are exiting from a protected action, so that we decrease the
750 -- protected object nesting level (if pragma Detect_Blocking is
751 -- active), and remove ownership of the protected object.
753 if Detect_Blocking then
755 Self_Id : constant Task_Id := Self;
758 -- Calls to this procedure can only take place when being within
759 -- a protected action and when the caller is the protected
762 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
763 and then Object.Owner = Self_Id);
765 -- Remove ownership of the protected object
767 Object.Owner := Null_Task;
769 Self_Id.Common.Protected_Action_Nesting :=
770 Self_Id.Common.Protected_Action_Nesting - 1;
774 STPO.Unlock (Object.L'Access);
777 end System.Tasking.Protected_Objects.Single_Entry;