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-2008, 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;
38 with Ada.Containers.Doubly_Linked_Lists;
39 pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
41 ---------------------------------
42 -- Ada.Real_Time.Timing_Events --
43 ---------------------------------
45 package body Ada.Real_Time.Timing_Events is
47 use System.Task_Primitives.Operations;
49 package SSL renames System.Soft_Links;
51 type Any_Timing_Event is access all Timing_Event'Class;
52 -- We must also handle user-defined types derived from Timing_Event
58 package Events is new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event);
59 -- Provides the type for the container holding pointers to events
61 All_Events : Events.List;
62 -- The queue of pending events, ordered by increasing timeout value, that
63 -- have been "set" by the user via Set_Handler.
65 Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock;
66 -- Used for mutually exclusive access to All_Events
68 procedure Process_Queued_Events;
69 -- Examine the queue of pending events for any that have timed-out. For
70 -- those that have timed-out, remove them from the queue and invoke their
71 -- handler (unless the user has cancelled the event by setting the handler
72 -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock
73 -- during part of the processing.
75 procedure Insert_Into_Queue (This : Any_Timing_Event);
76 -- Insert the specified event pointer into the queue of pending events
77 -- with mutually exclusive access via Event_Queue_Lock.
79 procedure Remove_From_Queue (This : Any_Timing_Event);
80 -- Remove the specified event pointer from the queue of pending events
81 -- with mutually exclusive access via Event_Queue_Lock.
82 -- This procedure is used by the client-side routines (Set_Handler, etc.).
89 pragma Priority (System.Priority'Last);
94 Period : constant Time_Span := Milliseconds (100);
95 -- This is a "chiming" clock timer that fires periodically. The period
96 -- selected is arbitrary and could be changed to suit the application
97 -- requirements. Obviously a shorter period would give better resolution
98 -- at the cost of more overhead.
100 System.Tasking.Utilities.Make_Independent;
102 -- We await the call to Start to ensure that Event_Queue_Lock has been
103 -- initialized by the package executable part prior to accessing it in
104 -- the loop. The task is activated before the first statement of the
105 -- executable part so it would otherwise be possible for the task to
106 -- call EnterCriticalSection in Process_Queued_Events before the
109 -- We don't simply put the initialization here, prior to the loop,
110 -- because other application tasks could call the visible routines that
111 -- also call Enter/LeaveCriticalSection prior to this task doing the
117 Process_Queued_Events;
118 delay until Clock + Period;
122 ---------------------------
123 -- Process_Queued_Events --
124 ---------------------------
126 procedure Process_Queued_Events is
127 Next_Event : Any_Timing_Event;
133 Write_Lock (Event_Queue_Lock'Access);
135 if All_Events.Is_Empty then
136 Unlock (Event_Queue_Lock'Access);
137 SSL.Abort_Undefer.all;
140 Next_Event := All_Events.First_Element;
143 if Next_Event.Timeout > Clock then
145 -- We found one that has not yet timed-out. The queue is in
146 -- ascending order by Timeout so there is no need to continue
147 -- processing (and indeed we must not continue since we always
148 -- delete the first element).
150 Unlock (Event_Queue_Lock'Access);
151 SSL.Abort_Undefer.all;
155 -- We have an event that has timed out so we will process it. It
156 -- must be the first in the queue so no search is needed.
158 All_Events.Delete_First;
160 -- A fundamental issue is that the invocation of the event's handler
161 -- might call Set_Handler on itself to re-insert itself back into the
162 -- queue of future events. Thus we cannot hold the lock on the queue
163 -- while invoking the event's handler.
165 Unlock (Event_Queue_Lock'Access);
167 SSL.Abort_Undefer.all;
169 -- There is no race condition with the user changing the handler
170 -- pointer while we are processing because we are executing at the
171 -- highest possible application task priority and are not doing
172 -- anything to block prior to invoking their handler.
175 Handler : constant Timing_Event_Handler := Next_Event.Handler;
177 -- The first act is to clear the event, per D.15 (13/2). Besides,
178 -- we cannot clear the handler pointer *after* invoking the
179 -- handler because the handler may have re-inserted the event via
180 -- Set_Event. Thus we take a copy and then clear the component.
182 Next_Event.Handler := null;
184 if Handler /= null then
185 Handler (Timing_Event (Next_Event.all));
192 end Process_Queued_Events;
194 -----------------------
195 -- Insert_Into_Queue --
196 -----------------------
198 procedure Insert_Into_Queue (This : Any_Timing_Event) is
200 function Sooner (Left, Right : Any_Timing_Event) return Boolean;
201 -- Compares events in terms of timeout values
203 package By_Timeout is new Events.Generic_Sorting (Sooner);
204 -- Used to keep the events in ascending order by timeout value
206 function Sooner (Left, Right : Any_Timing_Event) return Boolean is
208 return Left.Timeout < Right.Timeout;
214 Write_Lock (Event_Queue_Lock'Access);
216 All_Events.Append (This);
218 -- A critical property of the implementation of this package is that
219 -- all occurrences are in ascending order by Timeout. Thus the first
220 -- event in the queue always has the "next" value for the Timer task
221 -- to use in its delay statement.
223 By_Timeout.Sort (All_Events);
225 Unlock (Event_Queue_Lock'Access);
227 SSL.Abort_Undefer.all;
228 end Insert_Into_Queue;
230 -----------------------
231 -- Remove_From_Queue --
232 -----------------------
234 procedure Remove_From_Queue (This : Any_Timing_Event) is
240 Write_Lock (Event_Queue_Lock'Access);
242 Location := All_Events.Find (This);
243 if Location /= No_Element then
244 All_Events.Delete (Location);
247 Unlock (Event_Queue_Lock'Access);
249 SSL.Abort_Undefer.all;
250 end Remove_From_Queue;
256 procedure Set_Handler
257 (Event : in out Timing_Event;
259 Handler : Timing_Event_Handler)
262 Remove_From_Queue (Event'Unchecked_Access);
263 Event.Handler := null;
264 if At_Time <= Clock then
265 if Handler /= null then
270 if Handler /= null then
271 Event.Timeout := At_Time;
272 Event.Handler := Handler;
273 Insert_Into_Queue (Event'Unchecked_Access);
281 procedure Set_Handler
282 (Event : in out Timing_Event;
284 Handler : Timing_Event_Handler)
287 Remove_From_Queue (Event'Unchecked_Access);
288 Event.Handler := null;
289 if In_Time <= Time_Span_Zero then
290 if Handler /= null then
295 if Handler /= null then
296 Event.Timeout := Clock + In_Time;
297 Event.Handler := Handler;
298 Insert_Into_Queue (Event'Unchecked_Access);
302 ---------------------
303 -- Current_Handler --
304 ---------------------
306 function Current_Handler
307 (Event : Timing_Event) return Timing_Event_Handler
310 return Event.Handler;
317 procedure Cancel_Handler
318 (Event : in out Timing_Event;
319 Cancelled : out Boolean)
322 Remove_From_Queue (Event'Unchecked_Access);
323 Cancelled := Event.Handler /= null;
324 Event.Handler := null;
331 function Time_Of_Event (Event : Timing_Event) return Time is
333 return Event.Timeout;
340 procedure Finalize (This : in out Timing_Event) is
342 -- D.15 (19/2) says finalization clears the event
344 This.Handler := null;
345 Remove_From_Queue (This'Unchecked_Access);
349 Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level);
351 end Ada.Real_Time.Timing_Events;