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 --
11 -- Copyright (C) 1998-2002, Free Software Foundation, Inc. --
13 -- GNARL is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNARL; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNARL was developed by the GNARL team at Florida State University. It is --
32 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
37 -- Turn off polling, we do not want ATC polling to take place during
38 -- tasking operations. It causes infinite loops and other problems.
41 -- Used for Raise_Exception
43 with System.Task_Primitives.Operations;
44 -- Used for Write_Lock,
53 with System.Tasking.Utilities;
54 -- Used for Make_Independent
56 with System.Tasking.Initialization;
57 -- Used for Defer_Abort
60 with System.Tasking.Debug;
63 with System.OS_Primitives;
64 -- used for Max_Sensible_Delay
66 with Ada.Task_Identification;
67 -- used for Task_ID type
69 with System.Parameters;
70 -- used for Single_Lock
73 with System.Traces.Tasking;
74 -- used for Send_Trace_Info
76 with Unchecked_Conversion;
78 package body System.Tasking.Async_Delays is
80 package STPO renames System.Task_Primitives.Operations;
81 package ST renames System.Tasking;
82 package STU renames System.Tasking.Utilities;
83 package STI renames System.Tasking.Initialization;
84 package OSP renames System.OS_Primitives;
88 use System.Traces.Tasking;
90 function To_System is new Unchecked_Conversion
91 (Ada.Task_Identification.Task_Id, Task_ID);
93 Timer_Server_ID : ST.Task_ID;
95 Timer_Attention : Boolean := False;
96 pragma Atomic (Timer_Attention);
99 pragma Interrupt_Priority (System.Any_Priority'Last);
102 -- The timer queue is a circular doubly linked list, ordered by absolute
103 -- wakeup time. The first item in the queue is Timer_Queue.Succ.
104 -- It is given a Resume_Time that is larger than any legitimate wakeup
105 -- time, so that the ordered insertion will always stop searching when it
106 -- gets back to the queue header block.
108 Timer_Queue : aliased Delay_Block;
110 ------------------------
111 -- Cancel_Async_Delay --
112 ------------------------
114 -- This should (only) be called from the compiler-generated cleanup routine
115 -- for an async. select statement with delay statement as trigger. The
116 -- effect should be to remove the delay from the timer queue, and exit one
117 -- ATC nesting level.
118 -- The usage and logic are similar to Cancel_Protected_Entry_Call, but
119 -- simplified because this is not a true entry call.
121 procedure Cancel_Async_Delay (D : Delay_Block_Access) is
122 Dpred : Delay_Block_Access;
123 Dsucc : Delay_Block_Access;
126 -- Note that we mark the delay as being cancelled
127 -- using a level value that is reserved.
129 -- make this operation idempotent
131 if D.Level = ATC_Level_Infinity then
135 D.Level := ATC_Level_Infinity;
137 -- remove self from timer queue
139 STI.Defer_Abort_Nestable (D.Self_Id);
145 STPO.Write_Lock (Timer_Server_ID);
152 STPO.Unlock (Timer_Server_ID);
154 -- Note that the above deletion code is required to be
155 -- idempotent, since the block may have been dequeued
156 -- previously by the Timer_Server.
158 -- leave the asynchronous select
160 STPO.Write_Lock (D.Self_Id);
161 STU.Exit_One_ATC_Level (D.Self_Id);
162 STPO.Unlock (D.Self_Id);
168 STI.Undefer_Abort_Nestable (D.Self_Id);
169 end Cancel_Async_Delay;
171 ---------------------------
172 -- Enqueue_Time_Duration --
173 ---------------------------
175 function Enqueue_Duration
177 D : Delay_Block_Access)
187 -- The corresponding call to Undefer_Abort is performed by the
188 -- expanded code (see exp_ch9).
190 STI.Defer_Abort (STPO.Self);
192 (STPO.Monotonic_Clock
193 + Duration'Min (T, OSP.Max_Sensible_Delay), D);
196 end Enqueue_Duration;
202 -- Allocate a queue element for the wakeup time T and put it in the
203 -- queue in wakeup time order. Assume we are on an asynchronous
204 -- select statement with delay trigger. Put the calling task to
205 -- sleep until either the delay expires or is cancelled.
207 -- We use one entry call record for this delay, since we have
208 -- to increment the ATC nesting level, but since it is not a
209 -- real entry call we do not need to use any of the fields of
210 -- the call record. The following code implements a subset of
211 -- the actions for the asynchronous case of Protected_Entry_Call,
212 -- much simplified since we know this never blocks, and does not
213 -- have the full semantics of a protected entry call.
215 procedure Time_Enqueue
217 D : Delay_Block_Access)
219 Self_Id : constant Task_ID := STPO.Self;
220 Q : Delay_Block_Access;
223 -- for visibility of operator "="
226 pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P'));
227 pragma Assert (Self_Id.Deferral_Level = 1,
228 "async delay from within abort-deferred region");
230 if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
231 Ada.Exceptions.Raise_Exception (Storage_Error'Identity,
232 "not enough ATC nesting levels");
235 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
238 (Debug.Trace (Self_Id, "ASD: entered ATC level: " &
239 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
241 D.Level := Self_Id.ATC_Nesting_Level;
242 D.Self_Id := Self_Id;
249 STPO.Write_Lock (Timer_Server_ID);
251 -- Previously, there was code here to dynamically create
252 -- the Timer_Server task, if one did not already exist.
253 -- That code had a timing window that could allow multiple
254 -- timer servers to be created. Luckily, the need for
255 -- postponing creation of the timer server should now be
256 -- gone, since this package will only be linked in if
257 -- there are calls to enqueue calls on the timer server.
259 -- Insert D in the timer queue, at the position determined
260 -- by the wakeup time T.
262 Q := Timer_Queue.Succ;
264 while Q.Resume_Time < T loop
268 -- Q is the block that has Resume_Time equal to or greater than
269 -- T. After the insertion we want Q to be the successor of D.
276 -- If the new element became the head of the queue,
277 -- signal the Timer_Server to wake up.
279 if Timer_Queue.Succ = D then
280 Timer_Attention := True;
281 STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep);
284 STPO.Unlock (Timer_Server_ID);
295 function Timed_Out (D : Delay_Block_Access) return Boolean is
304 task body Timer_Server is
305 function Get_Next_Wakeup_Time return Duration;
306 -- Used to initialize Next_Wakeup_Time, but also to ensure that
307 -- Make_Independent is called during the elaboration of this task
309 --------------------------
310 -- Get_Next_Wakeup_Time --
311 --------------------------
313 function Get_Next_Wakeup_Time return Duration is
315 STU.Make_Independent;
316 return Duration'Last;
317 end Get_Next_Wakeup_Time;
319 Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time;
325 Tsucc : Delay_Block_Access;
326 Dequeued_Task : Task_ID;
329 Timer_Server_ID := STPO.Self;
331 -- Initialize the timer queue to empty, and make the wakeup time of the
332 -- header node be larger than any real wakeup time we will ever use.
335 STI.Defer_Abort (Timer_Server_ID);
341 STPO.Write_Lock (Timer_Server_ID);
343 -- The timer server needs to catch pending aborts after finalization
344 -- of library packages. If it doesn't poll for it, the server will
347 if not Timer_Attention then
348 Timer_Server_ID.Common.State := ST.Timer_Server_Sleep;
350 if Next_Wakeup_Time = Duration'Last then
351 Timer_Server_ID.User_State := 1;
353 STPO.Monotonic_Clock + OSP.Max_Sensible_Delay;
356 Timer_Server_ID.User_State := 2;
360 (Timer_Server_ID, Next_Wakeup_Time,
361 OSP.Absolute_RT, ST.Timer_Server_Sleep,
363 Timer_Server_ID.Common.State := ST.Runnable;
366 -- Service all of the wakeup requests on the queue whose times have
367 -- been reached, and update Next_Wakeup_Time to next wakeup time
368 -- after that (the wakeup time of the head of the queue if any, else
369 -- a time far in the future).
371 Timer_Server_ID.User_State := 3;
372 Timer_Attention := False;
374 Now := STPO.Monotonic_Clock;
376 while Timer_Queue.Succ.Resume_Time <= Now loop
378 -- Dequeue the waiting task from the front of the queue.
380 pragma Debug (System.Tasking.Debug.Trace
381 ("Timer service: waking up waiting task", 'E'));
383 Dequeued := Timer_Queue.Succ;
384 Timer_Queue.Succ := Dequeued.Succ;
385 Dequeued.Succ.Pred := Dequeued.Pred;
386 Dequeued.Succ := Dequeued;
387 Dequeued.Pred := Dequeued;
389 -- We want to abort the queued task to the level of the async.
390 -- select statement with the delay. To do that, we need to lock
391 -- the ATCB of that task, but to avoid deadlock we need to release
392 -- the lock of the Timer_Server. This leaves a window in which
393 -- another task might perform an enqueue or dequeue operation on
394 -- the timer queue, but that is OK because we always restart the
395 -- next iteration at the head of the queue.
397 if Parameters.Runtime_Traces then
398 Send_Trace_Info (E_Kill, Dequeued.Self_Id);
401 STPO.Unlock (Timer_Server_ID);
402 STPO.Write_Lock (Dequeued.Self_Id);
403 Dequeued_Task := Dequeued.Self_Id;
404 Dequeued.Timed_Out := True;
405 STI.Locked_Abort_To_Level
406 (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1);
407 STPO.Unlock (Dequeued_Task);
408 STPO.Write_Lock (Timer_Server_ID);
411 Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time;
413 -- Service returns the Next_Wakeup_Time.
414 -- The Next_Wakeup_Time is either an infinity (no delay request)
415 -- or the wakeup time of the queue head. This value is used for
416 -- an actual delay in this server.
418 STPO.Unlock (Timer_Server_ID);
424 STI.Undefer_Abort (Timer_Server_ID);
428 ------------------------------
429 -- Package Body Elaboration --
430 ------------------------------
433 Timer_Queue.Succ := Timer_Queue'Unchecked_Access;
434 Timer_Queue.Pred := Timer_Queue'Unchecked_Access;
435 Timer_Queue.Resume_Time := Duration'Last;
436 Timer_Server_ID := To_System (Timer_Server'Identity);
437 end System.Tasking.Async_Delays;