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