]>
Commit | Line | Data |
---|---|---|
cacbc350 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
ff7cce69 | 3 | -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
cacbc350 | 4 | -- -- |
366b8af7 | 5 | -- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- |
cacbc350 | 6 | -- -- |
ff7cce69 | 7 | -- B o d y -- |
cacbc350 | 8 | -- -- |
748086b7 | 9 | -- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- |
cacbc350 RK |
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- -- | |
748086b7 JJ |
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- -- | |
cacbc350 | 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
748086b7 | 16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
cacbc350 | 17 | -- -- |
748086b7 JJ |
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/>. -- | |
cacbc350 | 26 | -- -- |
fbf5a39b AC |
27 | -- GNARL was developed by the GNARL team at Florida State University. -- |
28 | -- Extensive contributions were provided by Ada Core Technologies, Inc. -- | |
cacbc350 RK |
29 | -- -- |
30 | ------------------------------------------------------------------------------ | |
31 | ||
32 | pragma Style_Checks (All_Checks); | |
366b8af7 RD |
33 | -- Turn off subprogram ordering check, since restricted GNARLI subprograms are |
34 | -- gathered together at end. | |
cacbc350 RK |
35 | |
36 | -- This package provides an optimized version of Protected_Objects.Operations | |
37 | -- and Protected_Objects.Entries making the following assumptions: | |
ff7cce69 AC |
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 | ||
cacbc350 RK |
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, | |
8a7988f5 | 53 | -- Service_Entry). |
cacbc350 RK |
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); | |
366b8af7 | 60 | -- Why is this required ??? |
cacbc350 RK |
61 | |
62 | with Ada.Exceptions; | |
cacbc350 | 63 | |
366b8af7 | 64 | with System.Task_Primitives.Operations; |
07fc65c4 | 65 | with System.Parameters; |
cacbc350 RK |
66 | |
67 | package body System.Tasking.Protected_Objects.Single_Entry is | |
68 | ||
69 | package STPO renames System.Task_Primitives.Operations; | |
70 | ||
07fc65c4 | 71 | use Parameters; |
cacbc350 RK |
72 | |
73 | ----------------------- | |
74 | -- Local Subprograms -- | |
75 | ----------------------- | |
76 | ||
77 | procedure Send_Program_Error | |
b5e792e2 | 78 | (Self_Id : Task_Id; |
cacbc350 RK |
79 | Entry_Call : Entry_Call_Link); |
80 | pragma Inline (Send_Program_Error); | |
81 | -- Raise Program_Error in the caller of the specified entry call | |
82 | ||
83 | -------------------------- | |
84 | -- Entry Calls Handling -- | |
85 | -------------------------- | |
86 | ||
87 | procedure Wakeup_Entry_Caller | |
b5e792e2 | 88 | (Self_ID : Task_Id; |
cacbc350 RK |
89 | Entry_Call : Entry_Call_Link; |
90 | New_State : Entry_Call_State); | |
91 | pragma Inline (Wakeup_Entry_Caller); | |
92 | -- This is called at the end of service of an entry call, | |
93 | -- to abort the caller if he is in an abortable part, and | |
94 | -- to wake up the caller if he is on Entry_Caller_Sleep. | |
95 | -- Call it holding the lock of Entry_Call.Self. | |
96 | -- | |
97 | -- Timed_Call or Simple_Call: | |
98 | -- The caller is waiting on Entry_Caller_Sleep, in | |
99 | -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. | |
100 | ||
07fc65c4 | 101 | procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); |
cacbc350 RK |
102 | pragma Inline (Wait_For_Completion); |
103 | -- This procedure suspends the calling task until the specified entry call | |
104 | -- has either been completed or cancelled. On exit, the call will not be | |
105 | -- queued. This waits for calls on protected entries. | |
106 | -- Call this only when holding Self_ID locked. | |
107 | ||
108 | procedure Wait_For_Completion_With_Timeout | |
07fc65c4 | 109 | (Entry_Call : Entry_Call_Link; |
cacbc350 RK |
110 | Wakeup_Time : Duration; |
111 | Mode : Delay_Modes); | |
112 | -- Same as Wait_For_Completion but it waits for a timeout with the value | |
113 | -- specified in Wakeup_Time as well. | |
cacbc350 RK |
114 | |
115 | procedure Check_Exception | |
b5e792e2 | 116 | (Self_ID : Task_Id; |
cacbc350 RK |
117 | Entry_Call : Entry_Call_Link); |
118 | pragma Inline (Check_Exception); | |
119 | -- Raise any pending exception from the Entry_Call. | |
120 | -- This should be called at the end of every compiler interface procedure | |
121 | -- that implements an entry call. | |
122 | -- The caller should not be holding any locks, or there will be deadlock. | |
123 | ||
124 | procedure PO_Do_Or_Queue | |
b5e792e2 | 125 | (Self_Id : Task_Id; |
cacbc350 RK |
126 | Object : Protection_Entry_Access; |
127 | Entry_Call : Entry_Call_Link); | |
3a77b68d GB |
128 | -- This procedure executes or queues an entry call, depending |
129 | -- on the status of the corresponding barrier. It assumes that the | |
130 | -- specified object is locked. | |
cacbc350 RK |
131 | |
132 | --------------------- | |
133 | -- Check_Exception -- | |
134 | --------------------- | |
135 | ||
136 | procedure Check_Exception | |
b5e792e2 | 137 | (Self_ID : Task_Id; |
cacbc350 RK |
138 | Entry_Call : Entry_Call_Link) |
139 | is | |
07fc65c4 GB |
140 | pragma Warnings (Off, Self_ID); |
141 | ||
cacbc350 RK |
142 | procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); |
143 | pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); | |
144 | ||
3a77b68d GB |
145 | use type Ada.Exceptions.Exception_Id; |
146 | ||
cacbc350 | 147 | E : constant Ada.Exceptions.Exception_Id := |
366b8af7 | 148 | Entry_Call.Exception_To_Raise; |
cacbc350 RK |
149 | |
150 | begin | |
151 | if E /= Ada.Exceptions.Null_Id then | |
152 | Internal_Raise (E); | |
153 | end if; | |
154 | end Check_Exception; | |
155 | ||
156 | ------------------------ | |
157 | -- Send_Program_Error -- | |
158 | ------------------------ | |
159 | ||
160 | procedure Send_Program_Error | |
b5e792e2 | 161 | (Self_Id : Task_Id; |
cacbc350 RK |
162 | Entry_Call : Entry_Call_Link) |
163 | is | |
b5e792e2 | 164 | Caller : constant Task_Id := Entry_Call.Self; |
cacbc350 RK |
165 | begin |
166 | Entry_Call.Exception_To_Raise := Program_Error'Identity; | |
07fc65c4 GB |
167 | |
168 | if Single_Lock then | |
169 | STPO.Lock_RTS; | |
170 | end if; | |
171 | ||
cacbc350 RK |
172 | STPO.Write_Lock (Caller); |
173 | Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); | |
174 | STPO.Unlock (Caller); | |
07fc65c4 GB |
175 | |
176 | if Single_Lock then | |
177 | STPO.Unlock_RTS; | |
178 | end if; | |
cacbc350 RK |
179 | end Send_Program_Error; |
180 | ||
181 | ------------------------- | |
182 | -- Wait_For_Completion -- | |
183 | ------------------------- | |
184 | ||
07fc65c4 | 185 | procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is |
b5e792e2 | 186 | Self_Id : constant Task_Id := Entry_Call.Self; |
cacbc350 | 187 | begin |
07fc65c4 GB |
188 | Self_Id.Common.State := Entry_Caller_Sleep; |
189 | STPO.Sleep (Self_Id, Entry_Caller_Sleep); | |
190 | Self_Id.Common.State := Runnable; | |
cacbc350 RK |
191 | end Wait_For_Completion; |
192 | ||
193 | -------------------------------------- | |
194 | -- Wait_For_Completion_With_Timeout -- | |
195 | -------------------------------------- | |
196 | ||
cacbc350 | 197 | procedure Wait_For_Completion_With_Timeout |
07fc65c4 | 198 | (Entry_Call : Entry_Call_Link; |
cacbc350 RK |
199 | Wakeup_Time : Duration; |
200 | Mode : Delay_Modes) | |
201 | is | |
b5e792e2 | 202 | Self_Id : constant Task_Id := Entry_Call.Self; |
cacbc350 | 203 | Timedout : Boolean; |
67ce0d7e | 204 | |
cacbc350 | 205 | Yielded : Boolean; |
67ce0d7e | 206 | pragma Unreferenced (Yielded); |
cacbc350 RK |
207 | |
208 | use type Ada.Exceptions.Exception_Id; | |
209 | ||
210 | begin | |
07fc65c4 GB |
211 | -- This procedure waits for the entry call to be served, with a timeout. |
212 | -- It tries to cancel the call if the timeout expires before the call is | |
213 | -- served. | |
214 | ||
215 | -- If we wake up from the timed sleep operation here, it may be for the | |
216 | -- following possible reasons: | |
217 | ||
218 | -- 1) The entry call is done being served. | |
219 | -- 2) The timeout has expired (Timedout = True) | |
220 | ||
221 | -- Once the timeout has expired we may need to continue to wait if the | |
222 | -- call is already being serviced. In that case, we want to go back to | |
223 | -- sleep, but without any timeout. The variable Timedout is used to | |
224 | -- control this. If the Timedout flag is set, we do not need to Sleep | |
225 | -- with a timeout. We just sleep until we get a wakeup for some status | |
226 | -- change. | |
cacbc350 | 227 | |
cacbc350 | 228 | pragma Assert (Entry_Call.Mode = Timed_Call); |
07fc65c4 | 229 | Self_Id.Common.State := Entry_Caller_Sleep; |
cacbc350 RK |
230 | |
231 | STPO.Timed_Sleep | |
07fc65c4 | 232 | (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); |
cacbc350 RK |
233 | |
234 | if Timedout then | |
235 | Entry_Call.State := Cancelled; | |
236 | else | |
237 | Entry_Call.State := Done; | |
238 | end if; | |
239 | ||
07fc65c4 | 240 | Self_Id.Common.State := Runnable; |
cacbc350 RK |
241 | end Wait_For_Completion_With_Timeout; |
242 | ||
243 | ------------------------- | |
244 | -- Wakeup_Entry_Caller -- | |
245 | ------------------------- | |
246 | ||
247 | -- This is called at the end of service of an entry call, to abort the | |
248 | -- caller if he is in an abortable part, and to wake up the caller if it | |
249 | -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. | |
250 | ||
251 | -- (This enforces the rule that a task must be off-queue if its state is | |
252 | -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. | |
253 | ||
254 | -- Timed_Call or Simple_Call: | |
255 | -- The caller is waiting on Entry_Caller_Sleep, in | |
256 | -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. | |
257 | ||
258 | -- Conditional_Call: | |
259 | -- The caller might be in Wait_For_Completion, | |
260 | -- waiting for a rendezvous (possibly requeued without abort) | |
261 | -- to complete. | |
262 | ||
263 | procedure Wakeup_Entry_Caller | |
b5e792e2 | 264 | (Self_ID : Task_Id; |
cacbc350 RK |
265 | Entry_Call : Entry_Call_Link; |
266 | New_State : Entry_Call_State) | |
267 | is | |
07fc65c4 GB |
268 | pragma Warnings (Off, Self_ID); |
269 | ||
b5e792e2 | 270 | Caller : constant Task_Id := Entry_Call.Self; |
07fc65c4 | 271 | |
cacbc350 RK |
272 | begin |
273 | pragma Assert (New_State = Done or else New_State = Cancelled); | |
274 | pragma Assert | |
275 | (Caller.Common.State /= Terminated and then | |
276 | Caller.Common.State /= Unactivated); | |
277 | ||
278 | Entry_Call.State := New_State; | |
279 | STPO.Wakeup (Caller, Entry_Caller_Sleep); | |
280 | end Wakeup_Entry_Caller; | |
281 | ||
282 | ----------------------- | |
283 | -- Restricted GNARLI -- | |
284 | ----------------------- | |
285 | ||
286 | -------------------------------- | |
287 | -- Complete_Single_Entry_Body -- | |
288 | -------------------------------- | |
289 | ||
290 | procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is | |
07fc65c4 GB |
291 | pragma Warnings (Off, Object); |
292 | ||
cacbc350 | 293 | begin |
07fc65c4 GB |
294 | -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise |
295 | -- has already been set to Null_Id). | |
296 | ||
cacbc350 RK |
297 | null; |
298 | end Complete_Single_Entry_Body; | |
299 | ||
300 | -------------------------------------------- | |
301 | -- Exceptional_Complete_Single_Entry_Body -- | |
302 | -------------------------------------------- | |
303 | ||
304 | procedure Exceptional_Complete_Single_Entry_Body | |
305 | (Object : Protection_Entry_Access; | |
306 | Ex : Ada.Exceptions.Exception_Id) is | |
307 | begin | |
308 | Object.Call_In_Progress.Exception_To_Raise := Ex; | |
309 | end Exceptional_Complete_Single_Entry_Body; | |
310 | ||
311 | --------------------------------- | |
312 | -- Initialize_Protection_Entry -- | |
313 | --------------------------------- | |
314 | ||
315 | procedure Initialize_Protection_Entry | |
316 | (Object : Protection_Entry_Access; | |
317 | Ceiling_Priority : Integer; | |
318 | Compiler_Info : System.Address; | |
319 | Entry_Body : Entry_Body_Access) | |
320 | is | |
07fc65c4 | 321 | Init_Priority : Integer := Ceiling_Priority; |
cacbc350 RK |
322 | begin |
323 | if Init_Priority = Unspecified_Priority then | |
324 | Init_Priority := System.Priority'Last; | |
325 | end if; | |
326 | ||
327 | STPO.Initialize_Lock (Init_Priority, Object.L'Access); | |
328 | Object.Ceiling := System.Any_Priority (Init_Priority); | |
ce65449a | 329 | Object.Owner := Null_Task; |
cacbc350 RK |
330 | Object.Compiler_Info := Compiler_Info; |
331 | Object.Call_In_Progress := null; | |
332 | Object.Entry_Body := Entry_Body; | |
333 | Object.Entry_Queue := null; | |
334 | end Initialize_Protection_Entry; | |
335 | ||
336 | ---------------- | |
337 | -- Lock_Entry -- | |
338 | ---------------- | |
339 | ||
340 | -- Compiler interface only. | |
341 | -- Do not call this procedure from within the run-time system. | |
342 | ||
343 | procedure Lock_Entry (Object : Protection_Entry_Access) is | |
344 | Ceiling_Violation : Boolean; | |
c885d7a1 | 345 | |
cacbc350 | 346 | begin |
ce65449a JR |
347 | -- If pragma Detect_Blocking is active then, as described in the ARM |
348 | -- 9.5.1, par. 15, we must check whether this is an external call on a | |
349 | -- protected subprogram with the same target object as that of the | |
350 | -- protected action that is currently in progress (i.e., if the caller | |
351 | -- is already the protected object's owner). If this is the case hence | |
352 | -- Program_Error must be raised. | |
353 | ||
354 | if Detect_Blocking and then Object.Owner = Self then | |
355 | raise Program_Error; | |
356 | end if; | |
357 | ||
358 | STPO.Write_Lock (Object.L'Access, Ceiling_Violation); | |
359 | ||
360 | if Ceiling_Violation then | |
361 | raise Program_Error; | |
362 | end if; | |
363 | ||
364 | -- We are entering in a protected action, so that we increase the | |
365 | -- protected object nesting level (if pragma Detect_Blocking is | |
366 | -- active), and update the protected object's owner. | |
c885d7a1 AC |
367 | |
368 | if Detect_Blocking then | |
369 | declare | |
ce65449a JR |
370 | Self_Id : constant Task_Id := Self; |
371 | ||
c885d7a1 | 372 | begin |
ce65449a JR |
373 | -- Update the protected object's owner |
374 | ||
375 | Object.Owner := Self_Id; | |
376 | ||
377 | -- Increase protected object nesting level | |
f0747897 AC |
378 | |
379 | Self_Id.Common.Protected_Action_Nesting := | |
380 | Self_Id.Common.Protected_Action_Nesting + 1; | |
c885d7a1 AC |
381 | end; |
382 | end if; | |
cacbc350 RK |
383 | end Lock_Entry; |
384 | ||
385 | -------------------------- | |
386 | -- Lock_Read_Only_Entry -- | |
387 | -------------------------- | |
388 | ||
ce65449a JR |
389 | -- Compiler interface only |
390 | ||
391 | -- Do not call this procedure from within the runtime system | |
cacbc350 RK |
392 | |
393 | procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is | |
394 | Ceiling_Violation : Boolean; | |
c885d7a1 | 395 | |
cacbc350 | 396 | begin |
ce65449a JR |
397 | -- If pragma Detect_Blocking is active then, as described in the ARM |
398 | -- 9.5.1, par. 15, we must check whether this is an external call on a | |
399 | -- protected subprogram with the same target object as that of the | |
400 | -- protected action that is currently in progress (i.e., if the caller | |
401 | -- is already the protected object's owner). If this is the case hence | |
402 | -- Program_Error must be raised. | |
403 | ||
404 | -- Note that in this case (getting read access), several tasks may | |
405 | -- have read ownership of the protected object, so that this method of | |
406 | -- storing the (single) protected object's owner does not work | |
407 | -- reliably for read locks. However, this is the approach taken for two | |
12a13f01 | 408 | -- major reasons: first, this function is not currently being used (it |
ce65449a JR |
409 | -- is provided for possible future use), and second, it largely |
410 | -- simplifies the implementation. | |
411 | ||
412 | if Detect_Blocking and then Object.Owner = Self then | |
413 | raise Program_Error; | |
414 | end if; | |
415 | ||
416 | STPO.Read_Lock (Object.L'Access, Ceiling_Violation); | |
417 | ||
418 | if Ceiling_Violation then | |
419 | raise Program_Error; | |
420 | end if; | |
421 | ||
422 | -- We are entering in a protected action, so that we increase the | |
423 | -- protected object nesting level (if pragma Detect_Blocking is | |
424 | -- active), and update the protected object's owner. | |
c885d7a1 AC |
425 | |
426 | if Detect_Blocking then | |
427 | declare | |
ce65449a JR |
428 | Self_Id : constant Task_Id := Self; |
429 | ||
c885d7a1 | 430 | begin |
ce65449a JR |
431 | -- Update the protected object's owner |
432 | ||
433 | Object.Owner := Self_Id; | |
434 | ||
435 | -- Increase protected object nesting level | |
f0747897 AC |
436 | |
437 | Self_Id.Common.Protected_Action_Nesting := | |
438 | Self_Id.Common.Protected_Action_Nesting + 1; | |
c885d7a1 AC |
439 | end; |
440 | end if; | |
cacbc350 RK |
441 | end Lock_Read_Only_Entry; |
442 | ||
443 | -------------------- | |
444 | -- PO_Do_Or_Queue -- | |
445 | -------------------- | |
446 | ||
447 | procedure PO_Do_Or_Queue | |
b5e792e2 | 448 | (Self_Id : Task_Id; |
cacbc350 RK |
449 | Object : Protection_Entry_Access; |
450 | Entry_Call : Entry_Call_Link) | |
451 | is | |
452 | Barrier_Value : Boolean; | |
ce65449a | 453 | |
cacbc350 RK |
454 | begin |
455 | -- When the Action procedure for an entry body returns, it must be | |
456 | -- completed (having called [Exceptional_]Complete_Entry_Body). | |
457 | ||
458 | Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1); | |
459 | ||
460 | if Barrier_Value then | |
461 | if Object.Call_In_Progress /= null then | |
ce65449a | 462 | |
cacbc350 RK |
463 | -- This violates the No_Entry_Queue restriction, send |
464 | -- Program_Error to the caller. | |
465 | ||
466 | Send_Program_Error (Self_Id, Entry_Call); | |
467 | return; | |
468 | end if; | |
469 | ||
470 | Object.Call_In_Progress := Entry_Call; | |
471 | Object.Entry_Body.Action | |
472 | (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); | |
473 | Object.Call_In_Progress := null; | |
07fc65c4 GB |
474 | |
475 | if Single_Lock then | |
476 | STPO.Lock_RTS; | |
477 | end if; | |
478 | ||
479 | STPO.Write_Lock (Entry_Call.Self); | |
cacbc350 | 480 | Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); |
07fc65c4 GB |
481 | STPO.Unlock (Entry_Call.Self); |
482 | ||
483 | if Single_Lock then | |
484 | STPO.Unlock_RTS; | |
485 | end if; | |
cacbc350 RK |
486 | |
487 | elsif Entry_Call.Mode /= Conditional_Call then | |
ff7cce69 AC |
488 | if Object.Entry_Queue /= null then |
489 | ||
490 | -- This violates the No_Entry_Queue restriction, send | |
491 | -- Program_Error to the caller. | |
492 | ||
493 | Send_Program_Error (Self_Id, Entry_Call); | |
494 | return; | |
495 | else | |
496 | Object.Entry_Queue := Entry_Call; | |
497 | end if; | |
498 | ||
cacbc350 RK |
499 | else |
500 | -- Conditional_Call | |
501 | ||
07fc65c4 GB |
502 | if Single_Lock then |
503 | STPO.Lock_RTS; | |
504 | end if; | |
505 | ||
cacbc350 RK |
506 | STPO.Write_Lock (Entry_Call.Self); |
507 | Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled); | |
508 | STPO.Unlock (Entry_Call.Self); | |
07fc65c4 GB |
509 | |
510 | if Single_Lock then | |
511 | STPO.Unlock_RTS; | |
512 | end if; | |
cacbc350 RK |
513 | end if; |
514 | ||
3a77b68d GB |
515 | exception |
516 | when others => | |
517 | Send_Program_Error | |
518 | (Self_Id, Entry_Call); | |
cacbc350 RK |
519 | end PO_Do_Or_Queue; |
520 | ||
521 | ---------------------------- | |
522 | -- Protected_Single_Count -- | |
523 | ---------------------------- | |
524 | ||
3a77b68d | 525 | function Protected_Count_Entry (Object : Protection_Entry) return Natural is |
cacbc350 | 526 | begin |
fbf5a39b | 527 | if Object.Entry_Queue /= null then |
cacbc350 RK |
528 | return 1; |
529 | else | |
530 | return 0; | |
531 | end if; | |
532 | end Protected_Count_Entry; | |
533 | ||
534 | --------------------------------- | |
535 | -- Protected_Single_Entry_Call -- | |
536 | --------------------------------- | |
537 | ||
538 | procedure Protected_Single_Entry_Call | |
539 | (Object : Protection_Entry_Access; | |
540 | Uninterpreted_Data : System.Address; | |
541 | Mode : Call_Modes) | |
542 | is | |
72fb810d JR |
543 | Self_Id : constant Task_Id := STPO.Self; |
544 | Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); | |
cacbc350 | 545 | begin |
c885d7a1 AC |
546 | -- If pragma Detect_Blocking is active then Program_Error must be |
547 | -- raised if this potentially blocking operation is called from a | |
548 | -- protected action. | |
549 | ||
550 | if Detect_Blocking | |
551 | and then Self_Id.Common.Protected_Action_Nesting > 0 | |
552 | then | |
366b8af7 | 553 | raise Program_Error with "potentially blocking operation"; |
c885d7a1 AC |
554 | end if; |
555 | ||
72fb810d | 556 | Lock_Entry (Object); |
cacbc350 RK |
557 | |
558 | Entry_Call.Mode := Mode; | |
559 | Entry_Call.State := Now_Abortable; | |
560 | Entry_Call.Uninterpreted_Data := Uninterpreted_Data; | |
561 | Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; | |
562 | ||
563 | PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); | |
564 | Unlock_Entry (Object); | |
565 | ||
566 | -- The call is either `Done' or not. It cannot be cancelled since there | |
567 | -- is no ATC construct. | |
568 | ||
569 | pragma Assert (Entry_Call.State /= Cancelled); | |
570 | ||
3a77b68d | 571 | if Entry_Call.State /= Done then |
07fc65c4 GB |
572 | if Single_Lock then |
573 | STPO.Lock_RTS; | |
574 | end if; | |
575 | ||
3a77b68d | 576 | STPO.Write_Lock (Self_Id); |
07fc65c4 | 577 | Wait_For_Completion (Entry_Call'Access); |
3a77b68d | 578 | STPO.Unlock (Self_Id); |
07fc65c4 GB |
579 | |
580 | if Single_Lock then | |
581 | STPO.Unlock_RTS; | |
582 | end if; | |
cacbc350 RK |
583 | end if; |
584 | ||
cacbc350 RK |
585 | Check_Exception (Self_Id, Entry_Call'Access); |
586 | end Protected_Single_Entry_Call; | |
587 | ||
588 | ----------------------------------- | |
589 | -- Protected_Single_Entry_Caller -- | |
590 | ----------------------------------- | |
591 | ||
592 | function Protected_Single_Entry_Caller | |
b5e792e2 | 593 | (Object : Protection_Entry) return Task_Id is |
cacbc350 RK |
594 | begin |
595 | return Object.Call_In_Progress.Self; | |
596 | end Protected_Single_Entry_Caller; | |
597 | ||
598 | ------------------- | |
599 | -- Service_Entry -- | |
600 | ------------------- | |
601 | ||
602 | procedure Service_Entry (Object : Protection_Entry_Access) is | |
3b37ffbf JR |
603 | Self_Id : constant Task_Id := STPO.Self; |
604 | Entry_Call : constant Entry_Call_Link := Object.Entry_Queue; | |
605 | Caller : Task_Id; | |
cacbc350 RK |
606 | |
607 | begin | |
3b37ffbf JR |
608 | if Entry_Call /= null |
609 | and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1) | |
610 | then | |
611 | Object.Entry_Queue := null; | |
cacbc350 | 612 | |
3b37ffbf | 613 | if Object.Call_In_Progress /= null then |
cacbc350 | 614 | |
3b37ffbf | 615 | -- Violation of No_Entry_Queue restriction, raise exception |
cacbc350 | 616 | |
3b37ffbf | 617 | Send_Program_Error (Self_Id, Entry_Call); |
8a7988f5 | 618 | Unlock_Entry (Object); |
3b37ffbf JR |
619 | return; |
620 | end if; | |
07fc65c4 | 621 | |
3b37ffbf JR |
622 | Object.Call_In_Progress := Entry_Call; |
623 | Object.Entry_Body.Action | |
624 | (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); | |
625 | Object.Call_In_Progress := null; | |
626 | Caller := Entry_Call.Self; | |
627 | Unlock_Entry (Object); | |
07fc65c4 | 628 | |
3b37ffbf JR |
629 | if Single_Lock then |
630 | STPO.Lock_RTS; | |
631 | end if; | |
07fc65c4 | 632 | |
3b37ffbf JR |
633 | STPO.Write_Lock (Caller); |
634 | Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); | |
635 | STPO.Unlock (Caller); | |
636 | ||
637 | if Single_Lock then | |
638 | STPO.Unlock_RTS; | |
cacbc350 | 639 | end if; |
3b37ffbf JR |
640 | |
641 | else | |
642 | -- Just unlock the entry | |
643 | ||
644 | Unlock_Entry (Object); | |
cacbc350 RK |
645 | end if; |
646 | ||
3a77b68d GB |
647 | exception |
648 | when others => | |
649 | Send_Program_Error (Self_Id, Entry_Call); | |
8a7988f5 | 650 | Unlock_Entry (Object); |
cacbc350 RK |
651 | end Service_Entry; |
652 | ||
653 | --------------------------------------- | |
654 | -- Timed_Protected_Single_Entry_Call -- | |
655 | --------------------------------------- | |
656 | ||
67ce0d7e | 657 | -- Compiler interface only (do not call from within the RTS) |
cacbc350 RK |
658 | |
659 | procedure Timed_Protected_Single_Entry_Call | |
660 | (Object : Protection_Entry_Access; | |
661 | Uninterpreted_Data : System.Address; | |
662 | Timeout : Duration; | |
663 | Mode : Delay_Modes; | |
664 | Entry_Call_Successful : out Boolean) | |
665 | is | |
b5e792e2 | 666 | Self_Id : constant Task_Id := STPO.Self; |
cacbc350 RK |
667 | Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); |
668 | Ceiling_Violation : Boolean; | |
669 | ||
670 | begin | |
c885d7a1 AC |
671 | -- If pragma Detect_Blocking is active then Program_Error must be |
672 | -- raised if this potentially blocking operation is called from a | |
673 | -- protected action. | |
674 | ||
675 | if Detect_Blocking | |
676 | and then Self_Id.Common.Protected_Action_Nesting > 0 | |
677 | then | |
366b8af7 | 678 | raise Program_Error with "potentially blocking operation"; |
c885d7a1 AC |
679 | end if; |
680 | ||
cacbc350 RK |
681 | STPO.Write_Lock (Object.L'Access, Ceiling_Violation); |
682 | ||
683 | if Ceiling_Violation then | |
684 | raise Program_Error; | |
685 | end if; | |
686 | ||
687 | Entry_Call.Mode := Timed_Call; | |
688 | Entry_Call.State := Now_Abortable; | |
689 | Entry_Call.Uninterpreted_Data := Uninterpreted_Data; | |
690 | Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; | |
691 | ||
692 | PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); | |
693 | Unlock_Entry (Object); | |
694 | ||
695 | -- Try to avoid waiting for completed calls. | |
696 | -- The call is either `Done' or not. It cannot be cancelled since there | |
697 | -- is no ATC construct and the timed wait has not started yet. | |
698 | ||
699 | pragma Assert (Entry_Call.State /= Cancelled); | |
700 | ||
701 | if Entry_Call.State = Done then | |
702 | Check_Exception (Self_Id, Entry_Call'Access); | |
703 | Entry_Call_Successful := True; | |
704 | return; | |
705 | end if; | |
706 | ||
07fc65c4 GB |
707 | if Single_Lock then |
708 | STPO.Lock_RTS; | |
709 | else | |
710 | STPO.Write_Lock (Self_Id); | |
711 | end if; | |
712 | ||
713 | Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode); | |
714 | ||
715 | if Single_Lock then | |
716 | STPO.Unlock_RTS; | |
717 | else | |
718 | STPO.Unlock (Self_Id); | |
719 | end if; | |
cacbc350 RK |
720 | |
721 | pragma Assert (Entry_Call.State >= Done); | |
722 | ||
723 | Check_Exception (Self_Id, Entry_Call'Access); | |
724 | Entry_Call_Successful := Entry_Call.State = Done; | |
725 | end Timed_Protected_Single_Entry_Call; | |
726 | ||
727 | ------------------ | |
728 | -- Unlock_Entry -- | |
729 | ------------------ | |
730 | ||
731 | procedure Unlock_Entry (Object : Protection_Entry_Access) is | |
732 | begin | |
c885d7a1 | 733 | -- We are exiting from a protected action, so that we decrease the |
ce65449a JR |
734 | -- protected object nesting level (if pragma Detect_Blocking is |
735 | -- active), and remove ownership of the protected object. | |
c885d7a1 AC |
736 | |
737 | if Detect_Blocking then | |
738 | declare | |
739 | Self_Id : constant Task_Id := Self; | |
740 | ||
741 | begin | |
ce65449a JR |
742 | -- Calls to this procedure can only take place when being within |
743 | -- a protected action and when the caller is the protected | |
744 | -- object's owner. | |
745 | ||
746 | pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 | |
747 | and then Object.Owner = Self_Id); | |
748 | ||
749 | -- Remove ownership of the protected object | |
750 | ||
751 | Object.Owner := Null_Task; | |
c885d7a1 | 752 | |
c885d7a1 AC |
753 | Self_Id.Common.Protected_Action_Nesting := |
754 | Self_Id.Common.Protected_Action_Nesting - 1; | |
755 | end; | |
756 | end if; | |
757 | ||
cacbc350 RK |
758 | STPO.Unlock (Object.L'Access); |
759 | end Unlock_Entry; | |
760 | ||
761 | end System.Tasking.Protected_Objects.Single_Entry; |