1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
9 -- Copyright (C) 1998-2013, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
32 pragma Style_Checks (All_Checks);
33 -- Turn off subprogram ordering check, since restricted GNARLI subprograms are
34 -- gathered together at end.
36 -- This package provides an optimized version of Protected_Objects.Operations
37 -- and Protected_Objects.Entries making the following assumptions:
39 -- PO has only one entry
40 -- There is only one caller at a time (No_Entry_Queue)
41 -- There is no dynamic priority support (No_Dynamic_Priorities)
42 -- No Abort Statements
43 -- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0)
44 -- PO are at library level
46 -- None of the tasks will terminate (no need for finalization)
48 -- This interface is intended to be used in the ravenscar and restricted
49 -- profiles, the compiler is responsible for ensuring that the conditions
50 -- mentioned above are respected, except for the No_Entry_Queue restriction
51 -- that is checked dynamically in this package, since the check cannot be
52 -- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue,
56 -- Turn off polling, we do not want polling to take place during tasking
57 -- operations. It can cause infinite loops and other problems.
59 pragma Suppress (All_Checks);
60 -- Why is this required ???
64 with System.Task_Primitives.Operations;
65 with System.Parameters;
67 package body System.Tasking.Protected_Objects.Single_Entry is
69 package STPO renames System.Task_Primitives.Operations;
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 procedure Send_Program_Error (Entry_Call : Entry_Call_Link);
78 pragma Inline (Send_Program_Error);
79 -- Raise Program_Error in the caller of the specified entry call
81 --------------------------
82 -- Entry Calls Handling --
83 --------------------------
85 procedure Wakeup_Entry_Caller (Entry_Call : Entry_Call_Link);
86 pragma Inline (Wakeup_Entry_Caller);
87 -- This is called at the end of service of an entry call,
88 -- to abort the caller if he is in an abortable part, and
89 -- to wake up the caller if he is on Entry_Caller_Sleep.
90 -- Call it holding the lock of Entry_Call.Self.
92 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
93 pragma Inline (Wait_For_Completion);
94 -- This procedure suspends the calling task until the specified entry call
95 -- has either been completed or cancelled. On exit, the call will not be
96 -- queued. This waits for calls on protected entries.
97 -- Call this only when holding Self_ID locked.
99 procedure Check_Exception
101 Entry_Call : Entry_Call_Link);
102 pragma Inline (Check_Exception);
103 -- Raise any pending exception from the Entry_Call.
104 -- This should be called at the end of every compiler interface procedure
105 -- that implements an entry call.
106 -- The caller should not be holding any locks, or there will be deadlock.
108 procedure PO_Do_Or_Queue
109 (Object : Protection_Entry_Access;
110 Entry_Call : Entry_Call_Link);
111 -- This procedure executes or queues an entry call, depending
112 -- on the status of the corresponding barrier. It assumes that the
113 -- specified object is locked.
115 ---------------------
116 -- Check_Exception --
117 ---------------------
119 procedure Check_Exception
121 Entry_Call : Entry_Call_Link)
123 pragma Warnings (Off, Self_ID);
125 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
126 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
128 use type Ada.Exceptions.Exception_Id;
130 E : constant Ada.Exceptions.Exception_Id :=
131 Entry_Call.Exception_To_Raise;
134 if E /= Ada.Exceptions.Null_Id then
139 ------------------------
140 -- Send_Program_Error --
141 ------------------------
143 procedure Send_Program_Error (Entry_Call : Entry_Call_Link)
145 Caller : constant Task_Id := Entry_Call.Self;
147 Entry_Call.Exception_To_Raise := Program_Error'Identity;
153 STPO.Write_Lock (Caller);
154 Wakeup_Entry_Caller (Entry_Call);
155 STPO.Unlock (Caller);
160 end Send_Program_Error;
162 -------------------------
163 -- Wait_For_Completion --
164 -------------------------
166 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
167 Self_Id : constant Task_Id := Entry_Call.Self;
169 Self_Id.Common.State := Entry_Caller_Sleep;
170 STPO.Sleep (Self_Id, Entry_Caller_Sleep);
171 Self_Id.Common.State := Runnable;
172 end Wait_For_Completion;
174 -------------------------
175 -- Wakeup_Entry_Caller --
176 -------------------------
178 -- This is called at the end of service of an entry call, to abort the
179 -- caller if he is in an abortable part, and to wake up the caller if it
180 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
182 -- (This enforces the rule that a task must be off-queue if its state is
183 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
185 -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion.
187 procedure Wakeup_Entry_Caller
188 (Entry_Call : Entry_Call_Link)
190 Caller : constant Task_Id := Entry_Call.Self;
193 (Caller.Common.State /= Terminated and then
194 Caller.Common.State /= Unactivated);
196 Entry_Call.State := Done;
197 STPO.Wakeup (Caller, Entry_Caller_Sleep);
198 end Wakeup_Entry_Caller;
200 -----------------------
201 -- Restricted GNARLI --
202 -----------------------
204 --------------------------------------------
205 -- Exceptional_Complete_Single_Entry_Body --
206 --------------------------------------------
208 procedure Exceptional_Complete_Single_Entry_Body
209 (Object : Protection_Entry_Access;
210 Ex : Ada.Exceptions.Exception_Id) is
212 Object.Call_In_Progress.Exception_To_Raise := Ex;
213 end Exceptional_Complete_Single_Entry_Body;
215 ---------------------------------
216 -- Initialize_Protection_Entry --
217 ---------------------------------
219 procedure Initialize_Protection_Entry
220 (Object : Protection_Entry_Access;
221 Ceiling_Priority : Integer;
222 Compiler_Info : System.Address;
223 Entry_Body : Entry_Body_Access)
226 Initialize_Protection (Object.Common'Access, Ceiling_Priority);
228 Object.Compiler_Info := Compiler_Info;
229 Object.Call_In_Progress := null;
230 Object.Entry_Body := Entry_Body;
231 Object.Entry_Queue := null;
232 end Initialize_Protection_Entry;
238 -- Compiler interface only.
239 -- Do not call this procedure from within the run-time system.
241 procedure Lock_Entry (Object : Protection_Entry_Access) is
243 Lock (Object.Common'Access);
246 --------------------------
247 -- Lock_Read_Only_Entry --
248 --------------------------
250 -- Compiler interface only
252 -- Do not call this procedure from within the runtime system
254 procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
256 Lock_Read_Only (Object.Common'Access);
257 end Lock_Read_Only_Entry;
263 procedure PO_Do_Or_Queue
264 (Object : Protection_Entry_Access;
265 Entry_Call : Entry_Call_Link)
267 Barrier_Value : Boolean;
270 -- When the Action procedure for an entry body returns, it must be
271 -- completed (having called [Exceptional_]Complete_Entry_Body).
273 Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
275 if Barrier_Value then
276 if Object.Call_In_Progress /= null then
278 -- This violates the No_Entry_Queue restriction, send
279 -- Program_Error to the caller.
281 Send_Program_Error (Entry_Call);
285 Object.Call_In_Progress := Entry_Call;
286 Object.Entry_Body.Action
287 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
288 Object.Call_In_Progress := null;
294 STPO.Write_Lock (Entry_Call.Self);
295 Wakeup_Entry_Caller (Entry_Call);
296 STPO.Unlock (Entry_Call.Self);
303 pragma Assert (Entry_Call.Mode = Simple_Call);
305 if Object.Entry_Queue /= null then
307 -- This violates the No_Entry_Queue restriction, send
308 -- Program_Error to the caller.
310 Send_Program_Error (Entry_Call);
313 Object.Entry_Queue := Entry_Call;
320 Send_Program_Error (Entry_Call);
323 ----------------------------
324 -- Protected_Single_Count --
325 ----------------------------
327 function Protected_Count_Entry (Object : Protection_Entry) return Natural is
329 if Object.Entry_Queue /= null then
334 end Protected_Count_Entry;
336 ---------------------------------
337 -- Protected_Single_Entry_Call --
338 ---------------------------------
340 procedure Protected_Single_Entry_Call
341 (Object : Protection_Entry_Access;
342 Uninterpreted_Data : System.Address)
344 Self_Id : constant Task_Id := STPO.Self;
345 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
347 -- If pragma Detect_Blocking is active then Program_Error must be
348 -- raised if this potentially blocking operation is called from a
352 and then Self_Id.Common.Protected_Action_Nesting > 0
354 raise Program_Error with "potentially blocking operation";
359 Entry_Call.Mode := Simple_Call;
360 Entry_Call.State := Now_Abortable;
361 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
362 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
364 PO_Do_Or_Queue (Object, Entry_Call'Access);
365 Unlock_Entry (Object);
367 -- The call is either `Done' or not. It cannot be cancelled since there
368 -- is no ATC construct.
370 pragma Assert (Entry_Call.State /= Cancelled);
372 if Entry_Call.State /= Done then
377 STPO.Write_Lock (Self_Id);
378 Wait_For_Completion (Entry_Call'Access);
379 STPO.Unlock (Self_Id);
386 Check_Exception (Self_Id, Entry_Call'Access);
387 end Protected_Single_Entry_Call;
389 -----------------------------------
390 -- Protected_Single_Entry_Caller --
391 -----------------------------------
393 function Protected_Single_Entry_Caller
394 (Object : Protection_Entry) return Task_Id is
396 return Object.Call_In_Progress.Self;
397 end Protected_Single_Entry_Caller;
403 procedure Service_Entry (Object : Protection_Entry_Access) is
404 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
408 if Entry_Call /= null
409 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
411 Object.Entry_Queue := null;
413 if Object.Call_In_Progress /= null then
415 -- Violation of No_Entry_Queue restriction, raise exception
417 Send_Program_Error (Entry_Call);
418 Unlock_Entry (Object);
422 Object.Call_In_Progress := Entry_Call;
423 Object.Entry_Body.Action
424 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
425 Object.Call_In_Progress := null;
426 Caller := Entry_Call.Self;
427 Unlock_Entry (Object);
433 STPO.Write_Lock (Caller);
434 Wakeup_Entry_Caller (Entry_Call);
435 STPO.Unlock (Caller);
442 -- Just unlock the entry
444 Unlock_Entry (Object);
449 Send_Program_Error (Entry_Call);
450 Unlock_Entry (Object);
457 procedure Unlock_Entry (Object : Protection_Entry_Access) is
459 Unlock (Object.Common'Access);
462 end System.Tasking.Protected_Objects.Single_Entry;