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