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-2018, 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 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. --
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. --
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/>. --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
30 ------------------------------------------------------------------------------
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
;
40 package body System
.Tasking
.Entry_Calls
is
42 package STPO
renames System
.Task_Primitives
.Operations
;
45 use Protected_Objects
.Entries
;
46 use Protected_Objects
.Operations
;
48 -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock
49 -- internally. Those operations will raise Program_Error, which
50 -- we are not prepared to handle inside the RTS. Instead, use
51 -- System.Task_Primitives lock operations directly on Protection.L.
53 -----------------------
54 -- Local Subprograms --
55 -----------------------
57 procedure Lock_Server
(Entry_Call
: Entry_Call_Link
);
59 -- This locks the server targeted by Entry_Call
61 -- This may be a task or a protected object, depending on the target of the
62 -- original call or any subsequent requeues.
64 -- This routine is needed because the field specifying the server for this
65 -- call must be protected by the server's mutex. If it were protected by
66 -- the caller's mutex, accessing the server's queues would require locking
67 -- the caller to get the server, locking the server, and then accessing the
68 -- queues. This involves holding two ATCB locks at once, something which we
69 -- can guarantee that it will always be done in the same order, or locking
70 -- a protected object while we hold an ATCB lock, something which is not
71 -- permitted. Since the server cannot be obtained reliably, it must be
72 -- obtained unreliably and then checked again once it has been locked.
74 -- If Single_Lock and server is a PO, release RTS_Lock
76 -- This should only be called by the Entry_Call.Self.
77 -- It should be holding no other ATCB locks at the time.
79 procedure Unlock_Server
(Entry_Call
: Entry_Call_Link
);
80 -- STPO.Unlock the server targeted by Entry_Call. The server must
81 -- be locked before calling this.
83 -- If Single_Lock and server is a PO, take RTS_Lock on exit.
85 procedure Unlock_And_Update_Server
87 Entry_Call
: Entry_Call_Link
);
88 -- Similar to Unlock_Server, but services entry calls if the
89 -- server is a protected object.
91 -- If Single_Lock and server is a PO, take RTS_Lock on exit.
93 procedure Check_Pending_Actions_For_Entry_Call
95 Entry_Call
: Entry_Call_Link
);
96 -- This procedure performs priority change of a queued call and dequeuing
97 -- of an entry call when the call is cancelled. If the call is dequeued the
98 -- state should be set to Cancelled. Call only with abort deferred and
99 -- holding lock of Self_ID. This is a bit of common code for all entry
100 -- calls. The effect is to do any deferred base priority change operation,
101 -- in case some other task called STPO.Set_Priority while the current task
102 -- had abort deferred, and to dequeue the call if the call has been
105 procedure Poll_Base_Priority_Change_At_Entry_Call
107 Entry_Call
: Entry_Call_Link
);
108 pragma Inline
(Poll_Base_Priority_Change_At_Entry_Call
);
109 -- A specialized version of Poll_Base_Priority_Change, that does the
110 -- optional entry queue reordering. Has to be called with the Self_ID's
111 -- ATCB write-locked. May temporarily release the lock.
113 ---------------------
114 -- Check_Exception --
115 ---------------------
117 procedure Check_Exception
119 Entry_Call
: Entry_Call_Link
)
121 pragma Warnings
(Off
, Self_ID
);
123 use type Ada
.Exceptions
.Exception_Id
;
125 procedure Internal_Raise
(X
: Ada
.Exceptions
.Exception_Id
);
126 pragma Import
(C
, Internal_Raise
, "__gnat_raise_with_msg");
128 E
: constant Ada
.Exceptions
.Exception_Id
:=
129 Entry_Call
.Exception_To_Raise
;
131 -- pragma Assert (Self_ID.Deferral_Level = 0);
133 -- The above may be useful for debugging, but the Florist packages
134 -- contain critical sections that defer abort and then do entry calls,
135 -- which causes the above Assert to trip.
137 if E
/= Ada
.Exceptions
.Null_Id
then
142 ------------------------------------------
143 -- Check_Pending_Actions_For_Entry_Call --
144 ------------------------------------------
146 procedure Check_Pending_Actions_For_Entry_Call
148 Entry_Call
: Entry_Call_Link
)
151 pragma Assert
(Self_ID
= Entry_Call
.Self
);
153 Poll_Base_Priority_Change_At_Entry_Call
(Self_ID
, Entry_Call
);
155 if Self_ID
.Pending_ATC_Level
< Self_ID
.ATC_Nesting_Level
156 and then Entry_Call
.State
= Now_Abortable
158 STPO
.Unlock
(Self_ID
);
159 Lock_Server
(Entry_Call
);
161 if Queuing
.Onqueue
(Entry_Call
)
162 and then Entry_Call
.State
= Now_Abortable
164 Queuing
.Dequeue_Call
(Entry_Call
);
166 (if Entry_Call
.Cancellation_Attempted
then Cancelled
else Done
);
167 Unlock_And_Update_Server
(Self_ID
, Entry_Call
);
170 Unlock_Server
(Entry_Call
);
173 STPO
.Write_Lock
(Self_ID
);
175 end Check_Pending_Actions_For_Entry_Call
;
181 procedure Lock_Server
(Entry_Call
: Entry_Call_Link
) is
183 Test_PO
: Protection_Entries_Access
;
184 Ceiling_Violation
: Boolean;
185 Failures
: Integer := 0;
188 Test_Task
:= Entry_Call
.Called_Task
;
191 if Test_Task
= null then
193 -- Entry_Call was queued on a protected object, or in transition,
194 -- when we last fetched Test_Task.
196 Test_PO
:= To_Protection
(Entry_Call
.Called_PO
);
198 if Test_PO
= null then
200 -- We had very bad luck, interleaving with TWO different
201 -- requeue operations. Go around the loop and try again.
216 Lock_Entries_With_Status
(Test_PO
, Ceiling_Violation
);
220 -- The following code allows Lock_Server to be called when
221 -- cancelling a call, to allow for the possibility that the
222 -- priority of the caller has been raised beyond that of the
223 -- protected entry call by Ada.Dynamic_Priorities.Set_Priority.
225 -- If the current task has a higher priority than the ceiling
226 -- of the protected object, temporarily lower it. It will
227 -- be reset in Unlock.
229 if Ceiling_Violation
then
231 Current_Task
: constant Task_Id
:= STPO
.Self
;
232 Old_Base_Priority
: System
.Any_Priority
;
239 STPO
.Write_Lock
(Current_Task
);
240 Old_Base_Priority
:= Current_Task
.Common
.Base_Priority
;
241 Current_Task
.New_Base_Priority
:= Test_PO
.Ceiling
;
242 System
.Tasking
.Initialization
.Change_Base_Priority
244 STPO
.Unlock
(Current_Task
);
250 -- Following lock should not fail
252 Lock_Entries
(Test_PO
);
254 Test_PO
.Old_Base_Priority
:= Old_Base_Priority
;
255 Test_PO
.Pending_Action
:= True;
259 exit when To_Address
(Test_PO
) = Entry_Call
.Called_PO
;
260 Unlock_Entries
(Test_PO
);
268 STPO
.Write_Lock
(Test_Task
);
269 exit when Test_Task
= Entry_Call
.Called_Task
;
270 STPO
.Unlock
(Test_Task
);
273 Test_Task
:= Entry_Call
.Called_Task
;
274 Failures
:= Failures
+ 1;
275 pragma Assert
(Failures
<= 5);
279 ---------------------------------------------
280 -- Poll_Base_Priority_Change_At_Entry_Call --
281 ---------------------------------------------
283 procedure Poll_Base_Priority_Change_At_Entry_Call
285 Entry_Call
: Entry_Call_Link
)
288 if Self_ID
.Pending_Priority_Change
then
290 -- Check for ceiling violations ???
292 Self_ID
.Pending_Priority_Change
:= False;
294 -- Requeue the entry call at the new priority. We need to requeue
295 -- even if the new priority is the same than the previous (see ACATS
298 STPO
.Unlock
(Self_ID
);
299 Lock_Server
(Entry_Call
);
300 Queuing
.Requeue_Call_With_New_Prio
301 (Entry_Call
, STPO
.Get_Priority
(Self_ID
));
302 Unlock_And_Update_Server
(Self_ID
, Entry_Call
);
303 STPO
.Write_Lock
(Self_ID
);
305 end Poll_Base_Priority_Change_At_Entry_Call
;
311 procedure Reset_Priority
313 Acceptor_Prev_Priority
: Rendezvous_Priority
)
316 pragma Assert
(Acceptor
= STPO
.Self
);
318 -- Since we limit this kind of "active" priority change to be done
319 -- by the task for itself, we don't need to lock Acceptor.
321 if Acceptor_Prev_Priority
/= Priority_Not_Boosted
then
322 STPO
.Set_Priority
(Acceptor
, Acceptor_Prev_Priority
,
323 Loss_Of_Inheritance
=> True);
327 ------------------------------
328 -- Try_To_Cancel_Entry_Call --
329 ------------------------------
331 procedure Try_To_Cancel_Entry_Call
(Succeeded
: out Boolean) is
332 Entry_Call
: Entry_Call_Link
;
333 Self_ID
: constant Task_Id
:= STPO
.Self
;
335 use type Ada
.Exceptions
.Exception_Id
;
338 Entry_Call
:= Self_ID
.Entry_Calls
(Self_ID
.ATC_Nesting_Level
)'Access;
340 -- Experimentation has shown that abort is sometimes (but not
341 -- always) already deferred when Cancel_xxx_Entry_Call is called.
342 -- That may indicate an error. Find out what is going on. ???
344 pragma Assert
(Entry_Call
.Mode
= Asynchronous_Call
);
345 Initialization
.Defer_Abort_Nestable
(Self_ID
);
351 STPO
.Write_Lock
(Self_ID
);
352 Entry_Call
.Cancellation_Attempted
:= True;
354 if Self_ID
.Pending_ATC_Level
>= Entry_Call
.Level
then
355 Self_ID
.Pending_ATC_Level
:= Entry_Call
.Level
- 1;
358 Entry_Calls
.Wait_For_Completion
(Entry_Call
);
359 STPO
.Unlock
(Self_ID
);
365 Succeeded
:= Entry_Call
.State
= Cancelled
;
367 Initialization
.Undefer_Abort_Nestable
(Self_ID
);
369 -- Ideally, abort should no longer be deferred at this point, so we
370 -- should be able to call Check_Exception. The loop below should be
371 -- considered temporary, to work around the possibility that abort
372 -- may be deferred more than one level deep ???
374 if Entry_Call
.Exception_To_Raise
/= Ada
.Exceptions
.Null_Id
then
375 while Self_ID
.Deferral_Level
> 0 loop
376 System
.Tasking
.Initialization
.Undefer_Abort_Nestable
(Self_ID
);
379 Entry_Calls
.Check_Exception
(Self_ID
, Entry_Call
);
381 end Try_To_Cancel_Entry_Call
;
383 ------------------------------
384 -- Unlock_And_Update_Server --
385 ------------------------------
387 procedure Unlock_And_Update_Server
389 Entry_Call
: Entry_Call_Link
)
391 Called_PO
: Protection_Entries_Access
;
395 if Entry_Call
.Called_Task
/= null then
396 STPO
.Unlock
(Entry_Call
.Called_Task
);
398 Called_PO
:= To_Protection
(Entry_Call
.Called_PO
);
399 PO_Service_Entries
(Self_ID
, Called_PO
, False);
401 if Called_PO
.Pending_Action
then
402 Called_PO
.Pending_Action
:= False;
409 STPO
.Write_Lock
(Caller
);
410 Caller
.New_Base_Priority
:= Called_PO
.Old_Base_Priority
;
411 Initialization
.Change_Base_Priority
(Caller
);
412 STPO
.Unlock
(Caller
);
419 Unlock_Entries
(Called_PO
);
425 end Unlock_And_Update_Server
;
431 procedure Unlock_Server
(Entry_Call
: Entry_Call_Link
) is
433 Called_PO
: Protection_Entries_Access
;
436 if Entry_Call
.Called_Task
/= null then
437 STPO
.Unlock
(Entry_Call
.Called_Task
);
439 Called_PO
:= To_Protection
(Entry_Call
.Called_PO
);
441 if Called_PO
.Pending_Action
then
442 Called_PO
.Pending_Action
:= False;
449 STPO
.Write_Lock
(Caller
);
450 Caller
.New_Base_Priority
:= Called_PO
.Old_Base_Priority
;
451 Initialization
.Change_Base_Priority
(Caller
);
452 STPO
.Unlock
(Caller
);
459 Unlock_Entries
(Called_PO
);
467 -------------------------
468 -- Wait_For_Completion --
469 -------------------------
471 procedure Wait_For_Completion
(Entry_Call
: Entry_Call_Link
) is
472 Self_Id
: constant Task_Id
:= Entry_Call
.Self
;
475 -- If this is a conditional call, it should be cancelled when it
476 -- becomes abortable. This is checked in the loop below.
478 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
480 -- Try to remove calls to Sleep in the loop below by letting the caller
481 -- a chance of getting ready immediately, using Unlock & Yield.
482 -- See similar action in Wait_For_Call & Timed_Selective_Wait.
487 STPO
.Unlock
(Self_Id
);
490 if Entry_Call
.State
< Done
then
497 STPO
.Write_Lock
(Self_Id
);
501 Check_Pending_Actions_For_Entry_Call
(Self_Id
, Entry_Call
);
503 exit when Entry_Call
.State
>= Done
;
505 STPO
.Sleep
(Self_Id
, Entry_Caller_Sleep
);
508 Self_Id
.Common
.State
:= Runnable
;
509 Utilities
.Exit_One_ATC_Level
(Self_Id
);
511 end Wait_For_Completion
;
513 --------------------------------------
514 -- Wait_For_Completion_With_Timeout --
515 --------------------------------------
517 procedure Wait_For_Completion_With_Timeout
518 (Entry_Call
: Entry_Call_Link
;
519 Wakeup_Time
: Duration;
521 Yielded
: out Boolean)
523 Self_Id
: constant Task_Id
:= Entry_Call
.Self
;
524 Timedout
: Boolean := False;
527 -- This procedure waits for the entry call to be served, with a timeout.
528 -- It tries to cancel the call if the timeout expires before the call is
531 -- If we wake up from the timed sleep operation here, it may be for
532 -- several possible reasons:
534 -- 1) The entry call is done being served.
535 -- 2) There is an abort or priority change to be served.
536 -- 3) The timeout has expired (Timedout = True)
537 -- 4) There has been a spurious wakeup.
539 -- Once the timeout has expired we may need to continue to wait if the
540 -- call is already being serviced. In that case, we want to go back to
541 -- sleep, but without any timeout. The variable Timedout is used to
542 -- control this. If the Timedout flag is set, we do not need to
543 -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for
544 -- some status change.
546 -- The original call may have become abortable after waking up. We want
547 -- to check Check_Pending_Actions_For_Entry_Call again in any case.
549 pragma Assert
(Entry_Call
.Mode
= Timed_Call
);
552 Self_Id
.Common
.State
:= Entry_Caller_Sleep
;
554 -- Looping is necessary in case the task wakes up early from the timed
555 -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of
556 -- POSIX condition variables. A thread waiting for a condition variable
557 -- is allowed to wake up at any time, not just when the condition is
558 -- signaled. See same loop in the ordinary Wait_For_Completion, above.
561 Check_Pending_Actions_For_Entry_Call
(Self_Id
, Entry_Call
);
562 exit when Entry_Call
.State
>= Done
;
564 STPO
.Timed_Sleep
(Self_Id
, Wakeup_Time
, Mode
,
565 Entry_Caller_Sleep
, Timedout
, Yielded
);
568 -- Try to cancel the call (see Try_To_Cancel_Entry_Call for
569 -- corresponding code in the ATC case).
571 Entry_Call
.Cancellation_Attempted
:= True;
573 -- Reset Entry_Call.State so that the call is marked as cancelled
574 -- by Check_Pending_Actions_For_Entry_Call below.
576 if Entry_Call
.State
< Was_Abortable
then
577 Entry_Call
.State
:= Now_Abortable
;
580 if Self_Id
.Pending_ATC_Level
>= Entry_Call
.Level
then
581 Self_Id
.Pending_ATC_Level
:= Entry_Call
.Level
- 1;
584 -- The following loop is the same as the loop and exit code
585 -- from the ordinary Wait_For_Completion. If we get here, we
586 -- have timed out but we need to keep waiting until the call
587 -- has actually completed or been cancelled successfully.
590 Check_Pending_Actions_For_Entry_Call
(Self_Id
, Entry_Call
);
591 exit when Entry_Call
.State
>= Done
;
592 STPO
.Sleep
(Self_Id
, Entry_Caller_Sleep
);
595 Self_Id
.Common
.State
:= Runnable
;
596 Utilities
.Exit_One_ATC_Level
(Self_Id
);
602 -- This last part is the same as ordinary Wait_For_Completion,
603 -- and is only executed if the call completed without timing out.
605 Self_Id
.Common
.State
:= Runnable
;
606 Utilities
.Exit_One_ATC_Level
(Self_Id
);
607 end Wait_For_Completion_With_Timeout
;
609 --------------------------
610 -- Wait_Until_Abortable --
611 --------------------------
613 procedure Wait_Until_Abortable
615 Call
: Entry_Call_Link
)
618 pragma Assert
(Self_ID
.ATC_Nesting_Level
> 0);
619 pragma Assert
(Call
.Mode
= Asynchronous_Call
);
621 STPO
.Write_Lock
(Self_ID
);
622 Self_ID
.Common
.State
:= Entry_Caller_Sleep
;
625 Check_Pending_Actions_For_Entry_Call
(Self_ID
, Call
);
626 exit when Call
.State
>= Was_Abortable
;
627 STPO
.Sleep
(Self_ID
, Async_Select_Sleep
);
630 Self_ID
.Common
.State
:= Runnable
;
631 STPO
.Unlock
(Self_ID
);
633 end Wait_Until_Abortable
;
635 end System
.Tasking
.Entry_Calls
;