File : s-bbtiev.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . B B . T I M I N G _ E V E N T S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2011-2016, AdaCore --
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. 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. --
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 ------------------------------------------------------------------------------
28
29 with System.BB.CPU_Primitives.Multiprocessors;
30 with System.BB.Parameters;
31 with System.BB.Protection;
32 with System.BB.Threads;
33 with System.BB.Threads.Queues;
34
35 package body System.BB.Timing_Events is
36
37 use type System.BB.Time.Time;
38 use System.Multiprocessors;
39 use System.BB.CPU_Primitives.Multiprocessors;
40 use System.BB.Threads;
41
42 Events_Table : array (CPU) of Timing_Event_Access := (others => null);
43 -- One event list for each CPU
44
45 procedure Insert
46 (Event : not null Timing_Event_Access;
47 Is_First : out Boolean) with
48 -- Insert an event in the event list of the current CPU (Timeout order
49 -- then FIFO). Is_First is set to True when Event becomes the next timing
50 -- event to serve, False otherwise.
51
52 Pre =>
53
54 -- The first element in the list (if it exists) cannot have a previous
55 -- element.
56
57 (if Events_Table (Current_CPU) /= null then
58 Events_Table (Current_CPU).Prev = null)
59
60 -- The event should be set
61
62 and then Event.Handler /= null
63
64 -- The event should not be already inserted in a list
65
66 and then Event.Next = null and then Event.Prev = null
67
68 -- Timing Events must always be handled by the same CPU
69
70 and then (not System.BB.Parameters.Multiprocessor
71 or else Event.CPU = Current_CPU),
72
73 Post =>
74
75 -- Is_First is set to True when Event becomes the next timing event to
76 -- serve (because the list was empty or the list contained only events
77 -- with a later expiration time).
78
79 (if Events_Table (Current_CPU) = Event then
80 Is_First
81 and then Event.all.Prev = null
82 and then Event.all.Next = Events_Table'Old (Current_CPU)
83
84 -- If the event is not first then the head of queue does not change
85
86 else
87 Events_Table (Current_CPU) = Events_Table'Old (Current_CPU)
88 and then Event.all.Prev /= null)
89
90 -- The queue cannot be empty after insertion
91
92 and then Events_Table (Current_CPU) /= null
93
94 -- The first element in the list can never have a previous element
95
96 and then Events_Table (Current_CPU).Prev = null
97
98 -- The queue is always ordered by expiration time and then FIFO
99
100 and then (Event.all.Next = null
101 or else Event.all.Next.Timeout > Event.Timeout)
102 and then (Event.all.Prev = null
103 or else Event.all.Prev.Timeout <= Event.Timeout);
104
105 procedure Extract (Event : not null Timing_Event_Access;
106 Was_First : out Boolean) with
107 -- Extract an event from the event list of the current CPU. Was_First is
108 -- True when we extract the event that was first in the queue, else False.
109
110 Pre =>
111
112 -- There must be at least one element in the queue
113
114 Events_Table (Current_CPU) /= null
115
116 -- The first element in the list can never have a previous element
117
118 and then Events_Table (Current_CPU).Prev = null
119
120 -- The first element has Prev equal to null, but the others have Prev
121 -- pointing to another timing event.
122
123 and then (if Event /= Events_Table (Current_CPU) then
124 Event.Prev /= null)
125
126 -- The queue is always ordered by expiration time and then FIFO
127
128 and then (Event.Next = null
129 or else Event.Next.Timeout >= Event.Timeout)
130 and then (Event.Prev = null
131 or else Event.Prev.Timeout <= Event.Timeout)
132
133 -- Timing Events must always be handled by the same CPU
134
135 and then (not System.BB.Parameters.Multiprocessor
136 or else Event.CPU = Current_CPU),
137
138 Post =>
139
140 -- Was_First is set to True when we extract the event that was first
141 -- in the queue.
142
143 (if Events_Table'Old (Current_CPU) = Event then
144 Events_Table (Current_CPU) /= Events_Table'Old (Current_CPU)
145 and then Was_First)
146
147 -- The first element in the list (if it exists) cannot have a
148 -- previous element.
149
150 and then (if Events_Table (Current_CPU) /= null then
151 Events_Table (Current_CPU).Prev = null)
152
153 -- The Prev and Next pointers are set to null to indicate that the
154 -- event is no longer in the list.
155
156 and then Event.all.Prev = null
157 and then Event.all.Next = null;
158
159 -----------------
160 -- Set_Handler --
161 -----------------
162
163 procedure Set_Handler
164 (Event : in out Timing_Event;
165 At_Time : System.BB.Time.Time;
166 Handler : Timing_Event_Handler)
167 is
168 Next_Alarm : System.BB.Time.Time;
169 CPU_Id : constant CPU := Current_CPU;
170 Was_First : Boolean := False;
171 Is_First : Boolean := False;
172
173 begin
174 if Event.Handler /= null then
175
176 -- Extract if the event is already set
177
178 Extract (Event'Unchecked_Access, Was_First);
179 end if;
180
181 Event.Handler := Handler;
182
183 if Handler /= null then
184
185 -- Update event fields
186
187 Event.Timeout := At_Time;
188 Event.CPU := CPU_Id;
189
190 -- Insert event in the list
191
192 Insert (Event'Unchecked_Access, Is_First);
193 end if;
194
195 if Was_First or else Is_First then
196 -- Set the timer for the next alarm
197
198 Next_Alarm := Time.Get_Next_Timeout (CPU_Id);
199 Time.Update_Alarm (Next_Alarm);
200 end if;
201
202 -- The following pragma cannot be transformed into a post-condition
203 -- because the call to Leave_Kernel is a dispatching operation and the
204 -- status of the timing event handler may change (if may expire, for
205 -- example).
206
207 pragma Assert
208 ((if Handler = null then
209
210 -- If Handler is null the event is cleared
211
212 Event.Handler = null
213
214 else
215 -- If Handler is not null then the timing event handler is set,
216 -- and the execution time for the event is set to At_Time in the
217 -- current CPU. Next timeout events can never be later than the
218 -- event that we have just inserted.
219
220 Event.Handler = Handler
221 and then Event.Timeout = At_Time
222 and then Time.Get_Next_Timeout (CPU_Id) <= At_Time));
223 end Set_Handler;
224
225 ---------------------
226 -- Current_Handler --
227 ---------------------
228
229 function Current_Handler
230 (Event : Timing_Event) return Timing_Event_Handler
231 is
232 begin
233 return Event.Handler;
234 end Current_Handler;
235
236 --------------------
237 -- Cancel_Handler --
238 --------------------
239
240 procedure Cancel_Handler
241 (Event : in out Timing_Event;
242 Cancelled : out Boolean)
243 is
244 Next_Alarm : System.BB.Time.Time;
245 CPU_Id : constant CPU := Current_CPU;
246 Was_First : Boolean;
247
248 begin
249 if Event.Handler /= null then
250
251 -- Extract if the event is already set
252
253 Extract (Event'Unchecked_Access, Was_First);
254
255 Cancelled := True;
256 Event.Handler := null;
257
258 if Was_First then
259 Next_Alarm := Time.Get_Next_Timeout (CPU_Id);
260 Time.Update_Alarm (Next_Alarm);
261 end if;
262 else
263 Cancelled := False;
264 end if;
265
266 pragma Assert (Event.Handler = null);
267 end Cancel_Handler;
268
269 -----------------------------------
270 -- Execute_Expired_Timing_Events --
271 -----------------------------------
272
273 procedure Execute_Expired_Timing_Events (Now : System.BB.Time.Time) is
274 CPU_Id : constant CPU := Current_CPU;
275 Event : Timing_Event_Access := Events_Table (CPU_Id);
276 Handler : Timing_Event_Handler;
277 Was_First : Boolean;
278 Self_Id : Thread_Id;
279 Caller_Priority : Integer;
280
281 begin
282 -- Fast path: no timing event
283
284 if Event = null then
285 return;
286 end if;
287
288 -- As required by RM D.15 (14/2), timing events must be executed at
289 -- the highest priority (Interrupt_Priority'Last). This is ensured by
290 -- executing this part at the highest interrupt priority (and not at the
291 -- one corresponding to the timer hardware interrupt). At the end of the
292 -- execution of any timing event handler the priority that is restored
293 -- is that of the alarm handler. If this part of the alarm handler
294 -- executes at a priority lower than Interrupt_Priority'Last then
295 -- the protection of the queues would not be guaranteed.
296
297 Self_Id := Thread_Self;
298 Caller_Priority := Get_Priority (Self_Id);
299
300 Queues.Change_Priority (Self_Id, Interrupt_Priority'Last);
301
302 -- Extract and execute all the expired timing events
303
304 while Event /= null and then Event.Timeout <= Now loop
305
306 -- Get handler
307
308 Handler := Event.Handler;
309
310 pragma Assert (Handler /= null);
311
312 -- Extract first event from the list
313
314 Extract (Event, Was_First);
315
316 pragma Assert (Was_First);
317
318 -- Clear the event. Do it before executing the handler before the
319 -- timing event can be reinserted in the handler.
320
321 Event.Handler := null;
322
323 -- Execute the handler
324
325 Handler (Event.all);
326
327 Event := Events_Table (CPU_Id);
328 end loop;
329
330 Queues.Change_Priority (Self_Id, Caller_Priority);
331
332 -- No more events to handle with an expiration time before Now
333
334 pragma Assert (Events_Table (CPU_Id) = null
335 or else Events_Table (CPU_Id).Timeout > Now);
336 end Execute_Expired_Timing_Events;
337
338 ----------------------
339 -- Get_Next_Timeout --
340 ----------------------
341
342 function Get_Next_Timeout
343 (CPU_Id : System.Multiprocessors.CPU) return System.BB.Time.Time
344 is
345 Event : constant Timing_Event_Access := Events_Table (CPU_Id);
346 begin
347 if Event = null then
348 return System.BB.Time.Time'Last;
349 else
350 return Event.all.Timeout;
351 end if;
352 end Get_Next_Timeout;
353
354 -------------------
355 -- Time_Of_Event --
356 -------------------
357
358 function Time_Of_Event (Event : Timing_Event) return System.BB.Time.Time is
359 begin
360 if Event.Handler = null then
361 return System.BB.Time.Time'First;
362 else
363 return Event.Timeout;
364 end if;
365 end Time_Of_Event;
366
367 -------------
368 -- Extract --
369 -------------
370
371 procedure Extract (Event : not null Timing_Event_Access;
372 Was_First : out Boolean)
373 is
374 CPU_Id : constant CPU := Current_CPU;
375
376 begin
377 -- Head extraction
378
379 if Events_Table (CPU_Id) = Event then
380 Was_First := True;
381 Events_Table (CPU_Id) := Event.Next;
382
383 -- Middle or tail extraction
384
385 else
386 pragma Assert (Event.Prev /= null);
387
388 Was_First := False;
389 Event.Prev.Next := Event.Next;
390 end if;
391
392 if Event.Next /= null then
393 Event.Next.Prev := Event.Prev;
394 end if;
395
396 Event.Next := null;
397 Event.Prev := null;
398 end Extract;
399
400 -------------
401 -- Insert --
402 -------------
403
404 procedure Insert
405 (Event : not null Timing_Event_Access;
406 Is_First : out Boolean)
407 is
408 CPU_Id : constant CPU := Current_CPU;
409 Aux_Pointer : Timing_Event_Access;
410
411 begin
412 -- Insert at the head if there is no other events with a smaller timeout
413
414 if Events_Table (CPU_Id) = null
415 or else Events_Table (CPU_Id).Timeout > Event.Timeout
416 then
417 Is_First := True;
418
419 Event.Next := Events_Table (CPU_Id);
420
421 if Events_Table (CPU_Id) /= null then
422 Events_Table (CPU_Id).Prev := Event;
423 end if;
424
425 Events_Table (CPU_Id) := Event;
426
427 -- Middle or tail insertion
428
429 else
430 pragma Assert (Events_Table (CPU_Id) /= null);
431
432 Is_First := False;
433
434 Aux_Pointer := Events_Table (CPU_Id);
435
436 while Aux_Pointer.Next /= null
437 and then Aux_Pointer.Next.Timeout <= Event.Timeout
438 loop
439 Aux_Pointer := Aux_Pointer.Next;
440 end loop;
441
442 -- Insert after the Aux_Pointer
443
444 Event.Next := Aux_Pointer.Next;
445 Event.Prev := Aux_Pointer;
446
447 if Aux_Pointer.Next /= null then
448 Aux_Pointer.Next.Prev := Event;
449 end if;
450
451 Aux_Pointer.Next := Event;
452 end if;
453 end Insert;
454
455 end System.BB.Timing_Events;