1 ------------------------------------------------------------------------------
3 -- GNU ADA 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-2001, 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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. It is --
30 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
32 ------------------------------------------------------------------------------
34 with System
.Task_Primitives
.Operations
;
35 -- used for STPO.Write_Lock
41 with System
.Tasking
.Initialization
;
42 -- used for Change_Base_Priority
43 -- Poll_Base_Priority_Change_At_Entry_Call
44 -- Dynamic_Priority_Support
45 -- Defer_Abort/Undefer_Abort
47 with System
.Tasking
.Protected_Objects
.Entries
;
48 -- used for To_Protection
50 with System
.Tasking
.Protected_Objects
.Operations
;
51 -- used for PO_Service_Entries
53 with System
.Tasking
.Queuing
;
54 -- used for Requeue_Call_With_New_Prio
58 with System
.Tasking
.Utilities
;
59 -- used for Exit_One_ATC_Level
61 with System
.Parameters
;
62 -- used for Single_Lock
66 -- used for Send_Trace_Info
68 package body System
.Tasking
.Entry_Calls
is
70 package STPO
renames System
.Task_Primitives
.Operations
;
74 use Protected_Objects
.Entries
;
75 use Protected_Objects
.Operations
;
78 -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock
79 -- internally. Those operations will raise Program_Error, which
80 -- we are not prepared to handle inside the RTS. Instead, use
81 -- System.Task_Primitives lock operations directly on Protection.L.
83 -----------------------
84 -- Local Subprograms --
85 -----------------------
87 procedure Lock_Server
(Entry_Call
: Entry_Call_Link
);
88 -- This locks the server targeted by Entry_Call.
90 -- This may be a task or a protected object,
91 -- depending on the target of the original call or any subsequent
94 -- This routine is needed because the field specifying the server
95 -- for this call must be protected by the server's mutex. If it were
96 -- protected by the caller's mutex, accessing the server's queues would
97 -- require locking the caller to get the server, locking the server,
98 -- and then accessing the queues. This involves holding two ATCB
99 -- locks at once, something which we can guarantee that it will always
100 -- be done in the same order, or locking a protected object while we
101 -- hold an ATCB lock, something which is not permitted. Since
102 -- the server cannot be obtained reliably, it must be obtained unreliably
103 -- and then checked again once it has been locked.
105 -- If Single_Lock and server is a PO, release RTS_Lock.
107 procedure Unlock_Server
(Entry_Call
: Entry_Call_Link
);
108 -- STPO.Unlock the server targeted by Entry_Call. The server must
109 -- be locked before calling this.
111 -- If Single_Lock and server is a PO, take RTS_Lock on exit.
113 procedure Unlock_And_Update_Server
115 Entry_Call
: Entry_Call_Link
);
116 -- Similar to Unlock_Server, but services entry calls if the
117 -- server is a protected object.
119 -- If Single_Lock and server is a PO, take RTS_Lock on exit.
121 procedure Check_Pending_Actions_For_Entry_Call
123 Entry_Call
: Entry_Call_Link
);
124 -- This procedure performs priority change of a queued call and
125 -- dequeuing of an entry call when the call is cancelled.
126 -- If the call is dequeued the state should be set to Cancelled.
128 procedure Poll_Base_Priority_Change_At_Entry_Call
130 Entry_Call
: Entry_Call_Link
);
131 pragma Inline
(Poll_Base_Priority_Change_At_Entry_Call
);
132 -- Has to be called with the Self_ID's ATCB write-locked.
133 -- May temporariliy release the lock.
135 ---------------------
136 -- Check_Exception --
137 ---------------------
139 -- Raise any pending exception from the Entry_Call.
141 -- This should be called at the end of every compiler interface
142 -- procedure that implements an entry call.
144 -- In principle, the caller should not be abort-deferred (unless
145 -- the application program violates the Ada language rules by doing
146 -- entry calls from within protected operations -- an erroneous practice
147 -- apparently followed with success by some adventurous GNAT users).
148 -- Absolutely, the caller should not be holding any locks, or there
151 procedure Check_Exception
153 Entry_Call
: Entry_Call_Link
)
155 pragma Warnings
(Off
, Self_ID
);
157 use type Ada
.Exceptions
.Exception_Id
;
159 procedure Internal_Raise
(X
: Ada
.Exceptions
.Exception_Id
);
160 pragma Import
(C
, Internal_Raise
, "__gnat_raise_with_msg");
162 E
: constant Ada
.Exceptions
.Exception_Id
:=
163 Entry_Call
.Exception_To_Raise
;
165 -- pragma Assert (Self_ID.Deferral_Level = 0);
166 -- The above may be useful for debugging, but the Florist packages
167 -- contain critical sections that defer abort and then do entry calls,
168 -- which causes the above Assert to trip.
170 if E
/= Ada
.Exceptions
.Null_Id
then
175 -----------------------------------------
176 -- Check_Pending_Actions_For_Entry_Call --
177 -----------------------------------------
179 -- Call only with abort deferred and holding lock of Self_ID. This
180 -- is a bit of common code for all entry calls. The effect is to do
181 -- any deferred base priority change operation, in case some other
182 -- task called STPO.Set_Priority while the current task had abort deferred,
183 -- and to dequeue the call if the call has been aborted.
185 procedure Check_Pending_Actions_For_Entry_Call
187 Entry_Call
: Entry_Call_Link
) is
189 pragma Assert
(Self_ID
= Entry_Call
.Self
);
191 Poll_Base_Priority_Change_At_Entry_Call
(Self_ID
, Entry_Call
);
193 if Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
194 and then Entry_Call
.State
= Now_Abortable
196 STPO
.Unlock
(Self_ID
);
197 Lock_Server
(Entry_Call
);
199 if Queuing
.Onqueue
(Entry_Call
)
200 and then Entry_Call
.State
= Now_Abortable
202 Queuing
.Dequeue_Call
(Entry_Call
);
204 if Entry_Call
.Cancellation_Attempted
then
205 Entry_Call
.State
:= Cancelled
;
207 Entry_Call
.State
:= Done
;
210 Unlock_And_Update_Server
(Self_ID
, Entry_Call
);
213 Unlock_Server
(Entry_Call
);
216 STPO
.Write_Lock
(Self_ID
);
218 end Check_Pending_Actions_For_Entry_Call
;
224 -- This should only be called by the Entry_Call.Self.
225 -- It should be holding no other ATCB locks at the time.
227 procedure Lock_Server
(Entry_Call
: Entry_Call_Link
) is
229 Test_PO
: Protection_Entries_Access
;
230 Ceiling_Violation
: Boolean;
231 Failures
: Integer := 0;
234 Test_Task
:= Entry_Call
.Called_Task
;
237 if Test_Task
= null then
239 -- Entry_Call was queued on a protected object,
240 -- or in transition, when we last fetched Test_Task.
242 Test_PO
:= To_Protection
(Entry_Call
.Called_PO
);
244 if Test_PO
= null then
246 -- We had very bad luck, interleaving with TWO different
247 -- requeue operations. Go around the loop and try again.
262 Lock_Entries
(Test_PO
, Ceiling_Violation
);
265 -- The following code allows Lock_Server to be called
266 -- when cancelling a call, to allow for the possibility
267 -- that the priority of the caller has been raised
268 -- beyond that of the protected entry call by
269 -- Ada.Dynamic_Priorities.Set_Priority.
271 -- If the current task has a higher priority than the ceiling
272 -- of the protected object, temporarily lower it. It will
273 -- be reset in Unlock.
275 if Ceiling_Violation
then
277 Current_Task
: Task_ID
:= STPO
.Self
;
278 Old_Base_Priority
: System
.Any_Priority
;
285 STPO
.Write_Lock
(Current_Task
);
286 Old_Base_Priority
:= Current_Task
.Common
.Base_Priority
;
287 Current_Task
.New_Base_Priority
:= Test_PO
.Ceiling
;
288 System
.Tasking
.Initialization
.Change_Base_Priority
290 STPO
.Unlock
(Current_Task
);
296 -- Following lock should not fail
298 Lock_Entries
(Test_PO
);
300 Test_PO
.Old_Base_Priority
:= Old_Base_Priority
;
301 Test_PO
.Pending_Action
:= True;
305 exit when To_Address
(Test_PO
) = Entry_Call
.Called_PO
;
306 Unlock_Entries
(Test_PO
);
314 STPO
.Write_Lock
(Test_Task
);
315 exit when Test_Task
= Entry_Call
.Called_Task
;
316 STPO
.Unlock
(Test_Task
);
319 Test_Task
:= Entry_Call
.Called_Task
;
320 Failures
:= Failures
+ 1;
321 pragma Assert
(Failures
<= 5);
325 ---------------------------------------------
326 -- Poll_Base_Priority_Change_At_Entry_Call --
327 ---------------------------------------------
329 -- A specialized version of Poll_Base_Priority_Change,
330 -- that does the optional entry queue reordering.
332 procedure Poll_Base_Priority_Change_At_Entry_Call
334 Entry_Call
: Entry_Call_Link
) is
336 if Dynamic_Priority_Support
and then Self_ID
.Pending_Priority_Change
then
337 -- Check for ceiling violations ???
339 Self_ID
.Pending_Priority_Change
:= False;
341 if Self_ID
.Common
.Base_Priority
= Self_ID
.New_Base_Priority
then
347 STPO
.Unlock
(Self_ID
);
349 STPO
.Write_Lock
(Self_ID
);
353 if Self_ID
.Common
.Base_Priority
< Self_ID
.New_Base_Priority
then
356 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
357 STPO
.Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
362 Self_ID
.Common
.Base_Priority
:= Self_ID
.New_Base_Priority
;
363 STPO
.Set_Priority
(Self_ID
, Self_ID
.Common
.Base_Priority
);
370 STPO
.Unlock
(Self_ID
);
372 STPO
.Write_Lock
(Self_ID
);
377 -- Requeue the entry call at the new priority.
378 -- We need to requeue even if the new priority is the same than
379 -- the previous (see ACVC cxd4006).
381 STPO
.Unlock
(Self_ID
);
382 Lock_Server
(Entry_Call
);
383 Queuing
.Requeue_Call_With_New_Prio
384 (Entry_Call
, STPO
.Get_Priority
(Self_ID
));
385 Unlock_And_Update_Server
(Self_ID
, Entry_Call
);
386 STPO
.Write_Lock
(Self_ID
);
388 end Poll_Base_Priority_Change_At_Entry_Call
;
394 procedure Reset_Priority
396 Acceptor_Prev_Priority
: Rendezvous_Priority
) is
398 pragma Assert
(Acceptor
= STPO
.Self
);
400 -- Since we limit this kind of "active" priority change to be done
401 -- by the task for itself, we don't need to lock Acceptor.
403 if Acceptor_Prev_Priority
/= Priority_Not_Boosted
then
404 STPO
.Set_Priority
(Acceptor
, Acceptor_Prev_Priority
,
405 Loss_Of_Inheritance
=> True);
409 ------------------------------
410 -- Try_To_Cancel_Entry_Call --
411 ------------------------------
413 procedure Try_To_Cancel_Entry_Call
(Succeeded
: out Boolean) is
414 Entry_Call
: Entry_Call_Link
;
415 Self_ID
: constant Task_ID
:= STPO
.Self
;
417 use type Ada
.Exceptions
.Exception_Id
;
420 Entry_Call
:= Self_ID
.Entry_Calls
(Self_ID
.ATC_Nesting_Level
)'Access;
422 -- Experimentation has shown that abort is sometimes (but not
423 -- always) already deferred when Cancel_xxx_Entry_Call is called.
424 -- That may indicate an error. Find out what is going on. ???
426 pragma Assert
(Entry_Call
.Mode
= Asynchronous_Call
);
427 Initialization
.Defer_Abort_Nestable
(Self_ID
);
433 STPO
.Write_Lock
(Self_ID
);
434 Entry_Call
.Cancellation_Attempted
:= True;
436 if Self_ID
.Pending_ATC_Level
>= Entry_Call
.Level
then
437 Self_ID
.Pending_ATC_Level
:= Entry_Call
.Level
- 1;
440 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
441 STPO
.Unlock
(Self_ID
);
447 Succeeded
:= Entry_Call
.State
= Cancelled
;
450 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
454 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
456 -- Ideally, abort should no longer be deferred at this
457 -- point, so we should be able to call Check_Exception.
458 -- The loop below should be considered temporary,
459 -- to work around the possiblility that abort may be deferred
460 -- more than one level deep.
462 if Entry_Call
.Exception_To_Raise
/= Ada
.Exceptions
.Null_Id
then
463 while Self_ID
.Deferral_Level
> 0 loop
464 System
.Tasking
.Initialization
.Undefer_Abort_Nestable
(Self_ID
);
467 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
470 end Try_To_Cancel_Entry_Call
;
472 ------------------------------
473 -- Unlock_And_Update_Server --
474 ------------------------------
476 procedure Unlock_And_Update_Server
478 Entry_Call
: Entry_Call_Link
)
480 Called_PO
: Protection_Entries_Access
;
484 if Entry_Call
.Called_Task
/= null then
485 STPO
.Unlock
(Entry_Call
.Called_Task
);
487 Called_PO
:= To_Protection
(Entry_Call
.Called_PO
);
488 PO_Service_Entries
(Self_ID
, Called_PO
);
490 if Called_PO
.Pending_Action
then
491 Called_PO
.Pending_Action
:= False;
498 STPO
.Write_Lock
(Caller
);
499 Caller
.New_Base_Priority
:= Called_PO
.Old_Base_Priority
;
500 Initialization
.Change_Base_Priority
(Caller
);
501 STPO
.Unlock
(Caller
);
508 Unlock_Entries
(Called_PO
);
514 end Unlock_And_Update_Server
;
520 procedure Unlock_Server
(Entry_Call
: Entry_Call_Link
) is
522 Called_PO
: Protection_Entries_Access
;
525 if Entry_Call
.Called_Task
/= null then
526 STPO
.Unlock
(Entry_Call
.Called_Task
);
528 Called_PO
:= To_Protection
(Entry_Call
.Called_PO
);
530 if Called_PO
.Pending_Action
then
531 Called_PO
.Pending_Action
:= False;
538 STPO
.Write_Lock
(Caller
);
539 Caller
.New_Base_Priority
:= Called_PO
.Old_Base_Priority
;
540 Initialization
.Change_Base_Priority
(Caller
);
541 STPO
.Unlock
(Caller
);
548 Unlock_Entries
(Called_PO
);
556 -------------------------
557 -- Wait_For_Completion --
558 -------------------------
560 procedure Wait_For_Completion
(Entry_Call
: Entry_Call_Link
) is
561 Self_Id
: constant Task_ID
:= Entry_Call
.Self
;
563 -- If this is a conditional call, it should be cancelled when it
564 -- becomes abortable. This is checked in the loop below.
566 if Parameters
.Runtime_Traces
then
567 Send_Trace_Info
(W_Completion
);
570 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
573 Check_Pending_Actions_For_Entry_Call
(Self_Id
, Entry_Call
);
574 exit when Entry_Call
.State
>= Done
;
575 STPO
.Sleep
(Self_Id
, Entry_Caller_Sleep
);
578 Self_Id
.Common
.State
:= Runnable
;
579 Utilities
.Exit_One_ATC_Level
(Self_Id
);
581 if Parameters
.Runtime_Traces
then
582 Send_Trace_Info
(M_Call_Complete
);
584 end Wait_For_Completion
;
586 --------------------------------------
587 -- Wait_For_Completion_With_Timeout --
588 --------------------------------------
590 procedure Wait_For_Completion_With_Timeout
591 (Entry_Call
: Entry_Call_Link
;
592 Wakeup_Time
: Duration;
594 Yielded
: out Boolean)
596 Self_Id
: constant Task_ID
:= Entry_Call
.Self
;
597 Timedout
: Boolean := False;
599 use type Ada
.Exceptions
.Exception_Id
;
602 -- This procedure waits for the entry call to be served, with a timeout.
603 -- It tries to cancel the call if the timeout expires before the call is
606 -- If we wake up from the timed sleep operation here, it may be for
607 -- several possible reasons:
609 -- 1) The entry call is done being served.
610 -- 2) There is an abort or priority change to be served.
611 -- 3) The timeout has expired (Timedout = True)
612 -- 4) There has been a spurious wakeup.
614 -- Once the timeout has expired we may need to continue to wait if the
615 -- call is already being serviced. In that case, we want to go back to
616 -- sleep, but without any timeout. The variable Timedout is used to
617 -- control this. If the Timedout flag is set, we do not need to
618 -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for
619 -- some status change.
621 -- The original call may have become abortable after waking up. We want
622 -- to check Check_Pending_Actions_For_Entry_Call again in any case.
624 pragma Assert
(Entry_Call
.Mode
= Timed_Call
);
627 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
629 -- Looping is necessary in case the task wakes up early from the
630 -- timed sleep, due to a "spurious wakeup". Spurious wakeups are
631 -- a weakness of POSIX condition variables. A thread waiting for
632 -- a condition variable is allowed to wake up at any time, not just
633 -- when the condition is signaled. See the same loop in the
634 -- ordinary Wait_For_Completion, above.
636 if Parameters
.Runtime_Traces
then
637 Send_Trace_Info
(WT_Completion
, Wakeup_Time
);
641 Check_Pending_Actions_For_Entry_Call
(Self_Id
, Entry_Call
);
642 exit when Entry_Call
.State
>= Done
;
644 STPO
.Timed_Sleep
(Self_Id
, Wakeup_Time
, Mode
,
645 Entry_Caller_Sleep
, Timedout
, Yielded
);
648 if Parameters
.Runtime_Traces
then
649 Send_Trace_Info
(E_Timeout
);
652 -- Try to cancel the call (see Try_To_Cancel_Entry_Call for
653 -- corresponding code in the ATC case).
655 Entry_Call
.Cancellation_Attempted
:= True;
657 if Self_Id
.Pending_ATC_Level
>= Entry_Call
.Level
then
658 Self_Id
.Pending_ATC_Level
:= Entry_Call
.Level
- 1;
661 -- The following loop is the same as the loop and exit code
662 -- from the ordinary Wait_For_Completion. If we get here, we
663 -- have timed out but we need to keep waiting until the call
664 -- has actually completed or been cancelled successfully.
667 Check_Pending_Actions_For_Entry_Call
(Self_Id
, Entry_Call
);
668 exit when Entry_Call
.State
>= Done
;
669 STPO
.Sleep
(Self_Id
, Entry_Caller_Sleep
);
672 Self_Id
.Common
.State
:= Runnable
;
673 Utilities
.Exit_One_ATC_Level
(Self_Id
);
679 -- This last part is the same as ordinary Wait_For_Completion,
680 -- and is only executed if the call completed without timing out.
682 if Parameters
.Runtime_Traces
then
683 Send_Trace_Info
(M_Call_Complete
);
686 Self_Id
.Common
.State
:= Runnable
;
687 Utilities
.Exit_One_ATC_Level
(Self_Id
);
688 end Wait_For_Completion_With_Timeout
;
690 --------------------------
691 -- Wait_Until_Abortable --
692 --------------------------
694 procedure Wait_Until_Abortable
696 Call
: Entry_Call_Link
) is
698 pragma Assert
(Self_ID
.ATC_Nesting_Level
> 0);
699 pragma Assert
(Call
.Mode
= Asynchronous_Call
);
701 if Parameters
.Runtime_Traces
then
702 Send_Trace_Info
(W_Completion
);
705 STPO
.Write_Lock
(Self_ID
);
706 Self_ID
.Common
.State
:= Entry_Caller_Sleep
;
709 Check_Pending_Actions_For_Entry_Call
(Self_ID
, Call
);
710 exit when Call
.State
>= Was_Abortable
;
711 STPO
.Sleep
(Self_ID
, Async_Select_Sleep
);
714 Self_ID
.Common
.State
:= Runnable
;
715 STPO
.Unlock
(Self_ID
);
717 if Parameters
.Runtime_Traces
then
718 Send_Trace_Info
(M_Call_Complete
);
720 end Wait_Until_Abortable
;
722 end System
.Tasking
.Entry_Calls
;