|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
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. --
|
|
|
21 -- --
|
|
|
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/>. --
|
|
|
26 -- --
|
|
|
27 -- GNARL was developed by the GNARL team at Florida State University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 pragma Style_Checks (All_Checks);
|
|
|
33 -- Turn off subprogram ordering check, since restricted GNARLI subprograms are
|
|
|
34 -- gathered together at end.
|
|
|
35
|
|
|
36 -- This package provides an optimized version of Protected_Objects.Operations
|
|
|
37 -- and Protected_Objects.Entries making the following assumptions:
|
|
|
38
|
|
|
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
|
|
|
45 -- No Requeue
|
|
|
46 -- None of the tasks will terminate (no need for finalization)
|
|
|
47
|
|
|
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,
|
|
|
53 -- Service_Entry).
|
|
|
54
|
|
|
55 pragma Polling (Off);
|
|
|
56 -- Turn off polling, we do not want polling to take place during tasking
|
|
|
57 -- operations. It can cause infinite loops and other problems.
|
|
|
58
|
|
|
59 pragma Suppress (All_Checks);
|
|
|
60 -- Why is this required ???
|
|
|
61
|
|
|
62 with Ada.Exceptions;
|
|
|
63
|
|
|
64 with System.Task_Primitives.Operations;
|
|
|
65 with System.Parameters;
|
|
|
66
|
|
|
67 package body System.Tasking.Protected_Objects.Single_Entry is
|
|
|
68
|
|
|
69 package STPO renames System.Task_Primitives.Operations;
|
|
|
70
|
|
|
71 use Parameters;
|
|
|
72
|
|
|
73 -----------------------
|
|
|
74 -- Local Subprograms --
|
|
|
75 -----------------------
|
|
|
76
|
|
|
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
|
|
|
80
|
|
|
81 --------------------------
|
|
|
82 -- Entry Calls Handling --
|
|
|
83 --------------------------
|
|
|
84
|
|
|
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.
|
|
|
90
|
|
|
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.
|
|
|
97
|
|
|
98 procedure Check_Exception
|
|
|
99 (Self_ID : Task_Id;
|
|
|
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
|
|
|
105 -- be deadlock.
|
|
|
106
|
|
|
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.
|
|
|
112
|
|
|
113 ---------------------
|
|
|
114 -- Check_Exception --
|
|
|
115 ---------------------
|
|
|
116
|
|
|
117 procedure Check_Exception
|
|
|
118 (Self_ID : Task_Id;
|
|
|
119 Entry_Call : Entry_Call_Link)
|
|
|
120 is
|
|
|
121 pragma Warnings (Off, Self_ID);
|
|
|
122
|
|
|
123 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
|
|
|
124 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
|
|
|
125
|
|
|
126 use type Ada.Exceptions.Exception_Id;
|
|
|
127
|
|
|
128 E : constant Ada.Exceptions.Exception_Id :=
|
|
|
129 Entry_Call.Exception_To_Raise;
|
|
|
130
|
|
|
131 begin
|
|
|
132 if E /= Ada.Exceptions.Null_Id then
|
|
|
133 Internal_Raise (E);
|
|
|
134 end if;
|
|
|
135 end Check_Exception;
|
|
|
136
|
|
|
137 ------------------------
|
|
|
138 -- Send_Program_Error --
|
|
|
139 ------------------------
|
|
|
140
|
|
|
141 procedure Send_Program_Error (Entry_Call : Entry_Call_Link) is
|
|
|
142 Caller : constant Task_Id := Entry_Call.Self;
|
|
|
143
|
|
|
144 begin
|
|
|
145 Entry_Call.Exception_To_Raise := Program_Error'Identity;
|
|
|
146
|
|
|
147 if Single_Lock then
|
|
|
148 STPO.Lock_RTS;
|
|
|
149 end if;
|
|
|
150
|
|
|
151 STPO.Write_Lock (Caller);
|
|
|
152 Wakeup_Entry_Caller (Entry_Call);
|
|
|
153 STPO.Unlock (Caller);
|
|
|
154
|
|
|
155 if Single_Lock then
|
|
|
156 STPO.Unlock_RTS;
|
|
|
157 end if;
|
|
|
158 end Send_Program_Error;
|
|
|
159
|
|
|
160 -------------------------
|
|
|
161 -- Wait_For_Completion --
|
|
|
162 -------------------------
|
|
|
163
|
|
|
164 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
|
|
|
165 Self_Id : constant Task_Id := Entry_Call.Self;
|
|
|
166 begin
|
|
|
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;
|
|
|
171
|
|
|
172 -------------------------
|
|
|
173 -- Wakeup_Entry_Caller --
|
|
|
174 -------------------------
|
|
|
175
|
|
|
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.
|
|
|
179
|
|
|
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.
|
|
|
182
|
|
|
183 -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion.
|
|
|
184
|
|
|
185 procedure Wakeup_Entry_Caller
|
|
|
186 (Entry_Call : Entry_Call_Link)
|
|
|
187 is
|
|
|
188 Caller : constant Task_Id := Entry_Call.Self;
|
|
|
189 begin
|
|
|
190 pragma Assert
|
|
|
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;
|
|
|
196
|
|
|
197 -----------------------
|
|
|
198 -- Restricted GNARLI --
|
|
|
199 -----------------------
|
|
|
200
|
|
|
201 --------------------------------------------
|
|
|
202 -- Exceptional_Complete_Single_Entry_Body --
|
|
|
203 --------------------------------------------
|
|
|
204
|
|
|
205 procedure Exceptional_Complete_Single_Entry_Body
|
|
|
206 (Object : Protection_Entry_Access;
|
|
|
207 Ex : Ada.Exceptions.Exception_Id)
|
|
|
208 is
|
|
|
209 begin
|
|
|
210 Object.Call_In_Progress.Exception_To_Raise := Ex;
|
|
|
211 end Exceptional_Complete_Single_Entry_Body;
|
|
|
212
|
|
|
213 ---------------------------------
|
|
|
214 -- Initialize_Protection_Entry --
|
|
|
215 ---------------------------------
|
|
|
216
|
|
|
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)
|
|
|
222 is
|
|
|
223 begin
|
|
|
224 Initialize_Protection (Object.Common'Access, Ceiling_Priority);
|
|
|
225
|
|
|
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;
|
|
|
231
|
|
|
232 ----------------
|
|
|
233 -- Lock_Entry --
|
|
|
234 ----------------
|
|
|
235
|
|
|
236 -- Compiler interface only
|
|
|
237
|
|
|
238 -- Do not call this procedure from within the run-time system.
|
|
|
239
|
|
|
240 procedure Lock_Entry (Object : Protection_Entry_Access) is
|
|
|
241 begin
|
|
|
242 Lock (Object.Common'Access);
|
|
|
243 end Lock_Entry;
|
|
|
244
|
|
|
245 --------------------------
|
|
|
246 -- Lock_Read_Only_Entry --
|
|
|
247 --------------------------
|
|
|
248
|
|
|
249 -- Compiler interface only
|
|
|
250
|
|
|
251 -- Do not call this procedure from within the runtime system
|
|
|
252
|
|
|
253 procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
|
|
|
254 begin
|
|
|
255 Lock_Read_Only (Object.Common'Access);
|
|
|
256 end Lock_Read_Only_Entry;
|
|
|
257
|
|
|
258 --------------------
|
|
|
259 -- PO_Do_Or_Queue --
|
|
|
260 --------------------
|
|
|
261
|
|
|
262 procedure PO_Do_Or_Queue
|
|
|
263 (Object : Protection_Entry_Access;
|
|
|
264 Entry_Call : Entry_Call_Link)
|
|
|
265 is
|
|
|
266 Barrier_Value : Boolean;
|
|
|
267
|
|
|
268 begin
|
|
|
269 -- When the Action procedure for an entry body returns, it must be
|
|
|
270 -- completed (having called [Exceptional_]Complete_Entry_Body).
|
|
|
271
|
|
|
272 Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
|
|
|
273
|
|
|
274 if Barrier_Value then
|
|
|
275 if Object.Call_In_Progress /= null then
|
|
|
276
|
|
|
277 -- This violates the No_Entry_Queue restriction, send
|
|
|
278 -- Program_Error to the caller.
|
|
|
279
|
|
|
280 Send_Program_Error (Entry_Call);
|
|
|
281 return;
|
|
|
282 end if;
|
|
|
283
|
|
|
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;
|
|
|
288
|
|
|
289 if Single_Lock then
|
|
|
290 STPO.Lock_RTS;
|
|
|
291 end if;
|
|
|
292
|
|
|
293 STPO.Write_Lock (Entry_Call.Self);
|
|
|
294 Wakeup_Entry_Caller (Entry_Call);
|
|
|
295 STPO.Unlock (Entry_Call.Self);
|
|
|
296
|
|
|
297 if Single_Lock then
|
|
|
298 STPO.Unlock_RTS;
|
|
|
299 end if;
|
|
|
300
|
|
|
301 else
|
|
|
302 pragma Assert (Entry_Call.Mode = Simple_Call);
|
|
|
303
|
|
|
304 if Object.Entry_Queue /= null then
|
|
|
305
|
|
|
306 -- This violates the No_Entry_Queue restriction, send
|
|
|
307 -- Program_Error to the caller.
|
|
|
308
|
|
|
309 Send_Program_Error (Entry_Call);
|
|
|
310 return;
|
|
|
311 else
|
|
|
312 Object.Entry_Queue := Entry_Call;
|
|
|
313 end if;
|
|
|
314
|
|
|
315 end if;
|
|
|
316
|
|
|
317 exception
|
|
|
318 when others =>
|
|
|
319 Send_Program_Error (Entry_Call);
|
|
|
320 end PO_Do_Or_Queue;
|
|
|
321
|
|
131
|
322 ---------------------------
|
|
|
323 -- Protected_Count_Entry --
|
|
|
324 ---------------------------
|
|
111
|
325
|
|
|
326 function Protected_Count_Entry (Object : Protection_Entry) return Natural is
|
|
|
327 begin
|
|
|
328 if Object.Entry_Queue /= null then
|
|
|
329 return 1;
|
|
|
330 else
|
|
|
331 return 0;
|
|
|
332 end if;
|
|
|
333 end Protected_Count_Entry;
|
|
|
334
|
|
|
335 ---------------------------------
|
|
|
336 -- Protected_Single_Entry_Call --
|
|
|
337 ---------------------------------
|
|
|
338
|
|
|
339 procedure Protected_Single_Entry_Call
|
|
|
340 (Object : Protection_Entry_Access;
|
|
|
341 Uninterpreted_Data : System.Address)
|
|
|
342 is
|
|
|
343 Self_Id : constant Task_Id := STPO.Self;
|
|
145
|
344 Entry_Call : Entry_Call_Record renames
|
|
|
345 Self_Id.Entry_Calls (Self_Id.Entry_Calls'First);
|
|
111
|
346 begin
|
|
|
347 -- If pragma Detect_Blocking is active then Program_Error must be
|
|
|
348 -- raised if this potentially blocking operation is called from a
|
|
|
349 -- protected action.
|
|
|
350
|
|
|
351 if Detect_Blocking
|
|
|
352 and then Self_Id.Common.Protected_Action_Nesting > 0
|
|
|
353 then
|
|
|
354 raise Program_Error with "potentially blocking operation";
|
|
|
355 end if;
|
|
|
356
|
|
|
357 Lock_Entry (Object);
|
|
|
358
|
|
|
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;
|
|
|
363
|
|
|
364 PO_Do_Or_Queue (Object, Entry_Call'Access);
|
|
|
365 Unlock_Entry (Object);
|
|
|
366
|
|
|
367 -- The call is either `Done' or not. It cannot be cancelled since there
|
|
|
368 -- is no ATC construct.
|
|
|
369
|
|
|
370 pragma Assert (Entry_Call.State /= Cancelled);
|
|
|
371
|
|
|
372 if Entry_Call.State /= Done then
|
|
|
373 if Single_Lock then
|
|
|
374 STPO.Lock_RTS;
|
|
|
375 end if;
|
|
|
376
|
|
|
377 STPO.Write_Lock (Self_Id);
|
|
|
378 Wait_For_Completion (Entry_Call'Access);
|
|
|
379 STPO.Unlock (Self_Id);
|
|
|
380
|
|
|
381 if Single_Lock then
|
|
|
382 STPO.Unlock_RTS;
|
|
|
383 end if;
|
|
|
384 end if;
|
|
|
385
|
|
|
386 Check_Exception (Self_Id, Entry_Call'Access);
|
|
|
387 end Protected_Single_Entry_Call;
|
|
|
388
|
|
|
389 -----------------------------------
|
|
|
390 -- Protected_Single_Entry_Caller --
|
|
|
391 -----------------------------------
|
|
|
392
|
|
|
393 function Protected_Single_Entry_Caller
|
|
|
394 (Object : Protection_Entry) return Task_Id
|
|
|
395 is
|
|
|
396 begin
|
|
|
397 return Object.Call_In_Progress.Self;
|
|
|
398 end Protected_Single_Entry_Caller;
|
|
|
399
|
|
|
400 -------------------
|
|
|
401 -- Service_Entry --
|
|
|
402 -------------------
|
|
|
403
|
|
|
404 procedure Service_Entry (Object : Protection_Entry_Access) is
|
|
|
405 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
|
|
|
406 Caller : Task_Id;
|
|
|
407
|
|
|
408 begin
|
|
|
409 if Entry_Call /= null
|
|
|
410 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
|
|
|
411 then
|
|
|
412 Object.Entry_Queue := null;
|
|
|
413
|
|
|
414 if Object.Call_In_Progress /= null then
|
|
|
415
|
|
|
416 -- Violation of No_Entry_Queue restriction, raise exception
|
|
|
417
|
|
|
418 Send_Program_Error (Entry_Call);
|
|
|
419 Unlock_Entry (Object);
|
|
|
420 return;
|
|
|
421 end if;
|
|
|
422
|
|
|
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);
|
|
|
429
|
|
|
430 if Single_Lock then
|
|
|
431 STPO.Lock_RTS;
|
|
|
432 end if;
|
|
|
433
|
|
|
434 STPO.Write_Lock (Caller);
|
|
|
435 Wakeup_Entry_Caller (Entry_Call);
|
|
|
436 STPO.Unlock (Caller);
|
|
|
437
|
|
|
438 if Single_Lock then
|
|
|
439 STPO.Unlock_RTS;
|
|
|
440 end if;
|
|
|
441
|
|
|
442 else
|
|
|
443 -- Just unlock the entry
|
|
|
444
|
|
|
445 Unlock_Entry (Object);
|
|
|
446 end if;
|
|
|
447
|
|
|
448 exception
|
|
|
449 when others =>
|
|
|
450 Send_Program_Error (Entry_Call);
|
|
|
451 Unlock_Entry (Object);
|
|
|
452 end Service_Entry;
|
|
|
453
|
|
|
454 ------------------
|
|
|
455 -- Unlock_Entry --
|
|
|
456 ------------------
|
|
|
457
|
|
|
458 procedure Unlock_Entry (Object : Protection_Entry_Access) is
|
|
|
459 begin
|
|
|
460 Unlock (Object.Common'Access);
|
|
|
461 end Unlock_Entry;
|
|
|
462
|
|
|
463 end System.Tasking.Protected_Objects.Single_Entry;
|
