1 ------------------------------------------------------------------------------
3 -- GNU ADA 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 --
10 -- Copyright (C) 1998-2002, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
36 -- Turn off polling, we do not want ATC polling to take place during
37 -- tasking operations. It causes infinite loops and other problems.
40 -- Used for Raise_Exception
42 with System
.Task_Primitives
.Operations
;
43 -- Used for Write_Lock,
52 with System
.Tasking
.Utilities
;
53 -- Used for Make_Independent
55 with System
.Tasking
.Initialization
;
56 -- Used for Defer_Abort
59 with System
.Tasking
.Debug
;
62 with System
.OS_Primitives
;
63 -- used for Max_Sensible_Delay
65 with Ada
.Task_Identification
;
66 -- used for Task_ID type
68 with System
.Parameters
;
69 -- used for Single_Lock
72 with System
.Traces
.Tasking
;
73 -- used for Send_Trace_Info
75 with Unchecked_Conversion
;
77 package body System
.Tasking
.Async_Delays
is
79 package STPO
renames System
.Task_Primitives
.Operations
;
80 package ST
renames System
.Tasking
;
81 package STU
renames System
.Tasking
.Utilities
;
82 package STI
renames System
.Tasking
.Initialization
;
83 package OSP
renames System
.OS_Primitives
;
87 use System
.Traces
.Tasking
;
89 function To_System
is new Unchecked_Conversion
90 (Ada
.Task_Identification
.Task_Id
, Task_ID
);
92 Timer_Server_ID
: ST
.Task_ID
;
94 Timer_Attention
: Boolean := False;
95 pragma Atomic
(Timer_Attention
);
98 pragma Interrupt_Priority
(System
.Any_Priority
'Last);
101 -- The timer queue is a circular doubly linked list, ordered by absolute
102 -- wakeup time. The first item in the queue is Timer_Queue.Succ.
103 -- It is given a Resume_Time that is larger than any legitimate wakeup
104 -- time, so that the ordered insertion will always stop searching when it
105 -- gets back to the queue header block.
107 Timer_Queue
: aliased Delay_Block
;
109 ------------------------
110 -- Cancel_Async_Delay --
111 ------------------------
113 -- This should (only) be called from the compiler-generated cleanup routine
114 -- for an async. select statement with delay statement as trigger. The
115 -- effect should be to remove the delay from the timer queue, and exit one
116 -- ATC nesting level.
117 -- The usage and logic are similar to Cancel_Protected_Entry_Call, but
118 -- simplified because this is not a true entry call.
120 procedure Cancel_Async_Delay
(D
: Delay_Block_Access
) is
121 Dpred
: Delay_Block_Access
;
122 Dsucc
: Delay_Block_Access
;
125 -- Note that we mark the delay as being cancelled
126 -- using a level value that is reserved.
128 -- make this operation idempotent
130 if D
.Level
= ATC_Level_Infinity
then
134 D
.Level
:= ATC_Level_Infinity
;
136 -- remove self from timer queue
138 STI
.Defer_Abort_Nestable
(D
.Self_Id
);
144 STPO
.Write_Lock
(Timer_Server_ID
);
151 STPO
.Unlock
(Timer_Server_ID
);
153 -- Note that the above deletion code is required to be
154 -- idempotent, since the block may have been dequeued
155 -- previously by the Timer_Server.
157 -- leave the asynchronous select
159 STPO
.Write_Lock
(D
.Self_Id
);
160 STU
.Exit_One_ATC_Level
(D
.Self_Id
);
161 STPO
.Unlock
(D
.Self_Id
);
167 STI
.Undefer_Abort_Nestable
(D
.Self_Id
);
168 end Cancel_Async_Delay
;
170 ---------------------------
171 -- Enqueue_Time_Duration --
172 ---------------------------
174 function Enqueue_Duration
176 D
: Delay_Block_Access
)
186 -- The corresponding call to Undefer_Abort is performed by the
187 -- expanded code (see exp_ch9).
189 STI
.Defer_Abort
(STPO
.Self
);
191 (STPO
.Monotonic_Clock
192 + Duration'Min (T
, OSP
.Max_Sensible_Delay
), D
);
195 end Enqueue_Duration
;
201 -- Allocate a queue element for the wakeup time T and put it in the
202 -- queue in wakeup time order. Assume we are on an asynchronous
203 -- select statement with delay trigger. Put the calling task to
204 -- sleep until either the delay expires or is cancelled.
206 -- We use one entry call record for this delay, since we have
207 -- to increment the ATC nesting level, but since it is not a
208 -- real entry call we do not need to use any of the fields of
209 -- the call record. The following code implements a subset of
210 -- the actions for the asynchronous case of Protected_Entry_Call,
211 -- much simplified since we know this never blocks, and does not
212 -- have the full semantics of a protected entry call.
214 procedure Time_Enqueue
216 D
: Delay_Block_Access
)
218 Self_Id
: constant Task_ID
:= STPO
.Self
;
219 Q
: Delay_Block_Access
;
222 -- for visibility of operator "="
225 pragma Debug
(Debug
.Trace
(Self_Id
, "Async_Delay", 'P'));
226 pragma Assert
(Self_Id
.Deferral_Level
= 1,
227 "async delay from within abort-deferred region");
229 if Self_Id
.ATC_Nesting_Level
= ATC_Level
'Last then
230 Ada
.Exceptions
.Raise_Exception
(Storage_Error
'Identity,
231 "not enough ATC nesting levels");
234 Self_Id
.ATC_Nesting_Level
:= Self_Id
.ATC_Nesting_Level
+ 1;
237 (Debug
.Trace
(Self_Id
, "ASD: entered ATC level: " &
238 ATC_Level
'Image (Self_Id
.ATC_Nesting_Level
), 'A'));
240 D
.Level
:= Self_Id
.ATC_Nesting_Level
;
241 D
.Self_Id
:= Self_Id
;
248 STPO
.Write_Lock
(Timer_Server_ID
);
250 -- Previously, there was code here to dynamically create
251 -- the Timer_Server task, if one did not already exist.
252 -- That code had a timing window that could allow multiple
253 -- timer servers to be created. Luckily, the need for
254 -- postponing creation of the timer server should now be
255 -- gone, since this package will only be linked in if
256 -- there are calls to enqueue calls on the timer server.
258 -- Insert D in the timer queue, at the position determined
259 -- by the wakeup time T.
261 Q
:= Timer_Queue
.Succ
;
263 while Q
.Resume_Time
< T
loop
267 -- Q is the block that has Resume_Time equal to or greater than
268 -- T. After the insertion we want Q to be the successor of D.
275 -- If the new element became the head of the queue,
276 -- signal the Timer_Server to wake up.
278 if Timer_Queue
.Succ
= D
then
279 Timer_Attention
:= True;
280 STPO
.Wakeup
(Timer_Server_ID
, ST
.Timer_Server_Sleep
);
283 STPO
.Unlock
(Timer_Server_ID
);
294 function Timed_Out
(D
: Delay_Block_Access
) return Boolean is
303 task body Timer_Server
is
304 function Get_Next_Wakeup_Time
return Duration;
305 -- Used to initialize Next_Wakeup_Time, but also to ensure that
306 -- Make_Independent is called during the elaboration of this task
308 --------------------------
309 -- Get_Next_Wakeup_Time --
310 --------------------------
312 function Get_Next_Wakeup_Time
return Duration is
314 STU
.Make_Independent
;
315 return Duration'Last;
316 end Get_Next_Wakeup_Time
;
318 Next_Wakeup_Time
: Duration := Get_Next_Wakeup_Time
;
324 Tsucc
: Delay_Block_Access
;
325 Dequeued_Task
: Task_ID
;
328 Timer_Server_ID
:= STPO
.Self
;
330 -- Initialize the timer queue to empty, and make the wakeup time of the
331 -- header node be larger than any real wakeup time we will ever use.
334 STI
.Defer_Abort
(Timer_Server_ID
);
340 STPO
.Write_Lock
(Timer_Server_ID
);
342 -- The timer server needs to catch pending aborts after finalization
343 -- of library packages. If it doesn't poll for it, the server will
346 if not Timer_Attention
then
347 Timer_Server_ID
.Common
.State
:= ST
.Timer_Server_Sleep
;
349 if Next_Wakeup_Time
= Duration'Last then
350 Timer_Server_ID
.User_State
:= 1;
352 STPO
.Monotonic_Clock
+ OSP
.Max_Sensible_Delay
;
355 Timer_Server_ID
.User_State
:= 2;
359 (Timer_Server_ID
, Next_Wakeup_Time
,
360 OSP
.Absolute_RT
, ST
.Timer_Server_Sleep
,
362 Timer_Server_ID
.Common
.State
:= ST
.Runnable
;
365 -- Service all of the wakeup requests on the queue whose times have
366 -- been reached, and update Next_Wakeup_Time to next wakeup time
367 -- after that (the wakeup time of the head of the queue if any, else
368 -- a time far in the future).
370 Timer_Server_ID
.User_State
:= 3;
371 Timer_Attention
:= False;
373 Now
:= STPO
.Monotonic_Clock
;
375 while Timer_Queue
.Succ
.Resume_Time
<= Now
loop
377 -- Dequeue the waiting task from the front of the queue.
379 pragma Debug
(System
.Tasking
.Debug
.Trace
380 ("Timer service: waking up waiting task", 'E'));
382 Dequeued
:= Timer_Queue
.Succ
;
383 Timer_Queue
.Succ
:= Dequeued
.Succ
;
384 Dequeued
.Succ
.Pred
:= Dequeued
.Pred
;
385 Dequeued
.Succ
:= Dequeued
;
386 Dequeued
.Pred
:= Dequeued
;
388 -- We want to abort the queued task to the level of the async.
389 -- select statement with the delay. To do that, we need to lock
390 -- the ATCB of that task, but to avoid deadlock we need to release
391 -- the lock of the Timer_Server. This leaves a window in which
392 -- another task might perform an enqueue or dequeue operation on
393 -- the timer queue, but that is OK because we always restart the
394 -- next iteration at the head of the queue.
396 if Parameters
.Runtime_Traces
then
397 Send_Trace_Info
(E_Kill
, Dequeued
.Self_Id
);
400 STPO
.Unlock
(Timer_Server_ID
);
401 STPO
.Write_Lock
(Dequeued
.Self_Id
);
402 Dequeued_Task
:= Dequeued
.Self_Id
;
403 Dequeued
.Timed_Out
:= True;
404 STI
.Locked_Abort_To_Level
405 (Timer_Server_ID
, Dequeued_Task
, Dequeued
.Level
- 1);
406 STPO
.Unlock
(Dequeued_Task
);
407 STPO
.Write_Lock
(Timer_Server_ID
);
410 Next_Wakeup_Time
:= Timer_Queue
.Succ
.Resume_Time
;
412 -- Service returns the Next_Wakeup_Time.
413 -- The Next_Wakeup_Time is either an infinity (no delay request)
414 -- or the wakeup time of the queue head. This value is used for
415 -- an actual delay in this server.
417 STPO
.Unlock
(Timer_Server_ID
);
423 STI
.Undefer_Abort
(Timer_Server_ID
);
427 ------------------------------
428 -- Package Body Elaboration --
429 ------------------------------
432 Timer_Queue
.Succ
:= Timer_Queue
'Unchecked_Access;
433 Timer_Queue
.Pred
:= Timer_Queue
'Unchecked_Access;
434 Timer_Queue
.Resume_Time
:= Duration'Last;
435 Timer_Server_ID
:= To_System
(Timer_Server
'Identity);
436 end System
.Tasking
.Async_Delays
;