File : s-taenca.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2011, 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 with System.Task_Primitives.Operations;
33 with System.Tasking.Initialization;
34 with System.Tasking.Protected_Objects.Entries;
35 with System.Tasking.Protected_Objects.Operations;
36 with System.Tasking.Queuing;
37 with System.Tasking.Utilities;
38 with System.Parameters;
39 with System.Traces;
40
41 package body System.Tasking.Entry_Calls is
42
43 package STPO renames System.Task_Primitives.Operations;
44
45 use Parameters;
46 use Task_Primitives;
47 use Protected_Objects.Entries;
48 use Protected_Objects.Operations;
49 use System.Traces;
50
51 -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock
52 -- internally. Those operations will raise Program_Error, which
53 -- we are not prepared to handle inside the RTS. Instead, use
54 -- System.Task_Primitives lock operations directly on Protection.L.
55
56 -----------------------
57 -- Local Subprograms --
58 -----------------------
59
60 procedure Lock_Server (Entry_Call : Entry_Call_Link);
61
62 -- This locks the server targeted by Entry_Call
63 --
64 -- This may be a task or a protected object, depending on the target of the
65 -- original call or any subsequent requeues.
66 --
67 -- This routine is needed because the field specifying the server for this
68 -- call must be protected by the server's mutex. If it were protected by
69 -- the caller's mutex, accessing the server's queues would require locking
70 -- the caller to get the server, locking the server, and then accessing the
71 -- queues. This involves holding two ATCB locks at once, something which we
72 -- can guarantee that it will always be done in the same order, or locking
73 -- a protected object while we hold an ATCB lock, something which is not
74 -- permitted. Since the server cannot be obtained reliably, it must be
75 -- obtained unreliably and then checked again once it has been locked.
76 --
77 -- If Single_Lock and server is a PO, release RTS_Lock
78 --
79 -- This should only be called by the Entry_Call.Self.
80 -- It should be holding no other ATCB locks at the time.
81
82 procedure Unlock_Server (Entry_Call : Entry_Call_Link);
83 -- STPO.Unlock the server targeted by Entry_Call. The server must
84 -- be locked before calling this.
85 --
86 -- If Single_Lock and server is a PO, take RTS_Lock on exit.
87
88 procedure Unlock_And_Update_Server
89 (Self_ID : Task_Id;
90 Entry_Call : Entry_Call_Link);
91 -- Similar to Unlock_Server, but services entry calls if the
92 -- server is a protected object.
93 --
94 -- If Single_Lock and server is a PO, take RTS_Lock on exit.
95
96 procedure Check_Pending_Actions_For_Entry_Call
97 (Self_ID : Task_Id;
98 Entry_Call : Entry_Call_Link);
99 -- This procedure performs priority change of a queued call and dequeuing
100 -- of an entry call when the call is cancelled. If the call is dequeued the
101 -- state should be set to Cancelled. Call only with abort deferred and
102 -- holding lock of Self_ID. This is a bit of common code for all entry
103 -- calls. The effect is to do any deferred base priority change operation,
104 -- in case some other task called STPO.Set_Priority while the current task
105 -- had abort deferred, and to dequeue the call if the call has been
106 -- aborted.
107
108 procedure Poll_Base_Priority_Change_At_Entry_Call
109 (Self_ID : Task_Id;
110 Entry_Call : Entry_Call_Link);
111 pragma Inline (Poll_Base_Priority_Change_At_Entry_Call);
112 -- A specialized version of Poll_Base_Priority_Change, that does the
113 -- optional entry queue reordering. Has to be called with the Self_ID's
114 -- ATCB write-locked. May temporarily release the lock.
115
116 ---------------------
117 -- Check_Exception --
118 ---------------------
119
120 procedure Check_Exception
121 (Self_ID : Task_Id;
122 Entry_Call : Entry_Call_Link)
123 is
124 pragma Warnings (Off, Self_ID);
125
126 use type Ada.Exceptions.Exception_Id;
127
128 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
129 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
130
131 E : constant Ada.Exceptions.Exception_Id :=
132 Entry_Call.Exception_To_Raise;
133 begin
134 -- pragma Assert (Self_ID.Deferral_Level = 0);
135
136 -- The above may be useful for debugging, but the Florist packages
137 -- contain critical sections that defer abort and then do entry calls,
138 -- which causes the above Assert to trip.
139
140 if E /= Ada.Exceptions.Null_Id then
141 Internal_Raise (E);
142 end if;
143 end Check_Exception;
144
145 ------------------------------------------
146 -- Check_Pending_Actions_For_Entry_Call --
147 ------------------------------------------
148
149 procedure Check_Pending_Actions_For_Entry_Call
150 (Self_ID : Task_Id;
151 Entry_Call : Entry_Call_Link)
152 is
153 begin
154 pragma Assert (Self_ID = Entry_Call.Self);
155
156 Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call);
157
158 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
159 and then Entry_Call.State = Now_Abortable
160 then
161 STPO.Unlock (Self_ID);
162 Lock_Server (Entry_Call);
163
164 if Queuing.Onqueue (Entry_Call)
165 and then Entry_Call.State = Now_Abortable
166 then
167 Queuing.Dequeue_Call (Entry_Call);
168 Entry_Call.State :=
169 (if Entry_Call.Cancellation_Attempted then Cancelled else Done);
170 Unlock_And_Update_Server (Self_ID, Entry_Call);
171
172 else
173 Unlock_Server (Entry_Call);
174 end if;
175
176 STPO.Write_Lock (Self_ID);
177 end if;
178 end Check_Pending_Actions_For_Entry_Call;
179
180 -----------------
181 -- Lock_Server --
182 -----------------
183
184 procedure Lock_Server (Entry_Call : Entry_Call_Link) is
185 Test_Task : Task_Id;
186 Test_PO : Protection_Entries_Access;
187 Ceiling_Violation : Boolean;
188 Failures : Integer := 0;
189
190 begin
191 Test_Task := Entry_Call.Called_Task;
192
193 loop
194 if Test_Task = null then
195
196 -- Entry_Call was queued on a protected object, or in transition,
197 -- when we last fetched Test_Task.
198
199 Test_PO := To_Protection (Entry_Call.Called_PO);
200
201 if Test_PO = null then
202
203 -- We had very bad luck, interleaving with TWO different
204 -- requeue operations. Go around the loop and try again.
205
206 if Single_Lock then
207 STPO.Unlock_RTS;
208 STPO.Yield;
209 STPO.Lock_RTS;
210 else
211 STPO.Yield;
212 end if;
213
214 else
215 if Single_Lock then
216 STPO.Unlock_RTS;
217 end if;
218
219 Lock_Entries_With_Status (Test_PO, Ceiling_Violation);
220
221 -- ???
222
223 -- The following code allows Lock_Server to be called when
224 -- cancelling a call, to allow for the possibility that the
225 -- priority of the caller has been raised beyond that of the
226 -- protected entry call by Ada.Dynamic_Priorities.Set_Priority.
227
228 -- If the current task has a higher priority than the ceiling
229 -- of the protected object, temporarily lower it. It will
230 -- be reset in Unlock.
231
232 if Ceiling_Violation then
233 declare
234 Current_Task : constant Task_Id := STPO.Self;
235 Old_Base_Priority : System.Any_Priority;
236
237 begin
238 if Single_Lock then
239 STPO.Lock_RTS;
240 end if;
241
242 STPO.Write_Lock (Current_Task);
243 Old_Base_Priority := Current_Task.Common.Base_Priority;
244 Current_Task.New_Base_Priority := Test_PO.Ceiling;
245 System.Tasking.Initialization.Change_Base_Priority
246 (Current_Task);
247 STPO.Unlock (Current_Task);
248
249 if Single_Lock then
250 STPO.Unlock_RTS;
251 end if;
252
253 -- Following lock should not fail
254
255 Lock_Entries (Test_PO);
256
257 Test_PO.Old_Base_Priority := Old_Base_Priority;
258 Test_PO.Pending_Action := True;
259 end;
260 end if;
261
262 exit when To_Address (Test_PO) = Entry_Call.Called_PO;
263 Unlock_Entries (Test_PO);
264
265 if Single_Lock then
266 STPO.Lock_RTS;
267 end if;
268 end if;
269
270 else
271 STPO.Write_Lock (Test_Task);
272 exit when Test_Task = Entry_Call.Called_Task;
273 STPO.Unlock (Test_Task);
274 end if;
275
276 Test_Task := Entry_Call.Called_Task;
277 Failures := Failures + 1;
278 pragma Assert (Failures <= 5);
279 end loop;
280 end Lock_Server;
281
282 ---------------------------------------------
283 -- Poll_Base_Priority_Change_At_Entry_Call --
284 ---------------------------------------------
285
286 procedure Poll_Base_Priority_Change_At_Entry_Call
287 (Self_ID : Task_Id;
288 Entry_Call : Entry_Call_Link)
289 is
290 begin
291 if Self_ID.Pending_Priority_Change then
292
293 -- Check for ceiling violations ???
294
295 Self_ID.Pending_Priority_Change := False;
296
297 -- Requeue the entry call at the new priority. We need to requeue
298 -- even if the new priority is the same than the previous (see ACATS
299 -- test cxd4006).
300
301 STPO.Unlock (Self_ID);
302 Lock_Server (Entry_Call);
303 Queuing.Requeue_Call_With_New_Prio
304 (Entry_Call, STPO.Get_Priority (Self_ID));
305 Unlock_And_Update_Server (Self_ID, Entry_Call);
306 STPO.Write_Lock (Self_ID);
307 end if;
308 end Poll_Base_Priority_Change_At_Entry_Call;
309
310 --------------------
311 -- Reset_Priority --
312 --------------------
313
314 procedure Reset_Priority
315 (Acceptor : Task_Id;
316 Acceptor_Prev_Priority : Rendezvous_Priority)
317 is
318 begin
319 pragma Assert (Acceptor = STPO.Self);
320
321 -- Since we limit this kind of "active" priority change to be done
322 -- by the task for itself, we don't need to lock Acceptor.
323
324 if Acceptor_Prev_Priority /= Priority_Not_Boosted then
325 STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority,
326 Loss_Of_Inheritance => True);
327 end if;
328 end Reset_Priority;
329
330 ------------------------------
331 -- Try_To_Cancel_Entry_Call --
332 ------------------------------
333
334 procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is
335 Entry_Call : Entry_Call_Link;
336 Self_ID : constant Task_Id := STPO.Self;
337
338 use type Ada.Exceptions.Exception_Id;
339
340 begin
341 Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;
342
343 -- Experimentation has shown that abort is sometimes (but not
344 -- always) already deferred when Cancel_xxx_Entry_Call is called.
345 -- That may indicate an error. Find out what is going on. ???
346
347 pragma Assert (Entry_Call.Mode = Asynchronous_Call);
348 Initialization.Defer_Abort_Nestable (Self_ID);
349
350 if Single_Lock then
351 STPO.Lock_RTS;
352 end if;
353
354 STPO.Write_Lock (Self_ID);
355 Entry_Call.Cancellation_Attempted := True;
356
357 if Self_ID.Pending_ATC_Level >= Entry_Call.Level then
358 Self_ID.Pending_ATC_Level := Entry_Call.Level - 1;
359 end if;
360
361 Entry_Calls.Wait_For_Completion (Entry_Call);
362 STPO.Unlock (Self_ID);
363
364 if Single_Lock then
365 STPO.Unlock_RTS;
366 end if;
367
368 Succeeded := Entry_Call.State = Cancelled;
369
370 Initialization.Undefer_Abort_Nestable (Self_ID);
371
372 -- Ideally, abort should no longer be deferred at this point, so we
373 -- should be able to call Check_Exception. The loop below should be
374 -- considered temporary, to work around the possibility that abort
375 -- may be deferred more than one level deep ???
376
377 if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then
378 while Self_ID.Deferral_Level > 0 loop
379 System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID);
380 end loop;
381
382 Entry_Calls.Check_Exception (Self_ID, Entry_Call);
383 end if;
384 end Try_To_Cancel_Entry_Call;
385
386 ------------------------------
387 -- Unlock_And_Update_Server --
388 ------------------------------
389
390 procedure Unlock_And_Update_Server
391 (Self_ID : Task_Id;
392 Entry_Call : Entry_Call_Link)
393 is
394 Called_PO : Protection_Entries_Access;
395 Caller : Task_Id;
396
397 begin
398 if Entry_Call.Called_Task /= null then
399 STPO.Unlock (Entry_Call.Called_Task);
400 else
401 Called_PO := To_Protection (Entry_Call.Called_PO);
402 PO_Service_Entries (Self_ID, Called_PO, False);
403
404 if Called_PO.Pending_Action then
405 Called_PO.Pending_Action := False;
406 Caller := STPO.Self;
407
408 if Single_Lock then
409 STPO.Lock_RTS;
410 end if;
411
412 STPO.Write_Lock (Caller);
413 Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
414 Initialization.Change_Base_Priority (Caller);
415 STPO.Unlock (Caller);
416
417 if Single_Lock then
418 STPO.Unlock_RTS;
419 end if;
420 end if;
421
422 Unlock_Entries (Called_PO);
423
424 if Single_Lock then
425 STPO.Lock_RTS;
426 end if;
427 end if;
428 end Unlock_And_Update_Server;
429
430 -------------------
431 -- Unlock_Server --
432 -------------------
433
434 procedure Unlock_Server (Entry_Call : Entry_Call_Link) is
435 Caller : Task_Id;
436 Called_PO : Protection_Entries_Access;
437
438 begin
439 if Entry_Call.Called_Task /= null then
440 STPO.Unlock (Entry_Call.Called_Task);
441 else
442 Called_PO := To_Protection (Entry_Call.Called_PO);
443
444 if Called_PO.Pending_Action then
445 Called_PO.Pending_Action := False;
446 Caller := STPO.Self;
447
448 if Single_Lock then
449 STPO.Lock_RTS;
450 end if;
451
452 STPO.Write_Lock (Caller);
453 Caller.New_Base_Priority := Called_PO.Old_Base_Priority;
454 Initialization.Change_Base_Priority (Caller);
455 STPO.Unlock (Caller);
456
457 if Single_Lock then
458 STPO.Unlock_RTS;
459 end if;
460 end if;
461
462 Unlock_Entries (Called_PO);
463
464 if Single_Lock then
465 STPO.Lock_RTS;
466 end if;
467 end if;
468 end Unlock_Server;
469
470 -------------------------
471 -- Wait_For_Completion --
472 -------------------------
473
474 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
475 Self_Id : constant Task_Id := Entry_Call.Self;
476
477 begin
478 -- If this is a conditional call, it should be cancelled when it
479 -- becomes abortable. This is checked in the loop below.
480
481 if Parameters.Runtime_Traces then
482 Send_Trace_Info (W_Completion);
483 end if;
484
485 Self_Id.Common.State := Entry_Caller_Sleep;
486
487 -- Try to remove calls to Sleep in the loop below by letting the caller
488 -- a chance of getting ready immediately, using Unlock & Yield.
489 -- See similar action in Wait_For_Call & Timed_Selective_Wait.
490
491 if Single_Lock then
492 STPO.Unlock_RTS;
493 else
494 STPO.Unlock (Self_Id);
495 end if;
496
497 if Entry_Call.State < Done then
498 STPO.Yield;
499 end if;
500
501 if Single_Lock then
502 STPO.Lock_RTS;
503 else
504 STPO.Write_Lock (Self_Id);
505 end if;
506
507 loop
508 Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
509
510 exit when Entry_Call.State >= Done;
511
512 STPO.Sleep (Self_Id, Entry_Caller_Sleep);
513 end loop;
514
515 Self_Id.Common.State := Runnable;
516 Utilities.Exit_One_ATC_Level (Self_Id);
517
518 if Parameters.Runtime_Traces then
519 Send_Trace_Info (M_Call_Complete);
520 end if;
521 end Wait_For_Completion;
522
523 --------------------------------------
524 -- Wait_For_Completion_With_Timeout --
525 --------------------------------------
526
527 procedure Wait_For_Completion_With_Timeout
528 (Entry_Call : Entry_Call_Link;
529 Wakeup_Time : Duration;
530 Mode : Delay_Modes;
531 Yielded : out Boolean)
532 is
533 Self_Id : constant Task_Id := Entry_Call.Self;
534 Timedout : Boolean := False;
535
536 use type Ada.Exceptions.Exception_Id;
537
538 begin
539 -- This procedure waits for the entry call to be served, with a timeout.
540 -- It tries to cancel the call if the timeout expires before the call is
541 -- served.
542
543 -- If we wake up from the timed sleep operation here, it may be for
544 -- several possible reasons:
545
546 -- 1) The entry call is done being served.
547 -- 2) There is an abort or priority change to be served.
548 -- 3) The timeout has expired (Timedout = True)
549 -- 4) There has been a spurious wakeup.
550
551 -- Once the timeout has expired we may need to continue to wait if the
552 -- call is already being serviced. In that case, we want to go back to
553 -- sleep, but without any timeout. The variable Timedout is used to
554 -- control this. If the Timedout flag is set, we do not need to
555 -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for
556 -- some status change.
557
558 -- The original call may have become abortable after waking up. We want
559 -- to check Check_Pending_Actions_For_Entry_Call again in any case.
560
561 pragma Assert (Entry_Call.Mode = Timed_Call);
562
563 Yielded := False;
564 Self_Id.Common.State := Entry_Caller_Sleep;
565
566 -- Looping is necessary in case the task wakes up early from the timed
567 -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of
568 -- POSIX condition variables. A thread waiting for a condition variable
569 -- is allowed to wake up at any time, not just when the condition is
570 -- signaled. See same loop in the ordinary Wait_For_Completion, above.
571
572 if Parameters.Runtime_Traces then
573 Send_Trace_Info (WT_Completion, Wakeup_Time);
574 end if;
575
576 loop
577 Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
578 exit when Entry_Call.State >= Done;
579
580 STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode,
581 Entry_Caller_Sleep, Timedout, Yielded);
582
583 if Timedout then
584 if Parameters.Runtime_Traces then
585 Send_Trace_Info (E_Timeout);
586 end if;
587
588 -- Try to cancel the call (see Try_To_Cancel_Entry_Call for
589 -- corresponding code in the ATC case).
590
591 Entry_Call.Cancellation_Attempted := True;
592
593 -- Reset Entry_Call.State so that the call is marked as cancelled
594 -- by Check_Pending_Actions_For_Entry_Call below.
595
596 if Entry_Call.State < Was_Abortable then
597 Entry_Call.State := Now_Abortable;
598 end if;
599
600 if Self_Id.Pending_ATC_Level >= Entry_Call.Level then
601 Self_Id.Pending_ATC_Level := Entry_Call.Level - 1;
602 end if;
603
604 -- The following loop is the same as the loop and exit code
605 -- from the ordinary Wait_For_Completion. If we get here, we
606 -- have timed out but we need to keep waiting until the call
607 -- has actually completed or been cancelled successfully.
608
609 loop
610 Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
611 exit when Entry_Call.State >= Done;
612 STPO.Sleep (Self_Id, Entry_Caller_Sleep);
613 end loop;
614
615 Self_Id.Common.State := Runnable;
616 Utilities.Exit_One_ATC_Level (Self_Id);
617
618 return;
619 end if;
620 end loop;
621
622 -- This last part is the same as ordinary Wait_For_Completion,
623 -- and is only executed if the call completed without timing out.
624
625 if Parameters.Runtime_Traces then
626 Send_Trace_Info (M_Call_Complete);
627 end if;
628
629 Self_Id.Common.State := Runnable;
630 Utilities.Exit_One_ATC_Level (Self_Id);
631 end Wait_For_Completion_With_Timeout;
632
633 --------------------------
634 -- Wait_Until_Abortable --
635 --------------------------
636
637 procedure Wait_Until_Abortable
638 (Self_ID : Task_Id;
639 Call : Entry_Call_Link)
640 is
641 begin
642 pragma Assert (Self_ID.ATC_Nesting_Level > 0);
643 pragma Assert (Call.Mode = Asynchronous_Call);
644
645 if Parameters.Runtime_Traces then
646 Send_Trace_Info (W_Completion);
647 end if;
648
649 STPO.Write_Lock (Self_ID);
650 Self_ID.Common.State := Entry_Caller_Sleep;
651
652 loop
653 Check_Pending_Actions_For_Entry_Call (Self_ID, Call);
654 exit when Call.State >= Was_Abortable;
655 STPO.Sleep (Self_ID, Async_Select_Sleep);
656 end loop;
657
658 Self_ID.Common.State := Runnable;
659 STPO.Unlock (Self_ID);
660
661 if Parameters.Runtime_Traces then
662 Send_Trace_Info (M_Call_Complete);
663 end if;
664 end Wait_Until_Abortable;
665
666 end System.Tasking.Entry_Calls;