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