1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K I N G . A S Y N C _ D E L A Y S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- 10-- -- 11-- GNARL 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-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32pragma Polling (Off); 33-- Turn off polling, we do not want ATC polling to take place during 34-- tasking operations. It causes infinite loops and other problems. 35 36with Ada.Unchecked_Conversion; 37with Ada.Task_Identification; 38 39with System.Task_Primitives.Operations; 40with System.Tasking.Utilities; 41with System.Tasking.Initialization; 42with System.Tasking.Debug; 43with System.OS_Primitives; 44with System.Interrupt_Management.Operations; 45with System.Parameters; 46with System.Traces.Tasking; 47 48package body System.Tasking.Async_Delays is 49 50 package STPO renames System.Task_Primitives.Operations; 51 package ST renames System.Tasking; 52 package STU renames System.Tasking.Utilities; 53 package STI renames System.Tasking.Initialization; 54 package OSP renames System.OS_Primitives; 55 56 use Parameters; 57 use System.Traces; 58 use System.Traces.Tasking; 59 60 function To_System is new Ada.Unchecked_Conversion 61 (Ada.Task_Identification.Task_Id, Task_Id); 62 63 Timer_Server_ID : ST.Task_Id; 64 65 Timer_Attention : Boolean := False; 66 pragma Atomic (Timer_Attention); 67 68 task Timer_Server is 69 pragma Interrupt_Priority (System.Any_Priority'Last); 70 end Timer_Server; 71 72 -- The timer queue is a circular doubly linked list, ordered by absolute 73 -- wakeup time. The first item in the queue is Timer_Queue.Succ. 74 -- It is given a Resume_Time that is larger than any legitimate wakeup 75 -- time, so that the ordered insertion will always stop searching when it 76 -- gets back to the queue header block. 77 78 Timer_Queue : aliased Delay_Block; 79 80 ------------------------ 81 -- Cancel_Async_Delay -- 82 ------------------------ 83 84 -- This should (only) be called from the compiler-generated cleanup routine 85 -- for an async. select statement with delay statement as trigger. The 86 -- effect should be to remove the delay from the timer queue, and exit one 87 -- ATC nesting level. 88 -- The usage and logic are similar to Cancel_Protected_Entry_Call, but 89 -- simplified because this is not a true entry call. 90 91 procedure Cancel_Async_Delay (D : Delay_Block_Access) is 92 Dpred : Delay_Block_Access; 93 Dsucc : Delay_Block_Access; 94 95 begin 96 -- Note that we mark the delay as being cancelled 97 -- using a level value that is reserved. 98 99 -- make this operation idempotent 100 101 if D.Level = ATC_Level_Infinity then 102 return; 103 end if; 104 105 D.Level := ATC_Level_Infinity; 106 107 -- remove self from timer queue 108 109 STI.Defer_Abort_Nestable (D.Self_Id); 110 111 if Single_Lock then 112 STPO.Lock_RTS; 113 end if; 114 115 STPO.Write_Lock (Timer_Server_ID); 116 Dpred := D.Pred; 117 Dsucc := D.Succ; 118 Dpred.Succ := Dsucc; 119 Dsucc.Pred := Dpred; 120 D.Succ := D; 121 D.Pred := D; 122 STPO.Unlock (Timer_Server_ID); 123 124 -- Note that the above deletion code is required to be 125 -- idempotent, since the block may have been dequeued 126 -- previously by the Timer_Server. 127 128 -- leave the asynchronous select 129 130 STPO.Write_Lock (D.Self_Id); 131 STU.Exit_One_ATC_Level (D.Self_Id); 132 STPO.Unlock (D.Self_Id); 133 134 if Single_Lock then 135 STPO.Unlock_RTS; 136 end if; 137 138 STI.Undefer_Abort_Nestable (D.Self_Id); 139 end Cancel_Async_Delay; 140 141 --------------------------- 142 -- Enqueue_Time_Duration -- 143 --------------------------- 144 145 function Enqueue_Duration 146 (T : Duration; 147 D : Delay_Block_Access) return Boolean 148 is 149 begin 150 if T <= 0.0 then 151 D.Timed_Out := True; 152 STPO.Yield; 153 return False; 154 155 else 156 -- The corresponding call to Undefer_Abort is performed by the 157 -- expanded code (see exp_ch9). 158 159 STI.Defer_Abort (STPO.Self); 160 Time_Enqueue 161 (STPO.Monotonic_Clock 162 + Duration'Min (T, OSP.Max_Sensible_Delay), D); 163 return True; 164 end if; 165 end Enqueue_Duration; 166 167 ------------------ 168 -- Time_Enqueue -- 169 ------------------ 170 171 -- Allocate a queue element for the wakeup time T and put it in the 172 -- queue in wakeup time order. Assume we are on an asynchronous 173 -- select statement with delay trigger. Put the calling task to 174 -- sleep until either the delay expires or is cancelled. 175 176 -- We use one entry call record for this delay, since we have 177 -- to increment the ATC nesting level, but since it is not a 178 -- real entry call we do not need to use any of the fields of 179 -- the call record. The following code implements a subset of 180 -- the actions for the asynchronous case of Protected_Entry_Call, 181 -- much simplified since we know this never blocks, and does not 182 -- have the full semantics of a protected entry call. 183 184 procedure Time_Enqueue 185 (T : Duration; 186 D : Delay_Block_Access) 187 is 188 Self_Id : constant Task_Id := STPO.Self; 189 Q : Delay_Block_Access; 190 191 use type ST.Task_Id; 192 -- for visibility of operator "=" 193 194 begin 195 pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P')); 196 pragma Assert (Self_Id.Deferral_Level = 1, 197 "async delay from within abort-deferred region"); 198 199 if Self_Id.ATC_Nesting_Level = ATC_Level'Last then 200 raise Storage_Error with "not enough ATC nesting levels"; 201 end if; 202 203 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; 204 205 pragma Debug 206 (Debug.Trace (Self_Id, "ASD: entered ATC level: " & 207 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); 208 209 D.Level := Self_Id.ATC_Nesting_Level; 210 D.Self_Id := Self_Id; 211 D.Resume_Time := T; 212 213 if Single_Lock then 214 STPO.Lock_RTS; 215 end if; 216 217 STPO.Write_Lock (Timer_Server_ID); 218 219 -- Previously, there was code here to dynamically create 220 -- the Timer_Server task, if one did not already exist. 221 -- That code had a timing window that could allow multiple 222 -- timer servers to be created. Luckily, the need for 223 -- postponing creation of the timer server should now be 224 -- gone, since this package will only be linked in if 225 -- there are calls to enqueue calls on the timer server. 226 227 -- Insert D in the timer queue, at the position determined 228 -- by the wakeup time T. 229 230 Q := Timer_Queue.Succ; 231 232 while Q.Resume_Time < T loop 233 Q := Q.Succ; 234 end loop; 235 236 -- Q is the block that has Resume_Time equal to or greater than 237 -- T. After the insertion we want Q to be the successor of D. 238 239 D.Succ := Q; 240 D.Pred := Q.Pred; 241 D.Pred.Succ := D; 242 Q.Pred := D; 243 244 -- If the new element became the head of the queue, 245 -- signal the Timer_Server to wake up. 246 247 if Timer_Queue.Succ = D then 248 Timer_Attention := True; 249 STPO.Wakeup (Timer_Server_ID, ST.Timer_Server_Sleep); 250 end if; 251 252 STPO.Unlock (Timer_Server_ID); 253 254 if Single_Lock then 255 STPO.Unlock_RTS; 256 end if; 257 end Time_Enqueue; 258 259 --------------- 260 -- Timed_Out -- 261 --------------- 262 263 function Timed_Out (D : Delay_Block_Access) return Boolean is 264 begin 265 return D.Timed_Out; 266 end Timed_Out; 267 268 ------------------ 269 -- Timer_Server -- 270 ------------------ 271 272 task body Timer_Server is 273 function Get_Next_Wakeup_Time return Duration; 274 -- Used to initialize Next_Wakeup_Time, but also to ensure that 275 -- Make_Independent is called during the elaboration of this task. 276 277 -------------------------- 278 -- Get_Next_Wakeup_Time -- 279 -------------------------- 280 281 function Get_Next_Wakeup_Time return Duration is 282 begin 283 STU.Make_Independent; 284 return Duration'Last; 285 end Get_Next_Wakeup_Time; 286 287 -- Local Declarations 288 289 Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time; 290 Timedout : Boolean; 291 Yielded : Boolean; 292 Now : Duration; 293 Dequeued : Delay_Block_Access; 294 Dequeued_Task : Task_Id; 295 296 pragma Unreferenced (Timedout, Yielded); 297 298 begin 299 Timer_Server_ID := STPO.Self; 300 301 -- Since this package may be elaborated before System.Interrupt, 302 -- we need to call Setup_Interrupt_Mask explicitly to ensure that 303 -- this task has the proper signal mask. 304 305 Interrupt_Management.Operations.Setup_Interrupt_Mask; 306 307 -- Initialize the timer queue to empty, and make the wakeup time of the 308 -- header node be larger than any real wakeup time we will ever use. 309 310 loop 311 STI.Defer_Abort (Timer_Server_ID); 312 313 if Single_Lock then 314 STPO.Lock_RTS; 315 end if; 316 317 STPO.Write_Lock (Timer_Server_ID); 318 319 -- The timer server needs to catch pending aborts after finalization 320 -- of library packages. If it doesn't poll for it, the server will 321 -- sometimes hang. 322 323 if not Timer_Attention then 324 Timer_Server_ID.Common.State := ST.Timer_Server_Sleep; 325 326 if Next_Wakeup_Time = Duration'Last then 327 Timer_Server_ID.User_State := 1; 328 Next_Wakeup_Time := 329 STPO.Monotonic_Clock + OSP.Max_Sensible_Delay; 330 331 else 332 Timer_Server_ID.User_State := 2; 333 end if; 334 335 STPO.Timed_Sleep 336 (Timer_Server_ID, Next_Wakeup_Time, 337 OSP.Absolute_RT, ST.Timer_Server_Sleep, 338 Timedout, Yielded); 339 Timer_Server_ID.Common.State := ST.Runnable; 340 end if; 341 342 -- Service all of the wakeup requests on the queue whose times have 343 -- been reached, and update Next_Wakeup_Time to next wakeup time 344 -- after that (the wakeup time of the head of the queue if any, else 345 -- a time far in the future). 346 347 Timer_Server_ID.User_State := 3; 348 Timer_Attention := False; 349 350 Now := STPO.Monotonic_Clock; 351 while Timer_Queue.Succ.Resume_Time <= Now loop 352 353 -- Dequeue the waiting task from the front of the queue 354 355 pragma Debug (System.Tasking.Debug.Trace 356 (Timer_Server_ID, "Timer service: waking up waiting task", 'E')); 357 358 Dequeued := Timer_Queue.Succ; 359 Timer_Queue.Succ := Dequeued.Succ; 360 Dequeued.Succ.Pred := Dequeued.Pred; 361 Dequeued.Succ := Dequeued; 362 Dequeued.Pred := Dequeued; 363 364 -- We want to abort the queued task to the level of the async. 365 -- select statement with the delay. To do that, we need to lock 366 -- the ATCB of that task, but to avoid deadlock we need to release 367 -- the lock of the Timer_Server. This leaves a window in which 368 -- another task might perform an enqueue or dequeue operation on 369 -- the timer queue, but that is OK because we always restart the 370 -- next iteration at the head of the queue. 371 372 if Parameters.Runtime_Traces then 373 Send_Trace_Info (E_Kill, Dequeued.Self_Id); 374 end if; 375 376 STPO.Unlock (Timer_Server_ID); 377 STPO.Write_Lock (Dequeued.Self_Id); 378 Dequeued_Task := Dequeued.Self_Id; 379 Dequeued.Timed_Out := True; 380 STI.Locked_Abort_To_Level 381 (Timer_Server_ID, Dequeued_Task, Dequeued.Level - 1); 382 STPO.Unlock (Dequeued_Task); 383 STPO.Write_Lock (Timer_Server_ID); 384 end loop; 385 386 Next_Wakeup_Time := Timer_Queue.Succ.Resume_Time; 387 388 -- Service returns the Next_Wakeup_Time. 389 -- The Next_Wakeup_Time is either an infinity (no delay request) 390 -- or the wakeup time of the queue head. This value is used for 391 -- an actual delay in this server. 392 393 STPO.Unlock (Timer_Server_ID); 394 395 if Single_Lock then 396 STPO.Unlock_RTS; 397 end if; 398 399 STI.Undefer_Abort (Timer_Server_ID); 400 end loop; 401 end Timer_Server; 402 403 ------------------------------ 404 -- Package Body Elaboration -- 405 ------------------------------ 406 407begin 408 Timer_Queue.Succ := Timer_Queue'Access; 409 Timer_Queue.Pred := Timer_Queue'Access; 410 Timer_Queue.Resume_Time := Duration'Last; 411 Timer_Server_ID := To_System (Timer_Server'Identity); 412end System.Tasking.Async_Delays; 413