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-2007, 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
35 -- Turn off polling, we do not want ATC polling to take place during
36 -- tasking operations. It causes infinite loops and other problems.
39 -- Used for Raise_Exception
41 with System.Task_Primitives.Operations;
42 -- Used for Write_Lock,
51 with System.Tasking.Utilities;
52 -- Used for Make_Independent
54 with System.Tasking.Initialization;
55 -- Used for Defer_Abort
58 with System.Tasking.Debug;
61 with System.OS_Primitives;
62 -- used for Max_Sensible_Delay
64 with Ada.Task_Identification;
65 -- used for Task_Id type
67 with System.Interrupt_Management.Operations;
68 -- used for Setup_Interrupt_Mask
70 with System.Parameters;
71 -- used for Single_Lock
74 with System.Traces.Tasking;
75 -- used for Send_Trace_Info
77 with Ada.Unchecked_Conversion;
79 package body System.Tasking.Async_Delays is
81 package STPO renames System.Task_Primitives.Operations;
82 package ST renames System.Tasking;
83 package STU renames System.Tasking.Utilities;
84 package STI renames System.Tasking.Initialization;
85 package OSP renames System.OS_Primitives;
89 use System.Traces.Tasking;
91 function To_System is new Ada.Unchecked_Conversion
92 (Ada.Task_Identification.Task_Id, Task_Id);
94 Timer_Server_ID : ST.Task_Id;
96 Timer_Attention : Boolean := False;
97 pragma Atomic (Timer_Attention);
100 pragma Interrupt_Priority (System.Any_Priority'Last);
103 -- The timer queue is a circular doubly linked list, ordered by absolute
104 -- wakeup time. The first item in the queue is Timer_Queue.Succ.
105 -- It is given a Resume_Time that is larger than any legitimate wakeup
106 -- time, so that the ordered insertion will always stop searching when it
107 -- gets back to the queue header block.
109 Timer_Queue : aliased Delay_Block;
111 ------------------------
112 -- Cancel_Async_Delay --
113 ------------------------
115 -- This should (only) be called from the compiler-generated cleanup routine
116 -- for an async. select statement with delay statement as trigger. The
117 -- effect should be to remove the delay from the timer queue, and exit one
118 -- ATC nesting level.
119 -- The usage and logic are similar to Cancel_Protected_Entry_Call, but
120 -- simplified because this is not a true entry call.
122 procedure Cancel_Async_Delay (D : Delay_Block_Access) is
123 Dpred : Delay_Block_Access;
124 Dsucc : Delay_Block_Access;
127 -- Note that we mark the delay as being cancelled
128 -- using a level value that is reserved.
130 -- make this operation idempotent
132 if D.Level = ATC_Level_Infinity then
136 D.Level := ATC_Level_Infinity;
138 -- remove self from timer queue
140 STI.Defer_Abort_Nestable (D.Self_Id);
146 STPO.Write_Lock (Timer_Server_ID);
153 STPO.Unlock (Timer_Server_ID);
155 -- Note that the above deletion code is required to be
156 -- idempotent, since the block may have been dequeued
157 -- previously by the Timer_Server.
159 -- leave the asynchronous select
161 STPO.Write_Lock (D.Self_Id);
162 STU.Exit_One_ATC_Level (D.Self_Id);
163 STPO.Unlock (D.Self_Id);
169 STI.Undefer_Abort_Nestable (D.Self_Id);
170 end Cancel_Async_Delay;
172 ---------------------------
173 -- Enqueue_Time_Duration --
174 ---------------------------
176 function Enqueue_Duration
178 D : Delay_Block_Access) return Boolean
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;
323 Dequeued : Delay_Block_Access;
324 Dequeued_Task : Task_Id;
327 Timer_Server_ID := STPO.Self;
329 -- Since this package may be elaborated before System.Interrupt,
330 -- we need to call Setup_Interrupt_Mask explicitly to ensure that
331 -- this task has the proper signal mask.
333 Interrupt_Management.Operations.Setup_Interrupt_Mask;
335 -- Initialize the timer queue to empty, and make the wakeup time of the
336 -- header node be larger than any real wakeup time we will ever use.
339 STI.Defer_Abort (Timer_Server_ID);
345 STPO.Write_Lock (Timer_Server_ID);
347 -- The timer server needs to catch pending aborts after finalization
348 -- of library packages. If it doesn't poll for it, the server will
351 if not Timer_Attention then
352 Timer_Server_ID.Common.State := ST.Timer_Server_Sleep;
354 if Next_Wakeup_Time = Duration'Last then
355 Timer_Server_ID.User_State := 1;
357 STPO.Monotonic_Clock + OSP.Max_Sensible_Delay;
360 Timer_Server_ID.User_State := 2;
364 (Timer_Server_ID, Next_Wakeup_Time,
365 OSP.Absolute_RT, ST.Timer_Server_Sleep,
367 Timer_Server_ID.Common.State := ST.Runnable;
370 -- Service all of the wakeup requests on the queue whose times have
371 -- been reached, and update Next_Wakeup_Time to next wakeup time
372 -- after that (the wakeup time of the head of the queue if any, else
373 -- a time far in the future).
375 Timer_Server_ID.User_State := 3;
376 Timer_Attention := False;
378 Now := STPO.Monotonic_Clock;
380 while Timer_Queue.Succ.Resume_Time <= Now loop
382 -- Dequeue the waiting task from the front of the queue
384 pragma Debug (System.Tasking.Debug.Trace
385 (Timer_Server_ID, "Timer service: waking up waiting task", 'E'));
387 Dequeued := Timer_Queue.Succ;
388 Timer_Queue.Succ := Dequeued.Succ;
389 Dequeued.Succ.Pred := Dequeued.Pred;
390 Dequeued.Succ := Dequeued;
391 Dequeued.Pred := Dequeued;
393 -- We want to abort the queued task to the level of the async.
394 -- select statement with the delay. To do that, we need to lock
395 -- the ATCB of that task, but to avoid deadlock we need to release
396 -- the lock of the Timer_Server. This leaves a window in which
397 -- another task might perform an enqueue or dequeue operation on
398 -- the timer queue, but that is OK because we always restart the
399 -- next iteration at the head of the queue.
401 if Parameters.Runtime_Traces then
402 Send_Trace_Info (E_Kill, Dequeued.Self_Id);
405 STPO.Unlock (Timer_Server_ID);
406 STPO.Write_Lock (Dequeued.Self_Id);
407 Dequeued_Task := Dequeued.Self_Id;
408 Dequeued.Timed_Out := True;
409 STI.Locked_Abort_To_Level
410 (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1);
411 STPO.Unlock (Dequeued_Task);
412 STPO.Write_Lock (Timer_Server_ID);
415 Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time;
417 -- Service returns the Next_Wakeup_Time.
418 -- The Next_Wakeup_Time is either an infinity (no delay request)
419 -- or the wakeup time of the queue head. This value is used for
420 -- an actual delay in this server.
422 STPO.Unlock (Timer_Server_ID);
428 STI.Undefer_Abort (Timer_Server_ID);
432 ------------------------------
433 -- Package Body Elaboration --
434 ------------------------------
437 Timer_Queue.Succ := Timer_Queue'Unchecked_Access;
438 Timer_Queue.Pred := Timer_Queue'Unchecked_Access;
439 Timer_Queue.Resume_Time := Duration'Last;
440 Timer_Server_ID := To_System (Timer_Server'Identity);
441 end System.Tasking.Async_Delays;