Daily bump.
[official-gcc.git] / gcc / ada / s-tposen.adb
blob10cfca21016aa75c4a1e2b868eba1795ff872c15
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-2009, 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 -- 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 ------------------------------------------------------------------------------
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
45 -- No Requeue
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,
53 -- Service_Entry).
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.
59 pragma Suppress (All_Checks);
60 -- Why is this required ???
62 with Ada.Exceptions;
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;
71 use Parameters;
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 procedure Send_Program_Error
78 (Self_Id : Task_Id;
79 Entry_Call : Entry_Call_Link);
80 pragma Inline (Send_Program_Error);
81 -- Raise Program_Error in the caller of the specified entry call
83 --------------------------
84 -- Entry Calls Handling --
85 --------------------------
87 procedure Wakeup_Entry_Caller
88 (Self_ID : Task_Id;
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.
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.
101 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
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.
108 procedure Wait_For_Completion_With_Timeout
109 (Entry_Call : Entry_Call_Link;
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.
115 procedure Check_Exception
116 (Self_ID : Task_Id;
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.
124 procedure PO_Do_Or_Queue
125 (Self_Id : Task_Id;
126 Object : Protection_Entry_Access;
127 Entry_Call : Entry_Call_Link);
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.
132 ---------------------
133 -- Check_Exception --
134 ---------------------
136 procedure Check_Exception
137 (Self_ID : Task_Id;
138 Entry_Call : Entry_Call_Link)
140 pragma Warnings (Off, Self_ID);
142 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
143 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
145 use type Ada.Exceptions.Exception_Id;
147 E : constant Ada.Exceptions.Exception_Id :=
148 Entry_Call.Exception_To_Raise;
150 begin
151 if E /= Ada.Exceptions.Null_Id then
152 Internal_Raise (E);
153 end if;
154 end Check_Exception;
156 ------------------------
157 -- Send_Program_Error --
158 ------------------------
160 procedure Send_Program_Error
161 (Self_Id : Task_Id;
162 Entry_Call : Entry_Call_Link)
164 Caller : constant Task_Id := Entry_Call.Self;
165 begin
166 Entry_Call.Exception_To_Raise := Program_Error'Identity;
168 if Single_Lock then
169 STPO.Lock_RTS;
170 end if;
172 STPO.Write_Lock (Caller);
173 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
174 STPO.Unlock (Caller);
176 if Single_Lock then
177 STPO.Unlock_RTS;
178 end if;
179 end Send_Program_Error;
181 -------------------------
182 -- Wait_For_Completion --
183 -------------------------
185 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
186 Self_Id : constant Task_Id := Entry_Call.Self;
187 begin
188 Self_Id.Common.State := Entry_Caller_Sleep;
189 STPO.Sleep (Self_Id, Entry_Caller_Sleep);
190 Self_Id.Common.State := Runnable;
191 end Wait_For_Completion;
193 --------------------------------------
194 -- Wait_For_Completion_With_Timeout --
195 --------------------------------------
197 procedure Wait_For_Completion_With_Timeout
198 (Entry_Call : Entry_Call_Link;
199 Wakeup_Time : Duration;
200 Mode : Delay_Modes)
202 Self_Id : constant Task_Id := Entry_Call.Self;
203 Timedout : Boolean;
205 Yielded : Boolean;
206 pragma Unreferenced (Yielded);
208 use type Ada.Exceptions.Exception_Id;
210 begin
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.
215 -- If we wake up from the timed sleep operation here, it may be for the
216 -- following possible reasons:
218 -- 1) The entry call is done being served.
219 -- 2) The timeout has expired (Timedout = True)
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.
228 pragma Assert (Entry_Call.Mode = Timed_Call);
229 Self_Id.Common.State := Entry_Caller_Sleep;
231 STPO.Timed_Sleep
232 (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded);
234 Entry_Call.State := (if Timedout then Cancelled else Done);
235 Self_Id.Common.State := Runnable;
236 end Wait_For_Completion_With_Timeout;
238 -------------------------
239 -- Wakeup_Entry_Caller --
240 -------------------------
242 -- This is called at the end of service of an entry call, to abort the
243 -- caller if he is in an abortable part, and to wake up the caller if it
244 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue.
246 -- (This enforces the rule that a task must be off-queue if its state is
247 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
249 -- Timed_Call or Simple_Call:
250 -- The caller is waiting on Entry_Caller_Sleep, in
251 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
253 -- Conditional_Call:
254 -- The caller might be in Wait_For_Completion,
255 -- waiting for a rendezvous (possibly requeued without abort)
256 -- to complete.
258 procedure Wakeup_Entry_Caller
259 (Self_ID : Task_Id;
260 Entry_Call : Entry_Call_Link;
261 New_State : Entry_Call_State)
263 pragma Warnings (Off, Self_ID);
265 Caller : constant Task_Id := Entry_Call.Self;
267 begin
268 pragma Assert (New_State = Done or else New_State = Cancelled);
269 pragma Assert
270 (Caller.Common.State /= Terminated and then
271 Caller.Common.State /= Unactivated);
273 Entry_Call.State := New_State;
274 STPO.Wakeup (Caller, Entry_Caller_Sleep);
275 end Wakeup_Entry_Caller;
277 -----------------------
278 -- Restricted GNARLI --
279 -----------------------
281 --------------------------------
282 -- Complete_Single_Entry_Body --
283 --------------------------------
285 procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is
286 pragma Warnings (Off, Object);
288 begin
289 -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise
290 -- has already been set to Null_Id).
292 null;
293 end Complete_Single_Entry_Body;
295 --------------------------------------------
296 -- Exceptional_Complete_Single_Entry_Body --
297 --------------------------------------------
299 procedure Exceptional_Complete_Single_Entry_Body
300 (Object : Protection_Entry_Access;
301 Ex : Ada.Exceptions.Exception_Id) is
302 begin
303 Object.Call_In_Progress.Exception_To_Raise := Ex;
304 end Exceptional_Complete_Single_Entry_Body;
306 ---------------------------------
307 -- Initialize_Protection_Entry --
308 ---------------------------------
310 procedure Initialize_Protection_Entry
311 (Object : Protection_Entry_Access;
312 Ceiling_Priority : Integer;
313 Compiler_Info : System.Address;
314 Entry_Body : Entry_Body_Access)
316 begin
317 Initialize_Protection (Object.Common'Access, Ceiling_Priority);
319 Object.Compiler_Info := Compiler_Info;
320 Object.Call_In_Progress := null;
321 Object.Entry_Body := Entry_Body;
322 Object.Entry_Queue := null;
323 end Initialize_Protection_Entry;
325 ----------------
326 -- Lock_Entry --
327 ----------------
329 -- Compiler interface only.
330 -- Do not call this procedure from within the run-time system.
332 procedure Lock_Entry (Object : Protection_Entry_Access) is
333 begin
334 Lock (Object.Common'Access);
335 end Lock_Entry;
337 --------------------------
338 -- Lock_Read_Only_Entry --
339 --------------------------
341 -- Compiler interface only
343 -- Do not call this procedure from within the runtime system
345 procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
346 begin
347 Lock_Read_Only (Object.Common'Access);
348 end Lock_Read_Only_Entry;
350 --------------------
351 -- PO_Do_Or_Queue --
352 --------------------
354 procedure PO_Do_Or_Queue
355 (Self_Id : Task_Id;
356 Object : Protection_Entry_Access;
357 Entry_Call : Entry_Call_Link)
359 Barrier_Value : Boolean;
361 begin
362 -- When the Action procedure for an entry body returns, it must be
363 -- completed (having called [Exceptional_]Complete_Entry_Body).
365 Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
367 if Barrier_Value then
368 if Object.Call_In_Progress /= null then
370 -- This violates the No_Entry_Queue restriction, send
371 -- Program_Error to the caller.
373 Send_Program_Error (Self_Id, Entry_Call);
374 return;
375 end if;
377 Object.Call_In_Progress := Entry_Call;
378 Object.Entry_Body.Action
379 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
380 Object.Call_In_Progress := null;
382 if Single_Lock then
383 STPO.Lock_RTS;
384 end if;
386 STPO.Write_Lock (Entry_Call.Self);
387 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
388 STPO.Unlock (Entry_Call.Self);
390 if Single_Lock then
391 STPO.Unlock_RTS;
392 end if;
394 elsif Entry_Call.Mode /= Conditional_Call then
395 if Object.Entry_Queue /= null then
397 -- This violates the No_Entry_Queue restriction, send
398 -- Program_Error to the caller.
400 Send_Program_Error (Self_Id, Entry_Call);
401 return;
402 else
403 Object.Entry_Queue := Entry_Call;
404 end if;
406 else
407 -- Conditional_Call
409 if Single_Lock then
410 STPO.Lock_RTS;
411 end if;
413 STPO.Write_Lock (Entry_Call.Self);
414 Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled);
415 STPO.Unlock (Entry_Call.Self);
417 if Single_Lock then
418 STPO.Unlock_RTS;
419 end if;
420 end if;
422 exception
423 when others =>
424 Send_Program_Error
425 (Self_Id, Entry_Call);
426 end PO_Do_Or_Queue;
428 ----------------------------
429 -- Protected_Single_Count --
430 ----------------------------
432 function Protected_Count_Entry (Object : Protection_Entry) return Natural is
433 begin
434 if Object.Entry_Queue /= null then
435 return 1;
436 else
437 return 0;
438 end if;
439 end Protected_Count_Entry;
441 ---------------------------------
442 -- Protected_Single_Entry_Call --
443 ---------------------------------
445 procedure Protected_Single_Entry_Call
446 (Object : Protection_Entry_Access;
447 Uninterpreted_Data : System.Address;
448 Mode : Call_Modes)
450 Self_Id : constant Task_Id := STPO.Self;
451 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
452 begin
453 -- If pragma Detect_Blocking is active then Program_Error must be
454 -- raised if this potentially blocking operation is called from a
455 -- protected action.
457 if Detect_Blocking
458 and then Self_Id.Common.Protected_Action_Nesting > 0
459 then
460 raise Program_Error with "potentially blocking operation";
461 end if;
463 Lock_Entry (Object);
465 Entry_Call.Mode := Mode;
466 Entry_Call.State := Now_Abortable;
467 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
468 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
470 PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
471 Unlock_Entry (Object);
473 -- The call is either `Done' or not. It cannot be cancelled since there
474 -- is no ATC construct.
476 pragma Assert (Entry_Call.State /= Cancelled);
478 if Entry_Call.State /= Done then
479 if Single_Lock then
480 STPO.Lock_RTS;
481 end if;
483 STPO.Write_Lock (Self_Id);
484 Wait_For_Completion (Entry_Call'Access);
485 STPO.Unlock (Self_Id);
487 if Single_Lock then
488 STPO.Unlock_RTS;
489 end if;
490 end if;
492 Check_Exception (Self_Id, Entry_Call'Access);
493 end Protected_Single_Entry_Call;
495 -----------------------------------
496 -- Protected_Single_Entry_Caller --
497 -----------------------------------
499 function Protected_Single_Entry_Caller
500 (Object : Protection_Entry) return Task_Id is
501 begin
502 return Object.Call_In_Progress.Self;
503 end Protected_Single_Entry_Caller;
505 -------------------
506 -- Service_Entry --
507 -------------------
509 procedure Service_Entry (Object : Protection_Entry_Access) is
510 Self_Id : constant Task_Id := STPO.Self;
511 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
512 Caller : Task_Id;
514 begin
515 if Entry_Call /= null
516 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1)
517 then
518 Object.Entry_Queue := null;
520 if Object.Call_In_Progress /= null then
522 -- Violation of No_Entry_Queue restriction, raise exception
524 Send_Program_Error (Self_Id, Entry_Call);
525 Unlock_Entry (Object);
526 return;
527 end if;
529 Object.Call_In_Progress := Entry_Call;
530 Object.Entry_Body.Action
531 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1);
532 Object.Call_In_Progress := null;
533 Caller := Entry_Call.Self;
534 Unlock_Entry (Object);
536 if Single_Lock then
537 STPO.Lock_RTS;
538 end if;
540 STPO.Write_Lock (Caller);
541 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
542 STPO.Unlock (Caller);
544 if Single_Lock then
545 STPO.Unlock_RTS;
546 end if;
548 else
549 -- Just unlock the entry
551 Unlock_Entry (Object);
552 end if;
554 exception
555 when others =>
556 Send_Program_Error (Self_Id, Entry_Call);
557 Unlock_Entry (Object);
558 end Service_Entry;
560 ---------------------------------------
561 -- Timed_Protected_Single_Entry_Call --
562 ---------------------------------------
564 -- Compiler interface only (do not call from within the RTS)
566 procedure Timed_Protected_Single_Entry_Call
567 (Object : Protection_Entry_Access;
568 Uninterpreted_Data : System.Address;
569 Timeout : Duration;
570 Mode : Delay_Modes;
571 Entry_Call_Successful : out Boolean)
573 Self_Id : constant Task_Id := STPO.Self;
574 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
576 begin
577 -- If pragma Detect_Blocking is active then Program_Error must be
578 -- raised if this potentially blocking operation is called from a
579 -- protected action.
581 if Detect_Blocking
582 and then Self_Id.Common.Protected_Action_Nesting > 0
583 then
584 raise Program_Error with "potentially blocking operation";
585 end if;
587 Lock (Object.Common'Access);
589 Entry_Call.Mode := Timed_Call;
590 Entry_Call.State := Now_Abortable;
591 Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
592 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
594 PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
595 Unlock_Entry (Object);
597 -- Try to avoid waiting for completed calls.
598 -- The call is either `Done' or not. It cannot be cancelled since there
599 -- is no ATC construct and the timed wait has not started yet.
601 pragma Assert (Entry_Call.State /= Cancelled);
603 if Entry_Call.State = Done then
604 Check_Exception (Self_Id, Entry_Call'Access);
605 Entry_Call_Successful := True;
606 return;
607 end if;
609 if Single_Lock then
610 STPO.Lock_RTS;
611 else
612 STPO.Write_Lock (Self_Id);
613 end if;
615 Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode);
617 if Single_Lock then
618 STPO.Unlock_RTS;
619 else
620 STPO.Unlock (Self_Id);
621 end if;
623 pragma Assert (Entry_Call.State >= Done);
625 Check_Exception (Self_Id, Entry_Call'Access);
626 Entry_Call_Successful := Entry_Call.State = Done;
627 end Timed_Protected_Single_Entry_Call;
629 ------------------
630 -- Unlock_Entry --
631 ------------------
633 procedure Unlock_Entry (Object : Protection_Entry_Access) is
634 begin
635 Unlock (Object.Common'Access);
636 end Unlock_Entry;
638 end System.Tasking.Protected_Objects.Single_Entry;