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-2014, 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 -- We need to Initialize_Lock before Timer is activated. The purpose of the 68 -- Dummy package is to get around Ada's syntax rules. 69 70 package Dummy is end Dummy; 71 package body Dummy is 72 begin 73 Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level); 74 end Dummy; 75 76 procedure Process_Queued_Events; 77 -- Examine the queue of pending events for any that have timed out. For 78 -- those that have timed out, remove them from the queue and invoke their 79 -- handler (unless the user has cancelled the event by setting the handler 80 -- pointer to null). Mutually exclusive access is held via Event_Queue_Lock 81 -- during part of the processing. 82 83 procedure Insert_Into_Queue (This : Any_Timing_Event); 84 -- Insert the specified event pointer into the queue of pending events 85 -- with mutually exclusive access via Event_Queue_Lock. 86 87 procedure Remove_From_Queue (This : Any_Timing_Event); 88 -- Remove the specified event pointer from the queue of pending events with 89 -- mutually exclusive access via Event_Queue_Lock. This procedure is used 90 -- by the client-side routines (Set_Handler, etc.). 91 92 ----------- 93 -- Timer -- 94 ----------- 95 96 task Timer is 97 pragma Priority (System.Priority'Last); 98 end Timer; 99 100 task body Timer is 101 Period : constant Time_Span := Milliseconds (100); 102 -- This is a "chiming" clock timer that fires periodically. The period 103 -- selected is arbitrary and could be changed to suit the application 104 -- requirements. Obviously a shorter period would give better resolution 105 -- at the cost of more overhead. 106 107 Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; 108 pragma Unreferenced (Ignore); 109 110 begin 111 -- Since this package may be elaborated before System.Interrupt, 112 -- we need to call Setup_Interrupt_Mask explicitly to ensure that 113 -- this task has the proper signal mask. 114 115 System.Interrupt_Management.Operations.Setup_Interrupt_Mask; 116 117 loop 118 Process_Queued_Events; 119 delay until Clock + Period; 120 end loop; 121 end Timer; 122 123 --------------------------- 124 -- Process_Queued_Events -- 125 --------------------------- 126 127 procedure Process_Queued_Events is 128 Next_Event : Any_Timing_Event; 129 130 begin 131 loop 132 SSL.Abort_Defer.all; 133 134 Write_Lock (Event_Queue_Lock'Access); 135 136 if All_Events.Is_Empty then 137 Unlock (Event_Queue_Lock'Access); 138 SSL.Abort_Undefer.all; 139 return; 140 else 141 Next_Event := All_Events.First_Element; 142 end if; 143 144 if Next_Event.Timeout > Clock then 145 146 -- We found one that has not yet timed out. The queue is in 147 -- ascending order by Timeout so there is no need to continue 148 -- processing (and indeed we must not continue since we always 149 -- delete the first element). 150 151 Unlock (Event_Queue_Lock'Access); 152 SSL.Abort_Undefer.all; 153 return; 154 end if; 155 156 -- We have an event that has timed out so we will process it. It must 157 -- be the first in the queue so no search is needed. 158 159 All_Events.Delete_First; 160 161 -- A fundamental issue is that the invocation of the event's handler 162 -- might call Set_Handler on itself to re-insert itself back into the 163 -- queue of future events. Thus we cannot hold the lock on the queue 164 -- while invoking the event's handler. 165 166 Unlock (Event_Queue_Lock'Access); 167 168 SSL.Abort_Undefer.all; 169 170 -- There is no race condition with the user changing the handler 171 -- pointer while we are processing because we are executing at the 172 -- highest possible application task priority and are not doing 173 -- anything to block prior to invoking their handler. 174 175 declare 176 Handler : constant Timing_Event_Handler := Next_Event.Handler; 177 178 begin 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. 183 184 Next_Event.Handler := null; 185 186 if Handler /= null then 187 Handler.all (Timing_Event (Next_Event.all)); 188 end if; 189 190 -- Ignore exceptions propagated by Handler.all, as required by 191 -- RM D.15(21/2). 192 193 exception 194 when others => 195 null; 196 end; 197 end loop; 198 end Process_Queued_Events; 199 200 ----------------------- 201 -- Insert_Into_Queue -- 202 ----------------------- 203 204 procedure Insert_Into_Queue (This : Any_Timing_Event) is 205 206 function Sooner (Left, Right : Any_Timing_Event) return Boolean; 207 -- Compares events in terms of timeout values 208 209 package By_Timeout is new Events.Generic_Sorting (Sooner); 210 -- Used to keep the events in ascending order by timeout value 211 212 ------------ 213 -- Sooner -- 214 ------------ 215 216 function Sooner (Left, Right : Any_Timing_Event) return Boolean is 217 begin 218 return Left.Timeout < Right.Timeout; 219 end Sooner; 220 221 -- Start of processing for Insert_Into_Queue 222 223 begin 224 SSL.Abort_Defer.all; 225 226 Write_Lock (Event_Queue_Lock'Access); 227 228 All_Events.Append (This); 229 230 -- A critical property of the implementation of this package is that 231 -- all occurrences are in ascending order by Timeout. Thus the first 232 -- event in the queue always has the "next" value for the Timer task 233 -- to use in its delay statement. 234 235 By_Timeout.Sort (All_Events); 236 237 Unlock (Event_Queue_Lock'Access); 238 239 SSL.Abort_Undefer.all; 240 end Insert_Into_Queue; 241 242 ----------------------- 243 -- Remove_From_Queue -- 244 ----------------------- 245 246 procedure Remove_From_Queue (This : Any_Timing_Event) is 247 use Events; 248 Location : Cursor; 249 250 begin 251 SSL.Abort_Defer.all; 252 253 Write_Lock (Event_Queue_Lock'Access); 254 255 Location := All_Events.Find (This); 256 257 if Location /= No_Element then 258 All_Events.Delete (Location); 259 end if; 260 261 Unlock (Event_Queue_Lock'Access); 262 263 SSL.Abort_Undefer.all; 264 end Remove_From_Queue; 265 266 ----------------- 267 -- Set_Handler -- 268 ----------------- 269 270 procedure Set_Handler 271 (Event : in out Timing_Event; 272 At_Time : Time; 273 Handler : Timing_Event_Handler) 274 is 275 begin 276 Remove_From_Queue (Event'Unchecked_Access); 277 Event.Handler := null; 278 279 -- RM D.15(15/2) required that at this point, we check whether the time 280 -- has already passed, and if so, call Handler.all directly from here 281 -- instead of doing the enqueuing below. However, this caused a nasty 282 -- race condition and potential deadlock. If the current task has 283 -- already locked the protected object of Handler.all, and the time has 284 -- passed, deadlock would occur. It has been fixed by AI05-0094-1, which 285 -- says that the handler should be executed as soon as possible, meaning 286 -- that the timing event will be executed after the protected action 287 -- finishes (Handler.all should not be called directly from here). 288 -- The same comment applies to the other Set_Handler below. 289 290 if Handler /= null then 291 Event.Timeout := At_Time; 292 Event.Handler := Handler; 293 Insert_Into_Queue (Event'Unchecked_Access); 294 end if; 295 end Set_Handler; 296 297 ----------------- 298 -- Set_Handler -- 299 ----------------- 300 301 procedure Set_Handler 302 (Event : in out Timing_Event; 303 In_Time : Time_Span; 304 Handler : Timing_Event_Handler) 305 is 306 begin 307 Remove_From_Queue (Event'Unchecked_Access); 308 Event.Handler := null; 309 310 -- See comment in the other Set_Handler above 311 312 if Handler /= null then 313 Event.Timeout := Clock + In_Time; 314 Event.Handler := Handler; 315 Insert_Into_Queue (Event'Unchecked_Access); 316 end if; 317 end Set_Handler; 318 319 --------------------- 320 -- Current_Handler -- 321 --------------------- 322 323 function Current_Handler 324 (Event : Timing_Event) return Timing_Event_Handler 325 is 326 begin 327 return Event.Handler; 328 end Current_Handler; 329 330 -------------------- 331 -- Cancel_Handler -- 332 -------------------- 333 334 procedure Cancel_Handler 335 (Event : in out Timing_Event; 336 Cancelled : out Boolean) 337 is 338 begin 339 Remove_From_Queue (Event'Unchecked_Access); 340 Cancelled := Event.Handler /= null; 341 Event.Handler := null; 342 end Cancel_Handler; 343 344 ------------------- 345 -- Time_Of_Event -- 346 ------------------- 347 348 function Time_Of_Event (Event : Timing_Event) return Time is 349 begin 350 -- RM D.15(18/2): Time_First must be returned in the event is not set 351 352 return (if Event.Handler = null then Time_First else Event.Timeout); 353 end Time_Of_Event; 354 355 -------------- 356 -- Finalize -- 357 -------------- 358 359 procedure Finalize (This : in out Timing_Event) is 360 begin 361 -- D.15 (19/2) says finalization clears the event 362 363 This.Handler := null; 364 Remove_From_Queue (This'Unchecked_Access); 365 end Finalize; 366 367end Ada.Real_Time.Timing_Events; 368