1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
9 -- Copyright (C) 1998-2020, 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, to abort the
88 -- caller if he is in an abortable part, and to wake up the caller if he
89 -- is on Entry_Caller_Sleep. Call it holding the lock of Entry_Call.Self.
91 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
92 pragma Inline (Wait_For_Completion);
93 -- This procedure suspends the calling task until the specified entry call
94 -- has either been completed or cancelled. On exit, the call will not be
95 -- queued. This waits for calls on protected entries.
96 -- Call this only when holding Self_ID locked.
98 procedure Check_Exception
100 Entry_Call : Entry_Call_Link);
101 pragma Inline (Check_Exception);
102 -- Raise any pending exception from the Entry_Call. This should be called
103 -- at the end of every compiler interface procedure that implements an
104 -- entry call. The caller should not be holding any locks, or there will
107 procedure PO_Do_Or_Queue
108 (Object : Protection_Entry_Access;
109 Entry_Call : Entry_Call_Link);
110 -- This procedure executes or queues an entry call, depending on the status
111 -- of the corresponding barrier. The specified object is assumed locked.
113 ---------------------
114 -- Check_Exception --
115 ---------------------
117 procedure Check_Exception
119 Entry_Call : Entry_Call_Link)
121 pragma Warnings (Off, Self_ID);
123 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
124 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
126 use type Ada.Exceptions.Exception_Id;
128 E : constant Ada.Exceptions.Exception_Id :=
129 Entry_Call.Exception_To_Raise;
132 if E /= Ada.Exceptions.Null_Id then
137 ------------------------
138 -- Send_Program_Error --
139 ------------------------
141 procedure Send_Program_Error (Entry_Call : Entry_Call_Link) is
142 Caller : constant Task_Id := Entry_Call.Self;
145 Entry_Call.Exception_To_Raise := Program_Error'Identity;
151 STPO.Write_Lock (Caller);
152 Wakeup_Entry_Caller (Entry_Call);
153 STPO.Unlock (Caller);
158 end Send_Program_Error;
160 -------------------------
161 -- Wait_For_Completion --
162 -------------------------
164 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
165 Self_Id : constant Task_Id := Entry_Call.Self;
167 Self_Id.Common.State := Entry_Caller_Sleep;
168 STPO.Sleep (Self_Id, Entry_Caller_Sleep);
169 Self_Id.Common.State := Runnable;
170 end Wait_For_Completion;
172 -------------------------
173 -- Wakeup_Entry_Caller --
174 -------------------------
176 -- This is called at the end of service of an entry call, to abort the
177 -- caller if he is in an abortable part, and to wake up the caller if it
178 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
180 -- (This enforces the rule that a task must be off-queue if its state is
181 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
183 -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion.
185 procedure Wakeup_Entry_Caller
186 (Entry_Call : Entry_Call_Link)
188 Caller : constant Task_Id := Entry_Call.Self;
191 (Caller.Common.State /= Terminated and then
192 Caller.Common.State /= Unactivated);
193 Entry_Call.State := Done;
194 STPO.Wakeup (Caller, Entry_Caller_Sleep);
195 end Wakeup_Entry_Caller;
197 -----------------------
198 -- Restricted GNARLI --
199 -----------------------
201 --------------------------------------------
202 -- Exceptional_Complete_Single_Entry_Body --
203 --------------------------------------------
205 procedure Exceptional_Complete_Single_Entry_Body
206 (Object : Protection_Entry_Access;
207 Ex : Ada.Exceptions.Exception_Id)
210 Object.Call_In_Progress.Exception_To_Raise := Ex;
211 end Exceptional_Complete_Single_Entry_Body;
213 ---------------------------------
214 -- Initialize_Protection_Entry --
215 ---------------------------------
217 procedure Initialize_Protection_Entry
218 (Object : Protection_Entry_Access;
219 Ceiling_Priority : Integer;
220 Compiler_Info : System.Address;
221 Entry_Body : Entry_Body_Access)
224 Initialize_Protection (Object.Common'Access, Ceiling_Priority);
226 Object.Compiler_Info := Compiler_Info;
227 Object.Call_In_Progress := null;
228 Object.Entry_Body := Entry_Body;
229 Object.Entry_Queue := null;
230 end Initialize_Protection_Entry;
236 -- Compiler interface only
238 -- Do not call this procedure from within the run-time system.
240 procedure Lock_Entry (Object : Protection_Entry_Access) is
242 Lock (Object.Common'Access);
245 --------------------------
246 -- Lock_Read_Only_Entry --
247 --------------------------
249 -- Compiler interface only
251 -- Do not call this procedure from within the runtime system
253 procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
255 Lock_Read_Only (Object.Common'Access);
256 end Lock_Read_Only_Entry;
262 procedure PO_Do_Or_Queue
263 (Object : Protection_Entry_Access;
264 Entry_Call : Entry_Call_Link)
266 Barrier_Value : Boolean;
269 -- When the Action procedure for an entry body returns, it must be
270 -- completed (having called [Exceptional_]Complete_Entry_Body).
272 Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
274 if Barrier_Value then
275 if Object.Call_In_Progress /= null then
277 -- This violates the No_Entry_Queue restriction, send
278 -- Program_Error to the caller.
280 Send_Program_Error (Entry_Call);
284 Object.Call_In_Progress := Entry_Call;
285 Object.Entry_Body.Action
286 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
287 Object.Call_In_Progress := null;
293 STPO.Write_Lock (Entry_Call.Self);
294 Wakeup_Entry_Caller (Entry_Call);
295 STPO.Unlock (Entry_Call.Self);
302 pragma Assert (Entry_Call.Mode = Simple_Call);
304 if Object.Entry_Queue /= null then
306 -- This violates the No_Entry_Queue restriction, send
307 -- Program_Error to the caller.
309 Send_Program_Error (Entry_Call);
312 Object.Entry_Queue := Entry_Call;
319 Send_Program_Error (Entry_Call);
322 ---------------------------
323 -- Protected_Count_Entry --
324 ---------------------------
326 function Protected_Count_Entry (Object : Protection_Entry) return Natural is
328 if Object.Entry_Queue /= null then
333 end Protected_Count_Entry;
335 ---------------------------------
336 -- Protected_Single_Entry_Call --
337 ---------------------------------
339 procedure Protected_Single_Entry_Call
340 (Object : Protection_Entry_Access;
341 Uninterpreted_Data : System.Address)
343 Self_Id : constant Task_Id := STPO.Self;
344 Entry_Call : Entry_Call_Record renames
345 Self_Id.Entry_Calls (Self_Id.Entry_Calls'First);
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
397 return Object.Call_In_Progress.Self;
398 end Protected_Single_Entry_Caller;
404 procedure Service_Entry (Object : Protection_Entry_Access) is
405 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
409 if Entry_Call /= null
410 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
412 Object.Entry_Queue := null;
414 if Object.Call_In_Progress /= null then
416 -- Violation of No_Entry_Queue restriction, raise exception
418 Send_Program_Error (Entry_Call);
419 Unlock_Entry (Object);
423 Object.Call_In_Progress := Entry_Call;
424 Object.Entry_Body.Action
425 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
426 Object.Call_In_Progress := null;
427 Caller := Entry_Call.Self;
428 Unlock_Entry (Object);
434 STPO.Write_Lock (Caller);
435 Wakeup_Entry_Caller (Entry_Call);
436 STPO.Unlock (Caller);
443 -- Just unlock the entry
445 Unlock_Entry (Object);
450 Send_Program_Error (Entry_Call);
451 Unlock_Entry (Object);
458 procedure Unlock_Entry (Object : Protection_Entry_Access) is
460 Unlock (Object.Common'Access);
463 end System.Tasking.Protected_Objects.Single_Entry;