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-2009, 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 3, 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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with System.Task_Primitives.Operations;
33 with System.Tasking.Utilities;
34 with System.Soft_Links;
36 with Ada.Containers.Doubly_Linked_Lists;
37 pragma Elaborate_All (Ada.Containers.Doubly_Linked_Lists);
39 ---------------------------------
40 -- Ada.Real_Time.Timing_Events --
41 ---------------------------------
43 package body Ada.Real_Time.Timing_Events is
45 use System.Task_Primitives.Operations;
47 package SSL renames System.Soft_Links;
49 type Any_Timing_Event is access all Timing_Event'Class;
50 -- We must also handle user-defined types derived from Timing_Event
56 package Events is new Ada.Containers.Doubly_Linked_Lists (Any_Timing_Event);
57 -- Provides the type for the container holding pointers to events
59 All_Events : Events.List;
60 -- The queue of pending events, ordered by increasing timeout value, that
61 -- have been "set" by the user via Set_Handler.
63 Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock;
64 -- Used for mutually exclusive access to All_Events
66 procedure Process_Queued_Events;
67 -- Examine the queue of pending events for any that have timed out. For
68 -- those that have timed out, remove them from the queue and invoke their
69 -- handler (unless the user has cancelled the event by setting the handler
70 -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock
71 -- during part of the processing.
73 procedure Insert_Into_Queue (This : Any_Timing_Event);
74 -- Insert the specified event pointer into the queue of pending events
75 -- with mutually exclusive access via Event_Queue_Lock.
77 procedure Remove_From_Queue (This : Any_Timing_Event);
78 -- Remove the specified event pointer from the queue of pending events
79 -- with mutually exclusive access via Event_Queue_Lock.
80 -- This procedure is used by the client-side routines (Set_Handler, etc.).
87 pragma Priority (System.Priority'Last);
92 Period : constant Time_Span := Milliseconds (100);
93 -- This is a "chiming" clock timer that fires periodically. The period
94 -- selected is arbitrary and could be changed to suit the application
95 -- requirements. Obviously a shorter period would give better resolution
96 -- at the cost of more overhead.
98 System.Tasking.Utilities.Make_Independent;
100 -- We await the call to Start to ensure that Event_Queue_Lock has been
101 -- initialized by the package executable part prior to accessing it in
102 -- the loop. The task is activated before the first statement of the
103 -- executable part so it would otherwise be possible for the task to
104 -- call EnterCriticalSection in Process_Queued_Events before the
107 -- We don't simply put the initialization here, prior to the loop,
108 -- because other application tasks could call the visible routines that
109 -- also call Enter/LeaveCriticalSection prior to this task doing the
115 Process_Queued_Events;
116 delay until Clock + Period;
120 ---------------------------
121 -- Process_Queued_Events --
122 ---------------------------
124 procedure Process_Queued_Events is
125 Next_Event : Any_Timing_Event;
131 Write_Lock (Event_Queue_Lock'Access);
133 if All_Events.Is_Empty then
134 Unlock (Event_Queue_Lock'Access);
135 SSL.Abort_Undefer.all;
138 Next_Event := All_Events.First_Element;
141 if Next_Event.Timeout > Clock then
143 -- We found one that has not yet timed out. The queue is in
144 -- ascending order by Timeout so there is no need to continue
145 -- processing (and indeed we must not continue since we always
146 -- delete the first element).
148 Unlock (Event_Queue_Lock'Access);
149 SSL.Abort_Undefer.all;
153 -- We have an event that has timed out so we will process it. It must
154 -- be the first in the queue so no search is needed.
156 All_Events.Delete_First;
158 -- A fundamental issue is that the invocation of the event's handler
159 -- might call Set_Handler on itself to re-insert itself back into the
160 -- queue of future events. Thus we cannot hold the lock on the queue
161 -- while invoking the event's handler.
163 Unlock (Event_Queue_Lock'Access);
165 SSL.Abort_Undefer.all;
167 -- There is no race condition with the user changing the handler
168 -- pointer while we are processing because we are executing at the
169 -- highest possible application task priority and are not doing
170 -- anything to block prior to invoking their handler.
173 Handler : constant Timing_Event_Handler := Next_Event.Handler;
175 -- The first act is to clear the event, per D.15(13/2). Besides,
176 -- we cannot clear the handler pointer *after* invoking the
177 -- handler because the handler may have re-inserted the event via
178 -- Set_Event. Thus we take a copy and then clear the component.
180 Next_Event.Handler := null;
182 if Handler /= null then
183 Handler.all (Timing_Event (Next_Event.all));
186 -- Ignore exceptions propagated by Handler.all, as required by
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;
267 -- RM D.15(15/2) requires that at this point, we check whether the time
268 -- has already passed, and if so, call Handler.all directly from here
269 -- instead of doing the enqueuing below. However, this causes a nasty
270 -- race condition and potential deadlock. If the current task has
271 -- already locked the protected object of Handler.all, and the time has
272 -- passed, deadlock would occur. Therefore, we ignore the requirement.
273 -- The same comment applies to the other Set_Handler below.
275 if Handler /= null then
276 Event.Timeout := At_Time;
277 Event.Handler := Handler;
278 Insert_Into_Queue (Event'Unchecked_Access);
286 procedure Set_Handler
287 (Event : in out Timing_Event;
289 Handler : Timing_Event_Handler)
292 Remove_From_Queue (Event'Unchecked_Access);
293 Event.Handler := null;
295 -- See comment in the other Set_Handler above
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;