1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367 | ------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2005-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Task_Primitives.Operations;
with System.Tasking.Utilities;
with System.Soft_Links;
with System.Interrupt_Management.Operations;
with Ada.Containers.Doubly_Linked_Lists;
pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
---------------------------------
-- Ada.Real_Time.Timing_Events --
---------------------------------
package body Ada.Real_Time.Timing_Events is
use System.Task_Primitives.Operations;
package SSL renames System.Soft_Links;
type Any_Timing_Event is access all Timing_Event'Class;
-- We must also handle user-defined types derived from Timing_Event
------------
-- Events --
------------
package Events is new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event);
-- Provides the type for the container holding pointers to events
All_Events : Events.List;
-- The queue of pending events, ordered by increasing timeout value, that
-- have been "set" by the user via Set_Handler.
Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock;
-- Used for mutually exclusive access to All_Events
-- We need to Initialize_Lock before Timer is activated. The purpose of the
-- Dummy package is to get around Ada's syntax rules.
package Dummy is end Dummy;
package body Dummy is
begin
Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level);
end Dummy;
procedure Process_Queued_Events;
-- Examine the queue of pending events for any that have timed out. For
-- those that have timed out, remove them from the queue and invoke their
-- handler (unless the user has cancelled the event by setting the handler
-- pointer to null). Mutually exclusive access is held via Event_Queue_Lock
-- during part of the processing.
procedure Insert_Into_Queue (This : Any_Timing_Event);
-- Insert the specified event pointer into the queue of pending events
-- with mutually exclusive access via Event_Queue_Lock.
procedure Remove_From_Queue (This : Any_Timing_Event);
-- Remove the specified event pointer from the queue of pending events with
-- mutually exclusive access via Event_Queue_Lock. This procedure is used
-- by the client-side routines (Set_Handler, etc.).
-----------
-- Timer --
-----------
task Timer is
pragma Priority (System.Priority'Last);
end Timer;
task body Timer is
Period : constant Time_Span := Milliseconds (100);
-- This is a "chiming" clock timer that fires periodically. The period
-- selected is arbitrary and could be changed to suit the application
-- requirements. Obviously a shorter period would give better resolution
-- at the cost of more overhead.
Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent;
pragma Unreferenced (Ignore);
begin
-- Since this package may be elaborated before System.Interrupt,
-- we need to call Setup_Interrupt_Mask explicitly to ensure that
-- this task has the proper signal mask.
System.Interrupt_Management.Operations.Setup_Interrupt_Mask;
loop
Process_Queued_Events;
delay until Clock + Period;
end loop;
end Timer;
---------------------------
-- Process_Queued_Events --
---------------------------
procedure Process_Queued_Events is
Next_Event : Any_Timing_Event;
begin
loop
SSL.Abort_Defer.all;
Write_Lock (Event_Queue_Lock'Access);
if All_Events.Is_Empty then
Unlock (Event_Queue_Lock'Access);
SSL.Abort_Undefer.all;
return;
else
Next_Event := All_Events.First_Element;
end if;
if Next_Event.Timeout > Clock then
-- We found one that has not yet timed out. The queue is in
-- ascending order by Timeout so there is no need to continue
-- processing (and indeed we must not continue since we always
-- delete the first element).
Unlock (Event_Queue_Lock'Access);
SSL.Abort_Undefer.all;
return;
end if;
-- We have an event that has timed out so we will process it. It must
-- be the first in the queue so no search is needed.
All_Events.Delete_First;
-- A fundamental issue is that the invocation of the event's handler
-- might call Set_Handler on itself to re-insert itself back into the
-- queue of future events. Thus we cannot hold the lock on the queue
-- while invoking the event's handler.
Unlock (Event_Queue_Lock'Access);
SSL.Abort_Undefer.all;
-- There is no race condition with the user changing the handler
-- pointer while we are processing because we are executing at the
-- highest possible application task priority and are not doing
-- anything to block prior to invoking their handler.
declare
Handler : constant Timing_Event_Handler := Next_Event.Handler;
begin
-- The first act is to clear the event, per D.15(13/2). Besides,
-- we cannot clear the handler pointer *after* invoking the
-- handler because the handler may have re-inserted the event via
-- Set_Event. Thus we take a copy and then clear the component.
Next_Event.Handler := null;
if Handler /= null then
Handler.all (Timing_Event (Next_Event.all));
end if;
-- Ignore exceptions propagated by Handler.all, as required by
-- RM D.15(21/2).
exception
when others =>
null;
end;
end loop;
end Process_Queued_Events;
-----------------------
-- Insert_Into_Queue --
-----------------------
procedure Insert_Into_Queue (This : Any_Timing_Event) is
function Sooner (Left, Right : Any_Timing_Event) return Boolean;
-- Compares events in terms of timeout values
package By_Timeout is new Events.Generic_Sorting (Sooner);
-- Used to keep the events in ascending order by timeout value
------------
-- Sooner --
------------
function Sooner (Left, Right : Any_Timing_Event) return Boolean is
begin
return Left.Timeout < Right.Timeout;
end Sooner;
-- Start of processing for Insert_Into_Queue
begin
SSL.Abort_Defer.all;
Write_Lock (Event_Queue_Lock'Access);
All_Events.Append (This);
-- A critical property of the implementation of this package is that
-- all occurrences are in ascending order by Timeout. Thus the first
-- event in the queue always has the "next" value for the Timer task
-- to use in its delay statement.
By_Timeout.Sort (All_Events);
Unlock (Event_Queue_Lock'Access);
SSL.Abort_Undefer.all;
end Insert_Into_Queue;
-----------------------
-- Remove_From_Queue --
-----------------------
procedure Remove_From_Queue (This : Any_Timing_Event) is
use Events;
Location : Cursor;
begin
SSL.Abort_Defer.all;
Write_Lock (Event_Queue_Lock'Access);
Location := All_Events.Find (This);
if Location /= No_Element then
All_Events.Delete (Location);
end if;
Unlock (Event_Queue_Lock'Access);
SSL.Abort_Undefer.all;
end Remove_From_Queue;
-----------------
-- Set_Handler --
-----------------
procedure Set_Handler
(Event : in out Timing_Event;
At_Time : Time;
Handler : Timing_Event_Handler)
is
begin
Remove_From_Queue (Event'Unchecked_Access);
Event.Handler := null;
-- RM D.15(15/2) required that at this point, we check whether the time
-- has already passed, and if so, call Handler.all directly from here
-- instead of doing the enqueuing below. However, this caused a nasty
-- race condition and potential deadlock. If the current task has
-- already locked the protected object of Handler.all, and the time has
-- passed, deadlock would occur. It has been fixed by AI05-0094-1, which
-- says that the handler should be executed as soon as possible, meaning
-- that the timing event will be executed after the protected action
-- finishes (Handler.all should not be called directly from here).
-- The same comment applies to the other Set_Handler below.
if Handler /= null then
Event.Timeout := At_Time;
Event.Handler := Handler;
Insert_Into_Queue (Event'Unchecked_Access);
end if;
end Set_Handler;
-----------------
-- Set_Handler --
-----------------
procedure Set_Handler
(Event : in out Timing_Event;
In_Time : Time_Span;
Handler : Timing_Event_Handler)
is
begin
Remove_From_Queue (Event'Unchecked_Access);
Event.Handler := null;
-- See comment in the other Set_Handler above
if Handler /= null then
Event.Timeout := Clock + In_Time;
Event.Handler := Handler;
Insert_Into_Queue (Event'Unchecked_Access);
end if;
end Set_Handler;
---------------------
-- Current_Handler --
---------------------
function Current_Handler
(Event : Timing_Event) return Timing_Event_Handler
is
begin
return Event.Handler;
end Current_Handler;
--------------------
-- Cancel_Handler --
--------------------
procedure Cancel_Handler
(Event : in out Timing_Event;
Cancelled : out Boolean)
is
begin
Remove_From_Queue (Event'Unchecked_Access);
Cancelled := Event.Handler /= null;
Event.Handler := null;
end Cancel_Handler;
-------------------
-- Time_Of_Event --
-------------------
function Time_Of_Event (Event : Timing_Event) return Time is
begin
-- RM D.15(18/2): Time_First must be returned in the event is not set
return (if Event.Handler = null then Time_First else Event.Timeout);
end Time_Of_Event;
--------------
-- Finalize --
--------------
procedure Finalize (This : in out Timing_Event) is
begin
-- D.15 (19/2) says finalization clears the event
This.Handler := null;
Remove_From_Queue (This'Unchecked_Access);
end Finalize;
end Ada.Real_Time.Timing_Events;
|