File : s-taasde.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
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 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
10 -- --
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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 pragma Polling (Off);
33 -- Turn off polling, we do not want ATC polling to take place during
34 -- tasking operations. It causes infinite loops and other problems.
35
36 with Ada.Unchecked_Conversion;
37 with Ada.Task_Identification;
38
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;
45 with System.Parameters;
46 with System.Traces.Tasking;
47
48 package body System.Tasking.Async_Delays is
49
50 package STPO renames System.Task_Primitives.Operations;
51 package ST renames System.Tasking;
52 package STU renames System.Tasking.Utilities;
53 package STI renames System.Tasking.Initialization;
54 package OSP renames System.OS_Primitives;
55
56 use Parameters;
57 use System.Traces;
58 use System.Traces.Tasking;
59
60 function To_System is new Ada.Unchecked_Conversion
61 (Ada.Task_Identification.Task_Id, Task_Id);
62
63 Timer_Attention : Boolean := False;
64 pragma Atomic (Timer_Attention);
65
66 task Timer_Server is
67 pragma Interrupt_Priority (System.Any_Priority'Last);
68 end Timer_Server;
69
70 Timer_Server_ID : constant ST.Task_Id := To_System (Timer_Server'Identity);
71
72 -- The timer queue is a circular doubly linked list, ordered by absolute
73 -- wakeup time. The first item in the queue is Timer_Queue.Succ.
74 -- It is given a Resume_Time that is larger than any legitimate wakeup
75 -- time, so that the ordered insertion will always stop searching when it
76 -- gets back to the queue header block.
77
78 Timer_Queue : aliased Delay_Block;
79
80 package Init_Timer_Queue is end Init_Timer_Queue;
81 pragma Unreferenced (Init_Timer_Queue);
82 -- Initialize the Timer_Queue. This is a package to work around the
83 -- fact that statements are syntactically illegal here. We want this
84 -- initialization to happen before the Timer_Server is activated. A
85 -- build-in-place function would also work, but that's not supported
86 -- on all platforms (e.g. cil).
87
88 package body Init_Timer_Queue is
89 begin
90 Timer_Queue.Succ := Timer_Queue'Unchecked_Access;
91 Timer_Queue.Pred := Timer_Queue'Unchecked_Access;
92 Timer_Queue.Resume_Time := Duration'Last;
93 end Init_Timer_Queue;
94
95 ------------------------
96 -- Cancel_Async_Delay --
97 ------------------------
98
99 -- This should (only) be called from the compiler-generated cleanup routine
100 -- for an async. select statement with delay statement as trigger. The
101 -- effect should be to remove the delay from the timer queue, and exit one
102 -- ATC nesting level.
103 -- The usage and logic are similar to Cancel_Protected_Entry_Call, but
104 -- simplified because this is not a true entry call.
105
106 procedure Cancel_Async_Delay (D : Delay_Block_Access) is
107 Dpred : Delay_Block_Access;
108 Dsucc : Delay_Block_Access;
109
110 begin
111 -- Note that we mark the delay as being cancelled
112 -- using a level value that is reserved.
113
114 -- make this operation idempotent
115
116 if D.Level = ATC_Level_Infinity then
117 return;
118 end if;
119
120 D.Level := ATC_Level_Infinity;
121
122 -- remove self from timer queue
123
124 STI.Defer_Abort_Nestable (D.Self_Id);
125
126 if Single_Lock then
127 STPO.Lock_RTS;
128 end if;
129
130 STPO.Write_Lock (Timer_Server_ID);
131 Dpred := D.Pred;
132 Dsucc := D.Succ;
133 Dpred.Succ := Dsucc;
134 Dsucc.Pred := Dpred;
135 D.Succ := D;
136 D.Pred := D;
137 STPO.Unlock (Timer_Server_ID);
138
139 -- Note that the above deletion code is required to be
140 -- idempotent, since the block may have been dequeued
141 -- previously by the Timer_Server.
142
143 -- leave the asynchronous select
144
145 STPO.Write_Lock (D.Self_Id);
146 STU.Exit_One_ATC_Level (D.Self_Id);
147 STPO.Unlock (D.Self_Id);
148
149 if Single_Lock then
150 STPO.Unlock_RTS;
151 end if;
152
153 STI.Undefer_Abort_Nestable (D.Self_Id);
154 end Cancel_Async_Delay;
155
156 ----------------------
157 -- Enqueue_Duration --
158 ----------------------
159
160 function Enqueue_Duration
161 (T : Duration;
162 D : Delay_Block_Access) return Boolean
163 is
164 begin
165 if T <= 0.0 then
166 D.Timed_Out := True;
167 STPO.Yield;
168 return False;
169
170 else
171 -- The corresponding call to Undefer_Abort is performed by the
172 -- expanded code (see exp_ch9).
173
174 STI.Defer_Abort (STPO.Self);
175 Time_Enqueue
176 (STPO.Monotonic_Clock
177 + Duration'Min (T, OSP.Max_Sensible_Delay), D);
178 return True;
179 end if;
180 end Enqueue_Duration;
181
182 ------------------
183 -- Time_Enqueue --
184 ------------------
185
186 -- Allocate a queue element for the wakeup time T and put it in the
187 -- queue in wakeup time order. Assume we are on an asynchronous
188 -- select statement with delay trigger. Put the calling task to
189 -- sleep until either the delay expires or is cancelled.
190
191 -- We use one entry call record for this delay, since we have
192 -- to increment the ATC nesting level, but since it is not a
193 -- real entry call we do not need to use any of the fields of
194 -- the call record. The following code implements a subset of
195 -- the actions for the asynchronous case of Protected_Entry_Call,
196 -- much simplified since we know this never blocks, and does not
197 -- have the full semantics of a protected entry call.
198
199 procedure Time_Enqueue
200 (T : Duration;
201 D : Delay_Block_Access)
202 is
203 Self_Id : constant Task_Id := STPO.Self;
204 Q : Delay_Block_Access;
205
206 use type ST.Task_Id;
207 -- for visibility of operator "="
208
209 begin
210 pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P'));
211 pragma Assert (Self_Id.Deferral_Level = 1,
212 "async delay from within abort-deferred region");
213
214 if Self_Id.ATC_Nesting_Level = ATC_Level'Last then
215 raise Storage_Error with "not enough ATC nesting levels";
216 end if;
217
218 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1;
219
220 pragma Debug
221 (Debug.Trace (Self_Id, "ASD: entered ATC level: " &
222 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A'));
223
224 D.Level := Self_Id.ATC_Nesting_Level;
225 D.Self_Id := Self_Id;
226 D.Resume_Time := T;
227
228 if Single_Lock then
229 STPO.Lock_RTS;
230 end if;
231
232 STPO.Write_Lock (Timer_Server_ID);
233
234 -- Previously, there was code here to dynamically create
235 -- the Timer_Server task, if one did not already exist.
236 -- That code had a timing window that could allow multiple
237 -- timer servers to be created. Luckily, the need for
238 -- postponing creation of the timer server should now be
239 -- gone, since this package will only be linked in if
240 -- there are calls to enqueue calls on the timer server.
241
242 -- Insert D in the timer queue, at the position determined
243 -- by the wakeup time T.
244
245 Q := Timer_Queue.Succ;
246
247 while Q.Resume_Time < T loop
248 Q := Q.Succ;
249 end loop;
250
251 -- Q is the block that has Resume_Time equal to or greater than
252 -- T. After the insertion we want Q to be the successor of D.
253
254 D.Succ := Q;
255 D.Pred := Q.Pred;
256 D.Pred.Succ := D;
257 Q.Pred := D;
258
259 -- If the new element became the head of the queue,
260 -- signal the Timer_Server to wake up.
261
262 if Timer_Queue.Succ = D then
263 Timer_Attention := True;
264 STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep);
265 end if;
266
267 STPO.Unlock (Timer_Server_ID);
268
269 if Single_Lock then
270 STPO.Unlock_RTS;
271 end if;
272 end Time_Enqueue;
273
274 ---------------
275 -- Timed_Out --
276 ---------------
277
278 function Timed_Out (D : Delay_Block_Access) return Boolean is
279 begin
280 return D.Timed_Out;
281 end Timed_Out;
282
283 ------------------
284 -- Timer_Server --
285 ------------------
286
287 task body Timer_Server is
288 Ignore : constant Boolean := STU.Make_Independent;
289
290 -- Local Declarations
291
292 Next_Wakeup_Time : Duration := Duration'Last;
293 Timedout : Boolean;
294 Yielded : Boolean;
295 Now : Duration;
296 Dequeued : Delay_Block_Access;
297 Dequeued_Task : Task_Id;
298
299 pragma Unreferenced (Timedout, Yielded);
300
301 begin
302 pragma Assert (Timer_Server_ID = STPO.Self);
303
304 -- Since this package may be elaborated before System.Interrupt,
305 -- we need to call Setup_Interrupt_Mask explicitly to ensure that
306 -- this task has the proper signal mask.
307
308 Interrupt_Management.Operations.Setup_Interrupt_Mask;
309
310 -- Initialize the timer queue to empty, and make the wakeup time of the
311 -- header node be larger than any real wakeup time we will ever use.
312
313 loop
314 STI.Defer_Abort (Timer_Server_ID);
315
316 if Single_Lock then
317 STPO.Lock_RTS;
318 end if;
319
320 STPO.Write_Lock (Timer_Server_ID);
321
322 -- The timer server needs to catch pending aborts after finalization
323 -- of library packages. If it doesn't poll for it, the server will
324 -- sometimes hang.
325
326 if not Timer_Attention then
327 Timer_Server_ID.Common.State := ST.Timer_Server_Sleep;
328
329 if Next_Wakeup_Time = Duration'Last then
330 Timer_Server_ID.User_State := 1;
331 Next_Wakeup_Time :=
332 STPO.Monotonic_Clock + OSP.Max_Sensible_Delay;
333
334 else
335 Timer_Server_ID.User_State := 2;
336 end if;
337
338 STPO.Timed_Sleep
339 (Timer_Server_ID, Next_Wakeup_Time,
340 OSP.Absolute_RT, ST.Timer_Server_Sleep,
341 Timedout, Yielded);
342 Timer_Server_ID.Common.State := ST.Runnable;
343 end if;
344
345 -- Service all of the wakeup requests on the queue whose times have
346 -- been reached, and update Next_Wakeup_Time to next wakeup time
347 -- after that (the wakeup time of the head of the queue if any, else
348 -- a time far in the future).
349
350 Timer_Server_ID.User_State := 3;
351 Timer_Attention := False;
352
353 Now := STPO.Monotonic_Clock;
354 while Timer_Queue.Succ.Resume_Time <= Now loop
355
356 -- Dequeue the waiting task from the front of the queue
357
358 pragma Debug (System.Tasking.Debug.Trace
359 (Timer_Server_ID, "Timer service: waking up waiting task", 'E'));
360
361 Dequeued := Timer_Queue.Succ;
362 Timer_Queue.Succ := Dequeued.Succ;
363 Dequeued.Succ.Pred := Dequeued.Pred;
364 Dequeued.Succ := Dequeued;
365 Dequeued.Pred := Dequeued;
366
367 -- We want to abort the queued task to the level of the async.
368 -- select statement with the delay. To do that, we need to lock
369 -- the ATCB of that task, but to avoid deadlock we need to release
370 -- the lock of the Timer_Server. This leaves a window in which
371 -- another task might perform an enqueue or dequeue operation on
372 -- the timer queue, but that is OK because we always restart the
373 -- next iteration at the head of the queue.
374
375 if Parameters.Runtime_Traces then
376 Send_Trace_Info (E_Kill, Dequeued.Self_Id);
377 end if;
378
379 STPO.Unlock (Timer_Server_ID);
380 STPO.Write_Lock (Dequeued.Self_Id);
381 Dequeued_Task := Dequeued.Self_Id;
382 Dequeued.Timed_Out := True;
383 STI.Locked_Abort_To_Level
384 (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1);
385 STPO.Unlock (Dequeued_Task);
386 STPO.Write_Lock (Timer_Server_ID);
387 end loop;
388
389 Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time;
390
391 -- Service returns the Next_Wakeup_Time.
392 -- The Next_Wakeup_Time is either an infinity (no delay request)
393 -- or the wakeup time of the queue head. This value is used for
394 -- an actual delay in this server.
395
396 STPO.Unlock (Timer_Server_ID);
397
398 if Single_Lock then
399 STPO.Unlock_RTS;
400 end if;
401
402 STI.Undefer_Abort (Timer_Server_ID);
403 end loop;
404 end Timer_Server;
405
406 end System.Tasking.Async_Delays;