File : s-tposen.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2013, Free Software Foundation, Inc. --
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 -- --
19 -- --
20 -- --
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
322 ----------------------------
323 -- Protected_Single_Count --
324 ----------------------------
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;
344 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
345 begin
346 -- If pragma Detect_Blocking is active then Program_Error must be
347 -- raised if this potentially blocking operation is called from a
348 -- protected action.
349
350 if Detect_Blocking
351 and then Self_Id.Common.Protected_Action_Nesting > 0
352 then
353 raise Program_Error with "potentially blocking operation";
354 end if;
355
356 Lock_Entry (Object);
357
358 Entry_Call.Mode := Simple_Call;
359 Entry_Call.State := Now_Abortable;
360 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
361 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
362
363 PO_Do_Or_Queue (Object, Entry_Call'Access);
364 Unlock_Entry (Object);
365
366 -- The call is either `Done' or not. It cannot be cancelled since there
367 -- is no ATC construct.
368
369 pragma Assert (Entry_Call.State /= Cancelled);
370
371 if Entry_Call.State /= Done then
372 if Single_Lock then
373 STPO.Lock_RTS;
374 end if;
375
376 STPO.Write_Lock (Self_Id);
377 Wait_For_Completion (Entry_Call'Access);
378 STPO.Unlock (Self_Id);
379
380 if Single_Lock then
381 STPO.Unlock_RTS;
382 end if;
383 end if;
384
385 Check_Exception (Self_Id, Entry_Call'Access);
386 end Protected_Single_Entry_Call;
387
388 -----------------------------------
389 -- Protected_Single_Entry_Caller --
390 -----------------------------------
391
392 function Protected_Single_Entry_Caller
393 (Object : Protection_Entry) return Task_Id
394 is
395 begin
396 return Object.Call_In_Progress.Self;
397 end Protected_Single_Entry_Caller;
398
399 -------------------
400 -- Service_Entry --
401 -------------------
402
403 procedure Service_Entry (Object : Protection_Entry_Access) is
404 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
405 Caller : Task_Id;
406
407 begin
408 if Entry_Call /= null
409 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
410 then
411 Object.Entry_Queue := null;
412
413 if Object.Call_In_Progress /= null then
414
415 -- Violation of No_Entry_Queue restriction, raise exception
416
417 Send_Program_Error (Entry_Call);
418 Unlock_Entry (Object);
419 return;
420 end if;
421
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);
428
429 if Single_Lock then
430 STPO.Lock_RTS;
431 end if;
432
433 STPO.Write_Lock (Caller);
434 Wakeup_Entry_Caller (Entry_Call);
435 STPO.Unlock (Caller);
436
437 if Single_Lock then
438 STPO.Unlock_RTS;
439 end if;
440
441 else
442 -- Just unlock the entry
443
444 Unlock_Entry (Object);
445 end if;
446
447 exception
448 when others =>
449 Send_Program_Error (Entry_Call);
450 Unlock_Entry (Object);
451 end Service_Entry;
452
453 ------------------
454 -- Unlock_Entry --
455 ------------------
456
457 procedure Unlock_Entry (Object : Protection_Entry_Access) is
458 begin
459 Unlock (Object.Common'Access);
460 end Unlock_Entry;
461
462 end System.Tasking.Protected_Objects.Single_Entry;