]>
Commit | Line | Data |
---|---|---|
cacbc350 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
b497b460 | 3 | -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
cacbc350 RK |
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 | -- -- |
b0c5fdda | 9 | -- Copyright (C) 1998-2014, 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- -- | |
748086b7 JJ |
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- -- | |
cacbc350 | 15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
748086b7 JJ |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
17 | -- -- | |
18 | -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
19 | -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 | -- version 3.1, as published by the Free Software Foundation. -- | |
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/>. -- | |
cacbc350 | 26 | -- -- |
fbf5a39b AC |
27 | -- GNARL was developed by the GNARL team at Florida State University. -- |
28 | -- Extensive contributions were provided by Ada Core Technologies, Inc. -- | |
cacbc350 RK |
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 | ||
366b8af7 RD |
36 | with Ada.Unchecked_Conversion; |
37 | with Ada.Task_Identification; | |
cacbc350 RK |
38 | |
39 | with System.Task_Primitives.Operations; | |
cacbc350 | 40 | with System.Tasking.Utilities; |
cacbc350 | 41 | with System.Tasking.Initialization; |
cacbc350 | 42 | with System.Tasking.Debug; |
cacbc350 | 43 | with System.OS_Primitives; |
b497b460 | 44 | with System.Interrupt_Management.Operations; |
07fc65c4 | 45 | with System.Parameters; |
07fc65c4 | 46 | with System.Traces.Tasking; |
cacbc350 RK |
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 | ||
07fc65c4 GB |
56 | use Parameters; |
57 | use System.Traces; | |
58 | use System.Traces.Tasking; | |
59 | ||
cecaf88a | 60 | function To_System is new Ada.Unchecked_Conversion |
b5e792e2 | 61 | (Ada.Task_Identification.Task_Id, Task_Id); |
cacbc350 | 62 | |
cacbc350 RK |
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 | ||
b0c5fdda AC |
70 | Timer_Server_ID : constant ST.Task_Id := To_System (Timer_Server'Identity); |
71 | ||
cacbc350 RK |
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 | ||
fccaf220 | 78 | Timer_Queue : aliased Delay_Block; |
b0c5fdda | 79 | |
fccaf220 BD |
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 | |
b0c5fdda | 89 | begin |
fccaf220 BD |
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; | |
cacbc350 RK |
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); | |
07fc65c4 GB |
125 | |
126 | if Single_Lock then | |
127 | STPO.Lock_RTS; | |
128 | end if; | |
129 | ||
cacbc350 RK |
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); | |
07fc65c4 GB |
148 | |
149 | if Single_Lock then | |
150 | STPO.Unlock_RTS; | |
151 | end if; | |
152 | ||
cacbc350 RK |
153 | STI.Undefer_Abort_Nestable (D.Self_Id); |
154 | end Cancel_Async_Delay; | |
155 | ||
f9648959 AC |
156 | ---------------------- |
157 | -- Enqueue_Duration -- | |
158 | ---------------------- | |
cacbc350 RK |
159 | |
160 | function Enqueue_Duration | |
0ae9f22f RD |
161 | (T : Duration; |
162 | D : Delay_Block_Access) return Boolean | |
cacbc350 RK |
163 | is |
164 | begin | |
165 | if T <= 0.0 then | |
166 | D.Timed_Out := True; | |
167 | STPO.Yield; | |
168 | return False; | |
169 | ||
170 | else | |
07fc65c4 GB |
171 | -- The corresponding call to Undefer_Abort is performed by the |
172 | -- expanded code (see exp_ch9). | |
173 | ||
cacbc350 RK |
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 | |
b5e792e2 | 203 | Self_Id : constant Task_Id := STPO.Self; |
cacbc350 RK |
204 | Q : Delay_Block_Access; |
205 | ||
b5e792e2 | 206 | use type ST.Task_Id; |
cacbc350 RK |
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 | |
366b8af7 | 215 | raise Storage_Error with "not enough ATC nesting levels"; |
cacbc350 RK |
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 | ||
07fc65c4 GB |
228 | if Single_Lock then |
229 | STPO.Lock_RTS; | |
230 | end if; | |
231 | ||
cacbc350 RK |
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); | |
07fc65c4 GB |
268 | |
269 | if Single_Lock then | |
270 | STPO.Unlock_RTS; | |
271 | end if; | |
cacbc350 RK |
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 | |
b0c5fdda | 288 | Ignore : constant Boolean := STU.Make_Independent; |
07fc65c4 | 289 | |
67ce0d7e RD |
290 | -- Local Declarations |
291 | ||
b0c5fdda | 292 | Next_Wakeup_Time : Duration := Duration'Last; |
cacbc350 RK |
293 | Timedout : Boolean; |
294 | Yielded : Boolean; | |
295 | Now : Duration; | |
fbf5a39b | 296 | Dequeued : Delay_Block_Access; |
b5e792e2 | 297 | Dequeued_Task : Task_Id; |
cacbc350 | 298 | |
67ce0d7e RD |
299 | pragma Unreferenced (Timedout, Yielded); |
300 | ||
cacbc350 | 301 | begin |
b0c5fdda | 302 | pragma Assert (Timer_Server_ID = STPO.Self); |
cacbc350 | 303 | |
b497b460 JR |
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 | ||
cacbc350 RK |
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); | |
07fc65c4 GB |
315 | |
316 | if Single_Lock then | |
317 | STPO.Lock_RTS; | |
318 | end if; | |
319 | ||
cacbc350 RK |
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; | |
cacbc350 RK |
354 | while Timer_Queue.Succ.Resume_Time <= Now loop |
355 | ||
0ae9f22f | 356 | -- Dequeue the waiting task from the front of the queue |
cacbc350 RK |
357 | |
358 | pragma Debug (System.Tasking.Debug.Trace | |
fbf5a39b | 359 | (Timer_Server_ID, "Timer service: waking up waiting task", 'E')); |
cacbc350 RK |
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 | ||
07fc65c4 GB |
375 | if Parameters.Runtime_Traces then |
376 | Send_Trace_Info (E_Kill, Dequeued.Self_Id); | |
377 | end if; | |
378 | ||
cacbc350 RK |
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); | |
07fc65c4 GB |
397 | |
398 | if Single_Lock then | |
399 | STPO.Unlock_RTS; | |
400 | end if; | |
401 | ||
cacbc350 RK |
402 | STI.Undefer_Abort (Timer_Server_ID); |
403 | end loop; | |
404 | end Timer_Server; | |
405 | ||
cacbc350 | 406 | end System.Tasking.Async_Delays; |