1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S --
9 -- Copyright (C) 1998-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 ------------------------------------------------------------------------------
33 -- Turn off polling, we do not want ATC polling to take place during
34 -- tasking operations. It causes infinite loops and other problems.
36 with Ada
.Unchecked_Conversion
;
37 with Ada
.Task_Identification
;
39 with System
.Task_Primitives
.Operations
;
40 with System
.Tasking
.Utilities
;
41 with System
.Tasking
.Initialization
;
42 with System
.Tasking
.Debug
;
43 with System
.OS_Primitives
;
44 with System
.Interrupt_Management
.Operations
;
46 package body System
.Tasking
.Async_Delays
is
48 package STPO
renames System
.Task_Primitives
.Operations
;
49 package ST
renames System
.Tasking
;
50 package STU
renames System
.Tasking
.Utilities
;
51 package STI
renames System
.Tasking
.Initialization
;
52 package OSP
renames System
.OS_Primitives
;
56 function To_System
is new Ada
.Unchecked_Conversion
57 (Ada
.Task_Identification
.Task_Id
, Task_Id
);
59 Timer_Attention
: Boolean := False;
60 pragma Atomic
(Timer_Attention
);
63 pragma Interrupt_Priority
(System
.Any_Priority
'Last);
66 Timer_Server_ID
: constant ST
.Task_Id
:= To_System
(Timer_Server
'Identity);
68 -- The timer queue is a circular doubly linked list, ordered by absolute
69 -- wakeup time. The first item in the queue is Timer_Queue.Succ.
70 -- It is given a Resume_Time that is larger than any legitimate wakeup
71 -- time, so that the ordered insertion will always stop searching when it
72 -- gets back to the queue header block.
74 Timer_Queue
: aliased Delay_Block
;
76 package Init_Timer_Queue
is end Init_Timer_Queue
;
77 pragma Unreferenced
(Init_Timer_Queue
);
78 -- Initialize the Timer_Queue. This is a package to work around the
79 -- fact that statements are syntactically illegal here. We want this
80 -- initialization to happen before the Timer_Server is activated. A
81 -- build-in-place function would also work, but that's not supported
82 -- on all platforms (e.g. cil).
84 package body Init_Timer_Queue
is
86 Timer_Queue
.Succ
:= Timer_Queue
'Unchecked_Access;
87 Timer_Queue
.Pred
:= Timer_Queue
'Unchecked_Access;
88 Timer_Queue
.Resume_Time
:= Duration'Last;
91 ------------------------
92 -- Cancel_Async_Delay --
93 ------------------------
95 -- This should (only) be called from the compiler-generated cleanup routine
96 -- for an async. select statement with delay statement as trigger. The
97 -- effect should be to remove the delay from the timer queue, and exit one
99 -- The usage and logic are similar to Cancel_Protected_Entry_Call, but
100 -- simplified because this is not a true entry call.
102 procedure Cancel_Async_Delay
(D
: Delay_Block_Access
) is
103 Dpred
: Delay_Block_Access
;
104 Dsucc
: Delay_Block_Access
;
107 -- Note that we mark the delay as being cancelled
108 -- using a level value that is reserved.
110 -- make this operation idempotent
112 if D
.Level
= ATC_Level_Infinity
then
116 D
.Level
:= ATC_Level_Infinity
;
118 -- remove self from timer queue
120 STI
.Defer_Abort_Nestable
(D
.Self_Id
);
126 STPO
.Write_Lock
(Timer_Server_ID
);
133 STPO
.Unlock
(Timer_Server_ID
);
135 -- Note that the above deletion code is required to be
136 -- idempotent, since the block may have been dequeued
137 -- previously by the Timer_Server.
139 -- leave the asynchronous select
141 STPO
.Write_Lock
(D
.Self_Id
);
142 STU
.Exit_One_ATC_Level
(D
.Self_Id
);
143 STPO
.Unlock
(D
.Self_Id
);
149 STI
.Undefer_Abort_Nestable
(D
.Self_Id
);
150 end Cancel_Async_Delay
;
152 ----------------------
153 -- Enqueue_Duration --
154 ----------------------
156 function Enqueue_Duration
158 D
: Delay_Block_Access
) return Boolean
167 -- The corresponding call to Undefer_Abort is performed by the
168 -- expanded code (see exp_ch9).
170 STI
.Defer_Abort
(STPO
.Self
);
172 (STPO
.Monotonic_Clock
173 + Duration'Min (T
, OSP
.Max_Sensible_Delay
), D
);
176 end Enqueue_Duration
;
182 -- Allocate a queue element for the wakeup time T and put it in the
183 -- queue in wakeup time order. Assume we are on an asynchronous
184 -- select statement with delay trigger. Put the calling task to
185 -- sleep until either the delay expires or is cancelled.
187 -- We use one entry call record for this delay, since we have
188 -- to increment the ATC nesting level, but since it is not a
189 -- real entry call we do not need to use any of the fields of
190 -- the call record. The following code implements a subset of
191 -- the actions for the asynchronous case of Protected_Entry_Call,
192 -- much simplified since we know this never blocks, and does not
193 -- have the full semantics of a protected entry call.
195 procedure Time_Enqueue
197 D
: Delay_Block_Access
)
199 Self_Id
: constant Task_Id
:= STPO
.Self
;
200 Q
: Delay_Block_Access
;
203 pragma Debug
(Debug
.Trace
(Self_Id
, "Async_Delay", 'P'));
204 pragma Assert
(Self_Id
.Deferral_Level
= 1,
205 "async delay from within abort-deferred region");
207 if Self_Id
.ATC_Nesting_Level
= ATC_Level
'Last then
208 raise Storage_Error
with "not enough ATC nesting levels";
211 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
+ 1;
214 (Debug
.Trace
(Self_Id
, "ASD: entered ATC level: " &
215 ATC_Level
'Image (Self_Id
.ATC_Nesting_Level
), 'A'));
217 D
.Level
:= Self_Id
.ATC_Nesting_Level
;
218 D
.Self_Id
:= Self_Id
;
225 STPO
.Write_Lock
(Timer_Server_ID
);
227 -- Previously, there was code here to dynamically create
228 -- the Timer_Server task, if one did not already exist.
229 -- That code had a timing window that could allow multiple
230 -- timer servers to be created. Luckily, the need for
231 -- postponing creation of the timer server should now be
232 -- gone, since this package will only be linked in if
233 -- there are calls to enqueue calls on the timer server.
235 -- Insert D in the timer queue, at the position determined
236 -- by the wakeup time T.
238 Q
:= Timer_Queue
.Succ
;
240 while Q
.Resume_Time
< T
loop
244 -- Q is the block that has Resume_Time equal to or greater than
245 -- T. After the insertion we want Q to be the successor of D.
252 -- If the new element became the head of the queue,
253 -- signal the Timer_Server to wake up.
255 if Timer_Queue
.Succ
= D
then
256 Timer_Attention
:= True;
257 STPO
.Wakeup
(Timer_Server_ID
, ST
.Timer_Server_Sleep
);
260 STPO
.Unlock
(Timer_Server_ID
);
271 function Timed_Out
(D
: Delay_Block_Access
) return Boolean is
280 task body Timer_Server
is
281 Ignore
: constant Boolean := STU
.Make_Independent
;
283 -- Local Declarations
285 Next_Wakeup_Time
: Duration := Duration'Last;
289 Dequeued
: Delay_Block_Access
;
290 Dequeued_Task
: Task_Id
;
292 pragma Unreferenced
(Timedout
, Yielded
);
295 pragma Assert
(Timer_Server_ID
= STPO
.Self
);
297 -- Since this package may be elaborated before System.Interrupt,
298 -- we need to call Setup_Interrupt_Mask explicitly to ensure that
299 -- this task has the proper signal mask.
301 Interrupt_Management
.Operations
.Setup_Interrupt_Mask
;
303 -- Initialize the timer queue to empty, and make the wakeup time of the
304 -- header node be larger than any real wakeup time we will ever use.
307 STI
.Defer_Abort
(Timer_Server_ID
);
313 STPO
.Write_Lock
(Timer_Server_ID
);
315 -- The timer server needs to catch pending aborts after finalization
316 -- of library packages. If it doesn't poll for it, the server will
319 if not Timer_Attention
then
320 Timer_Server_ID
.Common
.State
:= ST
.Timer_Server_Sleep
;
322 if Next_Wakeup_Time
= Duration'Last then
323 Timer_Server_ID
.User_State
:= 1;
325 STPO
.Monotonic_Clock
+ OSP
.Max_Sensible_Delay
;
328 Timer_Server_ID
.User_State
:= 2;
332 (Timer_Server_ID
, Next_Wakeup_Time
,
333 OSP
.Absolute_RT
, ST
.Timer_Server_Sleep
,
335 Timer_Server_ID
.Common
.State
:= ST
.Runnable
;
338 -- Service all of the wakeup requests on the queue whose times have
339 -- been reached, and update Next_Wakeup_Time to next wakeup time
340 -- after that (the wakeup time of the head of the queue if any, else
341 -- a time far in the future).
343 Timer_Server_ID
.User_State
:= 3;
344 Timer_Attention
:= False;
346 Now
:= STPO
.Monotonic_Clock
;
347 while Timer_Queue
.Succ
.Resume_Time
<= Now
loop
349 -- Dequeue the waiting task from the front of the queue
351 pragma Debug
(System
.Tasking
.Debug
.Trace
352 (Timer_Server_ID
, "Timer service: waking up waiting task", 'E'));
354 Dequeued
:= Timer_Queue
.Succ
;
355 Timer_Queue
.Succ
:= Dequeued
.Succ
;
356 Dequeued
.Succ
.Pred
:= Dequeued
.Pred
;
357 Dequeued
.Succ
:= Dequeued
;
358 Dequeued
.Pred
:= Dequeued
;
360 -- We want to abort the queued task to the level of the async.
361 -- select statement with the delay. To do that, we need to lock
362 -- the ATCB of that task, but to avoid deadlock we need to release
363 -- the lock of the Timer_Server. This leaves a window in which
364 -- another task might perform an enqueue or dequeue operation on
365 -- the timer queue, but that is OK because we always restart the
366 -- next iteration at the head of the queue.
368 STPO
.Unlock
(Timer_Server_ID
);
369 STPO
.Write_Lock
(Dequeued
.Self_Id
);
370 Dequeued_Task
:= Dequeued
.Self_Id
;
371 Dequeued
.Timed_Out
:= True;
372 STI
.Locked_Abort_To_Level
373 (Timer_Server_ID
, Dequeued_Task
, Dequeued
.Level
- 1);
374 STPO
.Unlock
(Dequeued_Task
);
375 STPO
.Write_Lock
(Timer_Server_ID
);
378 Next_Wakeup_Time
:= Timer_Queue
.Succ
.Resume_Time
;
380 -- Service returns the Next_Wakeup_Time.
381 -- The Next_Wakeup_Time is either an infinity (no delay request)
382 -- or the wakeup time of the queue head. This value is used for
383 -- an actual delay in this server.
385 STPO
.Unlock
(Timer_Server_ID
);
391 STI
.Undefer_Abort
(Timer_Server_ID
);
395 end System
.Tasking
.Async_Delays
;