1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
9 -- Copyright (C) 1998-2008, 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 subprograms are
36 -- 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 has 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);
62 -- Why is this required ???
66 with System.Task_Primitives.Operations;
67 with System.Parameters;
69 package body System.Tasking.Protected_Objects.Single_Entry is
71 package STPO renames System.Task_Primitives.Operations;
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 procedure Send_Program_Error
81 Entry_Call : Entry_Call_Link);
82 pragma Inline (Send_Program_Error);
83 -- Raise Program_Error in the caller of the specified entry call
85 --------------------------
86 -- Entry Calls Handling --
87 --------------------------
89 procedure Wakeup_Entry_Caller
91 Entry_Call : Entry_Call_Link;
92 New_State : Entry_Call_State);
93 pragma Inline (Wakeup_Entry_Caller);
94 -- This is called at the end of service of an entry call,
95 -- to abort the caller if he is in an abortable part, and
96 -- to wake up the caller if he is on Entry_Caller_Sleep.
97 -- Call it holding the lock of Entry_Call.Self.
99 -- Timed_Call or Simple_Call:
100 -- The caller is waiting on Entry_Caller_Sleep, in
101 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
103 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
104 pragma Inline (Wait_For_Completion);
105 -- This procedure suspends the calling task until the specified entry call
106 -- has either been completed or cancelled. On exit, the call will not be
107 -- queued. This waits for calls on protected entries.
108 -- Call this only when holding Self_ID locked.
110 procedure Wait_For_Completion_With_Timeout
111 (Entry_Call : Entry_Call_Link;
112 Wakeup_Time : Duration;
114 -- Same as Wait_For_Completion but it waits for a timeout with the value
115 -- specified in Wakeup_Time as well.
117 procedure Check_Exception
119 Entry_Call : Entry_Call_Link);
120 pragma Inline (Check_Exception);
121 -- Raise any pending exception from the Entry_Call.
122 -- This should be called at the end of every compiler interface procedure
123 -- that implements an entry call.
124 -- The caller should not be holding any locks, or there will be deadlock.
126 procedure PO_Do_Or_Queue
128 Object : Protection_Entry_Access;
129 Entry_Call : Entry_Call_Link);
130 -- This procedure executes or queues an entry call, depending
131 -- on the status of the corresponding barrier. It assumes that the
132 -- specified object is locked.
134 ---------------------
135 -- Check_Exception --
136 ---------------------
138 procedure Check_Exception
140 Entry_Call : Entry_Call_Link)
142 pragma Warnings (Off, Self_ID);
144 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
145 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
147 use type Ada.Exceptions.Exception_Id;
149 E : constant Ada.Exceptions.Exception_Id :=
150 Entry_Call.Exception_To_Raise;
153 if E /= Ada.Exceptions.Null_Id then
158 ------------------------
159 -- Send_Program_Error --
160 ------------------------
162 procedure Send_Program_Error
164 Entry_Call : Entry_Call_Link)
166 Caller : constant Task_Id := Entry_Call.Self;
168 Entry_Call.Exception_To_Raise := Program_Error'Identity;
174 STPO.Write_Lock (Caller);
175 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
176 STPO.Unlock (Caller);
181 end Send_Program_Error;
183 -------------------------
184 -- Wait_For_Completion --
185 -------------------------
187 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
188 Self_Id : constant Task_Id := Entry_Call.Self;
190 Self_Id.Common.State := Entry_Caller_Sleep;
191 STPO.Sleep (Self_Id, Entry_Caller_Sleep);
192 Self_Id.Common.State := Runnable;
193 end Wait_For_Completion;
195 --------------------------------------
196 -- Wait_For_Completion_With_Timeout --
197 --------------------------------------
199 procedure Wait_For_Completion_With_Timeout
200 (Entry_Call : Entry_Call_Link;
201 Wakeup_Time : Duration;
204 Self_Id : constant Task_Id := Entry_Call.Self;
208 pragma Unreferenced (Yielded);
210 use type Ada.Exceptions.Exception_Id;
213 -- This procedure waits for the entry call to be served, with a timeout.
214 -- It tries to cancel the call if the timeout expires before the call is
217 -- If we wake up from the timed sleep operation here, it may be for the
218 -- following possible reasons:
220 -- 1) The entry call is done being served.
221 -- 2) The timeout has expired (Timedout = True)
223 -- Once the timeout has expired we may need to continue to wait if the
224 -- call is already being serviced. In that case, we want to go back to
225 -- sleep, but without any timeout. The variable Timedout is used to
226 -- control this. If the Timedout flag is set, we do not need to Sleep
227 -- with a timeout. We just sleep until we get a wakeup for some status
230 pragma Assert (Entry_Call.Mode = Timed_Call);
231 Self_Id.Common.State := Entry_Caller_Sleep;
234 (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded);
237 Entry_Call.State := Cancelled;
239 Entry_Call.State := Done;
242 Self_Id.Common.State := Runnable;
243 end Wait_For_Completion_With_Timeout;
245 -------------------------
246 -- Wakeup_Entry_Caller --
247 -------------------------
249 -- This is called at the end of service of an entry call, to abort the
250 -- caller if he is in an abortable part, and to wake up the caller if it
251 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
253 -- (This enforces the rule that a task must be off-queue if its state is
254 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
256 -- Timed_Call or Simple_Call:
257 -- The caller is waiting on Entry_Caller_Sleep, in
258 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
261 -- The caller might be in Wait_For_Completion,
262 -- waiting for a rendezvous (possibly requeued without abort)
265 procedure Wakeup_Entry_Caller
267 Entry_Call : Entry_Call_Link;
268 New_State : Entry_Call_State)
270 pragma Warnings (Off, Self_ID);
272 Caller : constant Task_Id := Entry_Call.Self;
275 pragma Assert (New_State = Done or else New_State = Cancelled);
277 (Caller.Common.State /= Terminated and then
278 Caller.Common.State /= Unactivated);
280 Entry_Call.State := New_State;
281 STPO.Wakeup (Caller, Entry_Caller_Sleep);
282 end Wakeup_Entry_Caller;
284 -----------------------
285 -- Restricted GNARLI --
286 -----------------------
288 --------------------------------
289 -- Complete_Single_Entry_Body --
290 --------------------------------
292 procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is
293 pragma Warnings (Off, Object);
296 -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise
297 -- has already been set to Null_Id).
300 end Complete_Single_Entry_Body;
302 --------------------------------------------
303 -- Exceptional_Complete_Single_Entry_Body --
304 --------------------------------------------
306 procedure Exceptional_Complete_Single_Entry_Body
307 (Object : Protection_Entry_Access;
308 Ex : Ada.Exceptions.Exception_Id) is
310 Object.Call_In_Progress.Exception_To_Raise := Ex;
311 end Exceptional_Complete_Single_Entry_Body;
313 ---------------------------------
314 -- Initialize_Protection_Entry --
315 ---------------------------------
317 procedure Initialize_Protection_Entry
318 (Object : Protection_Entry_Access;
319 Ceiling_Priority : Integer;
320 Compiler_Info : System.Address;
321 Entry_Body : Entry_Body_Access)
323 Init_Priority : Integer := Ceiling_Priority;
325 if Init_Priority = Unspecified_Priority then
326 Init_Priority := System.Priority'Last;
329 STPO.Initialize_Lock (Init_Priority, Object.L'Access);
330 Object.Ceiling := System.Any_Priority (Init_Priority);
331 Object.Owner := Null_Task;
332 Object.Compiler_Info := Compiler_Info;
333 Object.Call_In_Progress := null;
334 Object.Entry_Body := Entry_Body;
335 Object.Entry_Queue := null;
336 end Initialize_Protection_Entry;
342 -- Compiler interface only.
343 -- Do not call this procedure from within the run-time system.
345 procedure Lock_Entry (Object : Protection_Entry_Access) is
346 Ceiling_Violation : Boolean;
349 -- If pragma Detect_Blocking is active then, as described in the ARM
350 -- 9.5.1, par. 15, we must check whether this is an external call on a
351 -- protected subprogram with the same target object as that of the
352 -- protected action that is currently in progress (i.e., if the caller
353 -- is already the protected object's owner). If this is the case hence
354 -- Program_Error must be raised.
356 if Detect_Blocking and then Object.Owner = Self then
360 STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
362 if Ceiling_Violation then
366 -- We are entering in a protected action, so that we increase the
367 -- protected object nesting level (if pragma Detect_Blocking is
368 -- active), and update the protected object's owner.
370 if Detect_Blocking then
372 Self_Id : constant Task_Id := Self;
375 -- Update the protected object's owner
377 Object.Owner := Self_Id;
379 -- Increase protected object nesting level
381 Self_Id.Common.Protected_Action_Nesting :=
382 Self_Id.Common.Protected_Action_Nesting + 1;
387 --------------------------
388 -- Lock_Read_Only_Entry --
389 --------------------------
391 -- Compiler interface only
393 -- Do not call this procedure from within the runtime system
395 procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
396 Ceiling_Violation : Boolean;
399 -- If pragma Detect_Blocking is active then, as described in the ARM
400 -- 9.5.1, par. 15, we must check whether this is an external call on a
401 -- protected subprogram with the same target object as that of the
402 -- protected action that is currently in progress (i.e., if the caller
403 -- is already the protected object's owner). If this is the case hence
404 -- Program_Error must be raised.
406 -- Note that in this case (getting read access), several tasks may
407 -- have read ownership of the protected object, so that this method of
408 -- storing the (single) protected object's owner does not work
409 -- reliably for read locks. However, this is the approach taken for two
410 -- major reasosn: first, this function is not currently being used (it
411 -- is provided for possible future use), and second, it largely
412 -- simplifies the implementation.
414 if Detect_Blocking and then Object.Owner = Self then
418 STPO.Read_Lock (Object.L'Access, Ceiling_Violation);
420 if Ceiling_Violation then
424 -- We are entering in a protected action, so that we increase the
425 -- protected object nesting level (if pragma Detect_Blocking is
426 -- active), and update the protected object's owner.
428 if Detect_Blocking then
430 Self_Id : constant Task_Id := Self;
433 -- Update the protected object's owner
435 Object.Owner := Self_Id;
437 -- Increase protected object nesting level
439 Self_Id.Common.Protected_Action_Nesting :=
440 Self_Id.Common.Protected_Action_Nesting + 1;
443 end Lock_Read_Only_Entry;
449 procedure PO_Do_Or_Queue
451 Object : Protection_Entry_Access;
452 Entry_Call : Entry_Call_Link)
454 Barrier_Value : Boolean;
457 -- When the Action procedure for an entry body returns, it must be
458 -- completed (having called [Exceptional_]Complete_Entry_Body).
460 Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
462 if Barrier_Value then
463 if Object.Call_In_Progress /= null then
465 -- This violates the No_Entry_Queue restriction, send
466 -- Program_Error to the caller.
468 Send_Program_Error (Self_Id, Entry_Call);
472 Object.Call_In_Progress := Entry_Call;
473 Object.Entry_Body.Action
474 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
475 Object.Call_In_Progress := null;
481 STPO.Write_Lock (Entry_Call.Self);
482 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
483 STPO.Unlock (Entry_Call.Self);
489 elsif Entry_Call.Mode /= Conditional_Call then
490 if Object.Entry_Queue /= null then
492 -- This violates the No_Entry_Queue restriction, send
493 -- Program_Error to the caller.
495 Send_Program_Error (Self_Id, Entry_Call);
498 Object.Entry_Queue := Entry_Call;
508 STPO.Write_Lock (Entry_Call.Self);
509 Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled);
510 STPO.Unlock (Entry_Call.Self);
520 (Self_Id, Entry_Call);
523 ----------------------------
524 -- Protected_Single_Count --
525 ----------------------------
527 function Protected_Count_Entry (Object : Protection_Entry) return Natural is
529 if Object.Entry_Queue /= null then
534 end Protected_Count_Entry;
536 ---------------------------------
537 -- Protected_Single_Entry_Call --
538 ---------------------------------
540 procedure Protected_Single_Entry_Call
541 (Object : Protection_Entry_Access;
542 Uninterpreted_Data : System.Address;
545 Self_Id : constant Task_Id := STPO.Self;
546 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
548 -- If pragma Detect_Blocking is active then Program_Error must be
549 -- raised if this potentially blocking operation is called from a
553 and then Self_Id.Common.Protected_Action_Nesting > 0
555 raise Program_Error with "potentially blocking operation";
560 Entry_Call.Mode := Mode;
561 Entry_Call.State := Now_Abortable;
562 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
563 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
565 PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
566 Unlock_Entry (Object);
568 -- The call is either `Done' or not. It cannot be cancelled since there
569 -- is no ATC construct.
571 pragma Assert (Entry_Call.State /= Cancelled);
573 if Entry_Call.State /= Done then
578 STPO.Write_Lock (Self_Id);
579 Wait_For_Completion (Entry_Call'Access);
580 STPO.Unlock (Self_Id);
587 Check_Exception (Self_Id, Entry_Call'Access);
588 end Protected_Single_Entry_Call;
590 -----------------------------------
591 -- Protected_Single_Entry_Caller --
592 -----------------------------------
594 function Protected_Single_Entry_Caller
595 (Object : Protection_Entry) return Task_Id is
597 return Object.Call_In_Progress.Self;
598 end Protected_Single_Entry_Caller;
604 procedure Service_Entry (Object : Protection_Entry_Access) is
605 Self_Id : constant Task_Id := STPO.Self;
606 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
610 if Entry_Call /= null
611 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
613 Object.Entry_Queue := null;
615 if Object.Call_In_Progress /= null then
617 -- Violation of No_Entry_Queue restriction, raise exception
619 Send_Program_Error (Self_Id, Entry_Call);
620 Unlock_Entry (Object);
624 Object.Call_In_Progress := Entry_Call;
625 Object.Entry_Body.Action
626 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
627 Object.Call_In_Progress := null;
628 Caller := Entry_Call.Self;
629 Unlock_Entry (Object);
635 STPO.Write_Lock (Caller);
636 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
637 STPO.Unlock (Caller);
644 -- Just unlock the entry
646 Unlock_Entry (Object);
651 Send_Program_Error (Self_Id, Entry_Call);
652 Unlock_Entry (Object);
655 ---------------------------------------
656 -- Timed_Protected_Single_Entry_Call --
657 ---------------------------------------
659 -- Compiler interface only (do not call from within the RTS)
661 procedure Timed_Protected_Single_Entry_Call
662 (Object : Protection_Entry_Access;
663 Uninterpreted_Data : System.Address;
666 Entry_Call_Successful : out Boolean)
668 Self_Id : constant Task_Id := STPO.Self;
669 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
670 Ceiling_Violation : Boolean;
673 -- If pragma Detect_Blocking is active then Program_Error must be
674 -- raised if this potentially blocking operation is called from a
678 and then Self_Id.Common.Protected_Action_Nesting > 0
680 raise Program_Error with "potentially blocking operation";
683 STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
685 if Ceiling_Violation then
689 Entry_Call.Mode := Timed_Call;
690 Entry_Call.State := Now_Abortable;
691 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
692 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
694 PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
695 Unlock_Entry (Object);
697 -- Try to avoid waiting for completed calls.
698 -- The call is either `Done' or not. It cannot be cancelled since there
699 -- is no ATC construct and the timed wait has not started yet.
701 pragma Assert (Entry_Call.State /= Cancelled);
703 if Entry_Call.State = Done then
704 Check_Exception (Self_Id, Entry_Call'Access);
705 Entry_Call_Successful := True;
712 STPO.Write_Lock (Self_Id);
715 Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode);
720 STPO.Unlock (Self_Id);
723 pragma Assert (Entry_Call.State >= Done);
725 Check_Exception (Self_Id, Entry_Call'Access);
726 Entry_Call_Successful := Entry_Call.State = Done;
727 end Timed_Protected_Single_Entry_Call;
733 procedure Unlock_Entry (Object : Protection_Entry_Access) is
735 -- We are exiting from a protected action, so that we decrease the
736 -- protected object nesting level (if pragma Detect_Blocking is
737 -- active), and remove ownership of the protected object.
739 if Detect_Blocking then
741 Self_Id : constant Task_Id := Self;
744 -- Calls to this procedure can only take place when being within
745 -- a protected action and when the caller is the protected
748 pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
749 and then Object.Owner = Self_Id);
751 -- Remove ownership of the protected object
753 Object.Owner := Null_Task;
755 Self_Id.Common.Protected_Action_Nesting :=
756 Self_Id.Common.Protected_Action_Nesting - 1;
760 STPO.Unlock (Object.L'Access);
763 end System.Tasking.Protected_Objects.Single_Entry;