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