1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . R E A L _ T I M E . T I M I N G _ E V E N T S --
9 -- Copyright (C) 2005-2006, Free Software Foundation, Inc. --
11 -- GNAT 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. 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. 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 GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with System
.Task_Primitives
.Operations
;
35 with System
.Tasking
.Utilities
;
36 with System
.Soft_Links
;
37 -- used for Abort_Defer/Undefer
39 with Ada
.Containers
.Doubly_Linked_Lists
;
40 pragma Elaborate_All
(Ada
.Containers
.Doubly_Linked_Lists
);
42 ---------------------------------
43 -- Ada.Real_Time.Timing_Events --
44 ---------------------------------
46 package body Ada
.Real_Time
.Timing_Events
is
48 use System
.Task_Primitives
.Operations
;
49 -- for Write_Lock and Unlock
51 package SSL
renames System
.Soft_Links
;
53 type Any_Timing_Event
is access all Timing_Event
'Class;
54 -- We must also handle user-defined types derived from Timing_Event
60 package Events
is new Ada
.Containers
.Doubly_Linked_Lists
(Any_Timing_Event
);
61 -- Provides the type for the container holding pointers to events
63 All_Events
: Events
.List
;
64 -- The queue of pending events, ordered by increasing timeout value, that
65 -- have been "set" by the user via Set_Handler.
67 Event_Queue_Lock
: aliased System
.Task_Primitives
.RTS_Lock
;
68 -- Used for mutually exclusive access to All_Events
70 procedure Process_Queued_Events
;
71 -- Examine the queue of pending events for any that have timed-out. For
72 -- those that have timed-out, remove them from the queue and invoke their
73 -- handler (unless the user has cancelled the event by setting the handler
74 -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock
75 -- during part of the processing.
77 procedure Insert_Into_Queue
(This
: Any_Timing_Event
);
78 -- Insert the specified event pointer into the queue of pending events
79 -- with mutually exclusive access via Event_Queue_Lock.
81 procedure Remove_From_Queue
(This
: Any_Timing_Event
);
82 -- Remove the specified event pointer from the queue of pending events
83 -- with mutually exclusive access via Event_Queue_Lock.
84 -- This procedure is used by the client-side routines (Set_Handler, etc.).
91 pragma Priority
(System
.Priority
'Last);
96 Period
: constant Time_Span
:= Milliseconds
(100);
97 -- This is a "chiming" clock timer that fires periodically. The period
98 -- selected is arbitrary and could be changed to suit the application
99 -- requirements. Obviously a shorter period would give better resolution
100 -- at the cost of more overhead.
102 System
.Tasking
.Utilities
.Make_Independent
;
104 -- We await the call to Start to ensure that Event_Queue_Lock has been
105 -- initialized by the package executable part prior to accessing it in
106 -- the loop. The task is activated before the first statement of the
107 -- executable part so it would otherwise be possible for the task to
108 -- call EnterCriticalSection in Process_Queued_Events before the
111 -- We don't simply put the initialization here, prior to the loop,
112 -- because other application tasks could call the visible routines that
113 -- also call Enter/LeaveCriticalSection prior to this task doing the
119 Process_Queued_Events
;
120 delay until Clock
+ Period
;
124 ---------------------------
125 -- Process_Queued_Events --
126 ---------------------------
128 procedure Process_Queued_Events
is
129 Next_Event
: Any_Timing_Event
;
135 Write_Lock
(Event_Queue_Lock
'Access);
137 if All_Events
.Is_Empty
then
138 Unlock
(Event_Queue_Lock
'Access);
139 SSL
.Abort_Undefer
.all;
142 Next_Event
:= All_Events
.First_Element
;
145 if Next_Event
.Timeout
> Clock
then
147 -- We found one that has not yet timed-out. The queue is in
148 -- ascending order by Timeout so there is no need to continue
149 -- processing (and indeed we must not continue since we always
150 -- delete the first element).
152 Unlock
(Event_Queue_Lock
'Access);
153 SSL
.Abort_Undefer
.all;
157 -- We have an event that has timed out so we will process it. It
158 -- must be the first in the queue so no search is needed.
160 All_Events
.Delete_First
;
162 -- A fundamental issue is that the invocation of the event's handler
163 -- might call Set_Handler on itself to re-insert itself back into the
164 -- queue of future events. Thus we cannot hold the lock on the queue
165 -- while invoking the event's handler.
167 Unlock
(Event_Queue_Lock
'Access);
169 SSL
.Abort_Undefer
.all;
171 -- There is no race condition with the user changing the handler
172 -- pointer while we are processing because we are executing at the
173 -- highest possible application task priority and are not doing
174 -- anything to block prior to invoking their handler.
177 Handler
: constant Timing_Event_Handler
:= Next_Event
.Handler
;
179 -- The first act is to clear the event, per D.15 (13/2). Besides,
180 -- we cannot clear the handler pointer *after* invoking the
181 -- handler because the handler may have re-inserted the event via
182 -- Set_Event. Thus we take a copy and then clear the component.
184 Next_Event
.Handler
:= null;
186 if Handler
/= null then
187 Handler
(Timing_Event
(Next_Event
.all));
194 end Process_Queued_Events
;
196 -----------------------
197 -- Insert_Into_Queue --
198 -----------------------
200 procedure Insert_Into_Queue
(This
: Any_Timing_Event
) is
202 function Sooner
(Left
, Right
: Any_Timing_Event
) return Boolean;
203 -- Compares events in terms of timeout values
205 package By_Timeout
is new Events
.Generic_Sorting
(Sooner
);
206 -- Used to keep the events in ascending order by timeout value
208 function Sooner
(Left
, Right
: Any_Timing_Event
) return Boolean is
210 return Left
.Timeout
< Right
.Timeout
;
216 Write_Lock
(Event_Queue_Lock
'Access);
218 All_Events
.Append
(This
);
220 -- A critical property of the implementation of this package is that
221 -- all occurrences are in ascending order by Timeout. Thus the first
222 -- event in the queue always has the "next" value for the Timer task
223 -- to use in its delay statement.
225 By_Timeout
.Sort
(All_Events
);
227 Unlock
(Event_Queue_Lock
'Access);
229 SSL
.Abort_Undefer
.all;
230 end Insert_Into_Queue
;
232 -----------------------
233 -- Remove_From_Queue --
234 -----------------------
236 procedure Remove_From_Queue
(This
: Any_Timing_Event
) is
242 Write_Lock
(Event_Queue_Lock
'Access);
244 Location
:= All_Events
.Find
(This
);
245 if Location
/= No_Element
then
246 All_Events
.Delete
(Location
);
249 Unlock
(Event_Queue_Lock
'Access);
251 SSL
.Abort_Undefer
.all;
252 end Remove_From_Queue
;
258 procedure Set_Handler
259 (Event
: in out Timing_Event
;
261 Handler
: Timing_Event_Handler
)
264 Remove_From_Queue
(Event
'Unchecked_Access);
265 Event
.Handler
:= null;
266 if At_Time
<= Clock
then
267 if Handler
/= null then
272 if Handler
/= null then
273 Event
.Timeout
:= At_Time
;
274 Event
.Handler
:= Handler
;
275 Insert_Into_Queue
(Event
'Unchecked_Access);
283 procedure Set_Handler
284 (Event
: in out Timing_Event
;
286 Handler
: Timing_Event_Handler
)
289 Remove_From_Queue
(Event
'Unchecked_Access);
290 Event
.Handler
:= null;
291 if In_Time
<= Time_Span_Zero
then
292 if Handler
/= null then
297 if Handler
/= null then
298 Event
.Timeout
:= Clock
+ In_Time
;
299 Event
.Handler
:= Handler
;
300 Insert_Into_Queue
(Event
'Unchecked_Access);
304 ---------------------
305 -- Current_Handler --
306 ---------------------
308 function Current_Handler
309 (Event
: Timing_Event
) return Timing_Event_Handler
312 return Event
.Handler
;
319 procedure Cancel_Handler
320 (Event
: in out Timing_Event
;
321 Cancelled
: out Boolean)
324 Remove_From_Queue
(Event
'Unchecked_Access);
325 Cancelled
:= Event
.Handler
/= null;
326 Event
.Handler
:= null;
333 function Time_Of_Event
(Event
: Timing_Event
) return Time
is
335 return Event
.Timeout
;
342 procedure Finalize
(This
: in out Timing_Event
) is
344 -- D.15 (19/2) says finalization clears the event
346 This
.Handler
:= null;
347 Remove_From_Queue
(This
'Unchecked_Access);
351 Initialize_Lock
(Event_Queue_Lock
'Access, Level
=> PO_Level
);
353 end Ada
.Real_Time
.Timing_Events
;