1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S --
9 -- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
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 2, or (at your option) any later ver- --
14 -- sion. GNARL 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 with System
.Task_Primitives
.Operations
;
35 with System
.Tasking
.Initialization
;
36 with System
.Tasking
.Protected_Objects
.Entries
;
37 with System
.Tasking
.Protected_Objects
.Operations
;
38 with System
.Tasking
.Queuing
;
39 with System
.Tasking
.Utilities
;
40 with System
.Parameters
;
43 package body System
.Tasking
.Entry_Calls
is
45 package STPO
renames System
.Task_Primitives
.Operations
;
49 use Protected_Objects
.Entries
;
50 use Protected_Objects
.Operations
;
53 -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock
54 -- internally. Those operations will raise Program_Error, which
55 -- we are not prepared to handle inside the RTS. Instead, use
56 -- System.Task_Primitives lock operations directly on Protection.L.
58 -----------------------
59 -- Local Subprograms --
60 -----------------------
62 procedure Lock_Server
(Entry_Call
: Entry_Call_Link
);
64 -- This locks the server targeted by Entry_Call
66 -- This may be a task or a protected object, depending on the target of the
67 -- original call or any subsequent requeues.
69 -- This routine is needed because the field specifying the server for this
70 -- call must be protected by the server's mutex. If it were protected by
71 -- the caller's mutex, accessing the server's queues would require locking
72 -- the caller to get the server, locking the server, and then accessing the
73 -- queues. This involves holding two ATCB locks at once, something which we
74 -- can guarantee that it will always be done in the same order, or locking
75 -- a protected object while we hold an ATCB lock, something which is not
76 -- permitted. Since the server cannot be obtained reliably, it must be
77 -- obtained unreliably and then checked again once it has been locked.
79 -- If Single_Lock and server is a PO, release RTS_Lock
81 -- This should only be called by the Entry_Call.Self.
82 -- It should be holding no other ATCB locks at the time.
84 procedure Unlock_Server
(Entry_Call
: Entry_Call_Link
);
85 -- STPO.Unlock the server targeted by Entry_Call. The server must
86 -- be locked before calling this.
88 -- If Single_Lock and server is a PO, take RTS_Lock on exit.
90 procedure Unlock_And_Update_Server
92 Entry_Call
: Entry_Call_Link
);
93 -- Similar to Unlock_Server, but services entry calls if the
94 -- server is a protected object.
96 -- If Single_Lock and server is a PO, take RTS_Lock on exit.
98 procedure Check_Pending_Actions_For_Entry_Call
100 Entry_Call
: Entry_Call_Link
);
101 -- This procedure performs priority change of a queued call and dequeuing
102 -- of an entry call when the call is cancelled. If the call is dequeued the
103 -- state should be set to Cancelled. Call only with abort deferred and
104 -- holding lock of Self_ID. This is a bit of common code for all entry
105 -- calls. The effect is to do any deferred base priority change operation,
106 -- in case some other task called STPO.Set_Priority while the current task
107 -- had abort deferred, and to dequeue the call if the call has been
110 procedure Poll_Base_Priority_Change_At_Entry_Call
112 Entry_Call
: Entry_Call_Link
);
113 pragma Inline
(Poll_Base_Priority_Change_At_Entry_Call
);
114 -- A specialized version of Poll_Base_Priority_Change, that does the
115 -- optional entry queue reordering. Has to be called with the Self_ID's
116 -- ATCB write-locked. May temporarily release the lock.
118 ---------------------
119 -- Check_Exception --
120 ---------------------
122 procedure Check_Exception
124 Entry_Call
: Entry_Call_Link
)
126 pragma Warnings
(Off
, Self_ID
);
128 use type Ada
.Exceptions
.Exception_Id
;
130 procedure Internal_Raise
(X
: Ada
.Exceptions
.Exception_Id
);
131 pragma Import
(C
, Internal_Raise
, "__gnat_raise_with_msg");
133 E
: constant Ada
.Exceptions
.Exception_Id
:=
134 Entry_Call
.Exception_To_Raise
;
136 -- pragma Assert (Self_ID.Deferral_Level = 0);
138 -- The above may be useful for debugging, but the Florist packages
139 -- contain critical sections that defer abort and then do entry calls,
140 -- which causes the above Assert to trip.
142 if E
/= Ada
.Exceptions
.Null_Id
then
147 ------------------------------------------
148 -- Check_Pending_Actions_For_Entry_Call --
149 ------------------------------------------
151 procedure Check_Pending_Actions_For_Entry_Call
153 Entry_Call
: Entry_Call_Link
)
156 pragma Assert
(Self_ID
= Entry_Call
.Self
);
158 Poll_Base_Priority_Change_At_Entry_Call
(Self_ID
, Entry_Call
);
160 if Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
161 and then Entry_Call
.State
= Now_Abortable
163 STPO
.Unlock
(Self_ID
);
164 Lock_Server
(Entry_Call
);
166 if Queuing
.Onqueue
(Entry_Call
)
167 and then Entry_Call
.State
= Now_Abortable
169 Queuing
.Dequeue_Call
(Entry_Call
);
171 if Entry_Call
.Cancellation_Attempted
then
172 Entry_Call
.State
:= Cancelled
;
174 Entry_Call
.State
:= Done
;
177 Unlock_And_Update_Server
(Self_ID
, Entry_Call
);
180 Unlock_Server
(Entry_Call
);
183 STPO
.Write_Lock
(Self_ID
);
185 end Check_Pending_Actions_For_Entry_Call
;
191 procedure Lock_Server
(Entry_Call
: Entry_Call_Link
) is
193 Test_PO
: Protection_Entries_Access
;
194 Ceiling_Violation
: Boolean;
195 Failures
: Integer := 0;
198 Test_Task
:= Entry_Call
.Called_Task
;
201 if Test_Task
= null then
203 -- Entry_Call was queued on a protected object, or in transition,
204 -- when we last fetched Test_Task.
206 Test_PO
:= To_Protection
(Entry_Call
.Called_PO
);
208 if Test_PO
= null then
210 -- We had very bad luck, interleaving with TWO different
211 -- requeue operations. Go around the loop and try again.
226 Lock_Entries
(Test_PO
, Ceiling_Violation
);
230 -- The following code allows Lock_Server to be called when
231 -- cancelling a call, to allow for the possibility that the
232 -- priority of the caller has been raised beyond that of the
233 -- protected entry call by Ada.Dynamic_Priorities.Set_Priority.
235 -- If the current task has a higher priority than the ceiling
236 -- of the protected object, temporarily lower it. It will
237 -- be reset in Unlock.
239 if Ceiling_Violation
then
241 Current_Task
: constant Task_Id
:= STPO
.Self
;
242 Old_Base_Priority
: System
.Any_Priority
;
249 STPO
.Write_Lock
(Current_Task
);
250 Old_Base_Priority
:= Current_Task
.Common
.Base_Priority
;
251 Current_Task
.New_Base_Priority
:= Test_PO
.Ceiling
;
252 System
.Tasking
.Initialization
.Change_Base_Priority
254 STPO
.Unlock
(Current_Task
);
260 -- Following lock should not fail
262 Lock_Entries
(Test_PO
);
264 Test_PO
.Old_Base_Priority
:= Old_Base_Priority
;
265 Test_PO
.Pending_Action
:= True;
269 exit when To_Address
(Test_PO
) = Entry_Call
.Called_PO
;
270 Unlock_Entries
(Test_PO
);
278 STPO
.Write_Lock
(Test_Task
);
279 exit when Test_Task
= Entry_Call
.Called_Task
;
280 STPO
.Unlock
(Test_Task
);
283 Test_Task
:= Entry_Call
.Called_Task
;
284 Failures
:= Failures
+ 1;
285 pragma Assert
(Failures
<= 5);
289 ---------------------------------------------
290 -- Poll_Base_Priority_Change_At_Entry_Call --
291 ---------------------------------------------
293 procedure Poll_Base_Priority_Change_At_Entry_Call
295 Entry_Call
: Entry_Call_Link
)
298 if Self_ID
.Pending_Priority_Change
then
300 -- Check for ceiling violations ???
302 Self_ID
.Pending_Priority_Change
:= False;
304 -- Requeue the entry call at the new priority. We need to requeue
305 -- even if the new priority is the same than the previous (see ACATS
308 STPO
.Unlock
(Self_ID
);
309 Lock_Server
(Entry_Call
);
310 Queuing
.Requeue_Call_With_New_Prio
311 (Entry_Call
, STPO
.Get_Priority
(Self_ID
));
312 Unlock_And_Update_Server
(Self_ID
, Entry_Call
);
313 STPO
.Write_Lock
(Self_ID
);
315 end Poll_Base_Priority_Change_At_Entry_Call
;
321 procedure Reset_Priority
323 Acceptor_Prev_Priority
: Rendezvous_Priority
)
326 pragma Assert
(Acceptor
= STPO
.Self
);
328 -- Since we limit this kind of "active" priority change to be done
329 -- by the task for itself, we don't need to lock Acceptor.
331 if Acceptor_Prev_Priority
/= Priority_Not_Boosted
then
332 STPO
.Set_Priority
(Acceptor
, Acceptor_Prev_Priority
,
333 Loss_Of_Inheritance
=> True);
337 ------------------------------
338 -- Try_To_Cancel_Entry_Call --
339 ------------------------------
341 procedure Try_To_Cancel_Entry_Call
(Succeeded
: out Boolean) is
342 Entry_Call
: Entry_Call_Link
;
343 Self_ID
: constant Task_Id
:= STPO
.Self
;
345 use type Ada
.Exceptions
.Exception_Id
;
348 Entry_Call
:= Self_ID
.Entry_Calls
(Self_ID
.ATC_Nesting_Level
)'Access;
350 -- Experimentation has shown that abort is sometimes (but not
351 -- always) already deferred when Cancel_xxx_Entry_Call is called.
352 -- That may indicate an error. Find out what is going on. ???
354 pragma Assert
(Entry_Call
.Mode
= Asynchronous_Call
);
355 Initialization
.Defer_Abort_Nestable
(Self_ID
);
361 STPO
.Write_Lock
(Self_ID
);
362 Entry_Call
.Cancellation_Attempted
:= True;
364 if Self_ID
.Pending_ATC_Level
>= Entry_Call
.Level
then
365 Self_ID
.Pending_ATC_Level
:= Entry_Call
.Level
- 1;
368 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
369 STPO
.Unlock
(Self_ID
);
375 Succeeded
:= Entry_Call
.State
= Cancelled
;
377 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
379 -- Ideally, abort should no longer be deferred at this point, so we
380 -- should be able to call Check_Exception. The loop below should be
381 -- considered temporary, to work around the possibility that abort
382 -- may be deferred more than one level deep ???
384 if Entry_Call
.Exception_To_Raise
/= Ada
.Exceptions
.Null_Id
then
385 while Self_ID
.Deferral_Level
> 0 loop
386 System
.Tasking
.Initialization
.Undefer_Abort_Nestable
(Self_ID
);
389 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
391 end Try_To_Cancel_Entry_Call
;
393 ------------------------------
394 -- Unlock_And_Update_Server --
395 ------------------------------
397 procedure Unlock_And_Update_Server
399 Entry_Call
: Entry_Call_Link
)
401 Called_PO
: Protection_Entries_Access
;
405 if Entry_Call
.Called_Task
/= null then
406 STPO
.Unlock
(Entry_Call
.Called_Task
);
408 Called_PO
:= To_Protection
(Entry_Call
.Called_PO
);
409 PO_Service_Entries
(Self_ID
, Called_PO
, False);
411 if Called_PO
.Pending_Action
then
412 Called_PO
.Pending_Action
:= False;
419 STPO
.Write_Lock
(Caller
);
420 Caller
.New_Base_Priority
:= Called_PO
.Old_Base_Priority
;
421 Initialization
.Change_Base_Priority
(Caller
);
422 STPO
.Unlock
(Caller
);
429 Unlock_Entries
(Called_PO
);
435 end Unlock_And_Update_Server
;
441 procedure Unlock_Server
(Entry_Call
: Entry_Call_Link
) is
443 Called_PO
: Protection_Entries_Access
;
446 if Entry_Call
.Called_Task
/= null then
447 STPO
.Unlock
(Entry_Call
.Called_Task
);
449 Called_PO
:= To_Protection
(Entry_Call
.Called_PO
);
451 if Called_PO
.Pending_Action
then
452 Called_PO
.Pending_Action
:= False;
459 STPO
.Write_Lock
(Caller
);
460 Caller
.New_Base_Priority
:= Called_PO
.Old_Base_Priority
;
461 Initialization
.Change_Base_Priority
(Caller
);
462 STPO
.Unlock
(Caller
);
469 Unlock_Entries
(Called_PO
);
477 -------------------------
478 -- Wait_For_Completion --
479 -------------------------
481 procedure Wait_For_Completion
(Entry_Call
: Entry_Call_Link
) is
482 Self_Id
: constant Task_Id
:= Entry_Call
.Self
;
485 -- If this is a conditional call, it should be cancelled when it
486 -- becomes abortable. This is checked in the loop below.
488 if Parameters
.Runtime_Traces
then
489 Send_Trace_Info
(W_Completion
);
492 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
494 -- Try to remove calls to Sleep in the loop below by letting the caller
495 -- a chance of getting ready immediately, using Unlock & Yield.
496 -- See similar action in Wait_For_Call & Timed_Selective_Wait.
501 STPO
.Unlock
(Self_Id
);
504 if Entry_Call
.State
< Done
then
511 STPO
.Write_Lock
(Self_Id
);
515 Check_Pending_Actions_For_Entry_Call
(Self_Id
, Entry_Call
);
517 exit when Entry_Call
.State
>= Done
;
519 STPO
.Sleep
(Self_Id
, Entry_Caller_Sleep
);
522 Self_Id
.Common
.State
:= Runnable
;
523 Utilities
.Exit_One_ATC_Level
(Self_Id
);
525 if Parameters
.Runtime_Traces
then
526 Send_Trace_Info
(M_Call_Complete
);
528 end Wait_For_Completion
;
530 --------------------------------------
531 -- Wait_For_Completion_With_Timeout --
532 --------------------------------------
534 procedure Wait_For_Completion_With_Timeout
535 (Entry_Call
: Entry_Call_Link
;
536 Wakeup_Time
: Duration;
538 Yielded
: out Boolean)
540 Self_Id
: constant Task_Id
:= Entry_Call
.Self
;
541 Timedout
: Boolean := False;
543 use type Ada
.Exceptions
.Exception_Id
;
546 -- This procedure waits for the entry call to be served, with a timeout.
547 -- It tries to cancel the call if the timeout expires before the call is
550 -- If we wake up from the timed sleep operation here, it may be for
551 -- several possible reasons:
553 -- 1) The entry call is done being served.
554 -- 2) There is an abort or priority change to be served.
555 -- 3) The timeout has expired (Timedout = True)
556 -- 4) There has been a spurious wakeup.
558 -- Once the timeout has expired we may need to continue to wait if the
559 -- call is already being serviced. In that case, we want to go back to
560 -- sleep, but without any timeout. The variable Timedout is used to
561 -- control this. If the Timedout flag is set, we do not need to
562 -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for
563 -- some status change.
565 -- The original call may have become abortable after waking up. We want
566 -- to check Check_Pending_Actions_For_Entry_Call again in any case.
568 pragma Assert
(Entry_Call
.Mode
= Timed_Call
);
571 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
573 -- Looping is necessary in case the task wakes up early from the timed
574 -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of
575 -- POSIX condition variables. A thread waiting for a condition variable
576 -- is allowed to wake up at any time, not just when the condition is
577 -- signaled. See same loop in the ordinary Wait_For_Completion, above.
579 if Parameters
.Runtime_Traces
then
580 Send_Trace_Info
(WT_Completion
, Wakeup_Time
);
584 Check_Pending_Actions_For_Entry_Call
(Self_Id
, Entry_Call
);
585 exit when Entry_Call
.State
>= Done
;
587 STPO
.Timed_Sleep
(Self_Id
, Wakeup_Time
, Mode
,
588 Entry_Caller_Sleep
, Timedout
, Yielded
);
591 if Parameters
.Runtime_Traces
then
592 Send_Trace_Info
(E_Timeout
);
595 -- Try to cancel the call (see Try_To_Cancel_Entry_Call for
596 -- corresponding code in the ATC case).
598 Entry_Call
.Cancellation_Attempted
:= True;
600 if Self_Id
.Pending_ATC_Level
>= Entry_Call
.Level
then
601 Self_Id
.Pending_ATC_Level
:= Entry_Call
.Level
- 1;
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.
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
);
615 Self_Id
.Common
.State
:= Runnable
;
616 Utilities
.Exit_One_ATC_Level
(Self_Id
);
622 -- This last part is the same as ordinary Wait_For_Completion,
623 -- and is only executed if the call completed without timing out.
625 if Parameters
.Runtime_Traces
then
626 Send_Trace_Info
(M_Call_Complete
);
629 Self_Id
.Common
.State
:= Runnable
;
630 Utilities
.Exit_One_ATC_Level
(Self_Id
);
631 end Wait_For_Completion_With_Timeout
;
633 --------------------------
634 -- Wait_Until_Abortable --
635 --------------------------
637 procedure Wait_Until_Abortable
639 Call
: Entry_Call_Link
)
642 pragma Assert
(Self_ID
.ATC_Nesting_Level
> 0);
643 pragma Assert
(Call
.Mode
= Asynchronous_Call
);
645 if Parameters
.Runtime_Traces
then
646 Send_Trace_Info
(W_Completion
);
649 STPO
.Write_Lock
(Self_ID
);
650 Self_ID
.Common
.State
:= Entry_Caller_Sleep
;
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
);
658 Self_ID
.Common
.State
:= Runnable
;
659 STPO
.Unlock
(Self_ID
);
661 if Parameters
.Runtime_Traces
then
662 Send_Trace_Info
(M_Call_Complete
);
664 end Wait_Until_Abortable
;
666 end System
.Tasking
.Entry_Calls
;