1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K I N G . U T I L I T I E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2011, 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 32-- This package provides RTS Internal Declarations 33 34-- These declarations are not part of the GNARLI 35 36pragma Polling (Off); 37-- Turn off polling, we do not want ATC polling to take place during tasking 38-- operations. It causes infinite loops and other problems. 39 40with System.Tasking.Debug; 41with System.Task_Primitives.Operations; 42with System.Tasking.Initialization; 43with System.Tasking.Queuing; 44with System.Parameters; 45with System.Traces.Tasking; 46 47package body System.Tasking.Utilities is 48 49 package STPO renames System.Task_Primitives.Operations; 50 51 use Parameters; 52 use Tasking.Debug; 53 use Task_Primitives; 54 use Task_Primitives.Operations; 55 56 use System.Traces; 57 use System.Traces.Tasking; 58 59 -------------------- 60 -- Abort_One_Task -- 61 -------------------- 62 63 -- Similar to Locked_Abort_To_Level (Self_ID, T, 0), but: 64 -- (1) caller should be holding no locks except RTS_Lock when Single_Lock 65 -- (2) may be called for tasks that have not yet been activated 66 -- (3) always aborts whole task 67 68 procedure Abort_One_Task (Self_ID : Task_Id; T : Task_Id) is 69 begin 70 if Parameters.Runtime_Traces then 71 Send_Trace_Info (T_Abort, Self_ID, T); 72 end if; 73 74 Write_Lock (T); 75 76 if T.Common.State = Unactivated then 77 T.Common.Activator := null; 78 T.Common.State := Terminated; 79 T.Callable := False; 80 Cancel_Queued_Entry_Calls (T); 81 82 elsif T.Common.State /= Terminated then 83 Initialization.Locked_Abort_To_Level (Self_ID, T, 0); 84 end if; 85 86 Unlock (T); 87 end Abort_One_Task; 88 89 ----------------- 90 -- Abort_Tasks -- 91 ----------------- 92 93 -- This must be called to implement the abort statement. 94 -- Much of the actual work of the abort is done by the abortee, 95 -- via the Abort_Handler signal handler, and propagation of the 96 -- Abort_Signal special exception. 97 98 procedure Abort_Tasks (Tasks : Task_List) is 99 Self_Id : constant Task_Id := STPO.Self; 100 C : Task_Id; 101 P : Task_Id; 102 103 begin 104 -- If pragma Detect_Blocking is active then Program_Error must be 105 -- raised if this potentially blocking operation is called from a 106 -- protected action. 107 108 if System.Tasking.Detect_Blocking 109 and then Self_Id.Common.Protected_Action_Nesting > 0 110 then 111 raise Program_Error with "potentially blocking operation"; 112 end if; 113 114 Initialization.Defer_Abort_Nestable (Self_Id); 115 116 -- ????? 117 -- Really should not be nested deferral here. 118 -- Patch for code generation error that defers abort before 119 -- evaluating parameters of an entry call (at least, timed entry 120 -- calls), and so may propagate an exception that causes abort 121 -- to remain undeferred indefinitely. See C97404B. When all 122 -- such bugs are fixed, this patch can be removed. 123 124 Lock_RTS; 125 126 for J in Tasks'Range loop 127 C := Tasks (J); 128 Abort_One_Task (Self_Id, C); 129 end loop; 130 131 C := All_Tasks_List; 132 133 while C /= null loop 134 if C.Pending_ATC_Level > 0 then 135 P := C.Common.Parent; 136 137 while P /= null loop 138 if P.Pending_ATC_Level = 0 then 139 Abort_One_Task (Self_Id, C); 140 exit; 141 end if; 142 143 P := P.Common.Parent; 144 end loop; 145 end if; 146 147 C := C.Common.All_Tasks_Link; 148 end loop; 149 150 Unlock_RTS; 151 Initialization.Undefer_Abort_Nestable (Self_Id); 152 end Abort_Tasks; 153 154 ------------------------------- 155 -- Cancel_Queued_Entry_Calls -- 156 ------------------------------- 157 158 -- This should only be called by T, unless T is a terminated previously 159 -- unactivated task. 160 161 procedure Cancel_Queued_Entry_Calls (T : Task_Id) is 162 Next_Entry_Call : Entry_Call_Link; 163 Entry_Call : Entry_Call_Link; 164 Self_Id : constant Task_Id := STPO.Self; 165 166 Caller : Task_Id; 167 pragma Unreferenced (Caller); 168 -- Should this be removed ??? 169 170 Level : Integer; 171 pragma Unreferenced (Level); 172 -- Should this be removed ??? 173 174 begin 175 pragma Assert (T = Self or else T.Common.State = Terminated); 176 177 for J in 1 .. T.Entry_Num loop 178 Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call); 179 180 while Entry_Call /= null loop 181 182 -- Leave Entry_Call.Done = False, since this is cancelled 183 184 Caller := Entry_Call.Self; 185 Entry_Call.Exception_To_Raise := Tasking_Error'Identity; 186 Queuing.Dequeue_Head (T.Entry_Queues (J), Next_Entry_Call); 187 Level := Entry_Call.Level - 1; 188 Unlock (T); 189 Write_Lock (Entry_Call.Self); 190 Initialization.Wakeup_Entry_Caller 191 (Self_Id, Entry_Call, Cancelled); 192 Unlock (Entry_Call.Self); 193 Write_Lock (T); 194 Entry_Call.State := Done; 195 Entry_Call := Next_Entry_Call; 196 end loop; 197 end loop; 198 end Cancel_Queued_Entry_Calls; 199 200 ------------------------ 201 -- Exit_One_ATC_Level -- 202 ------------------------ 203 204 -- Call only with abort deferred and holding lock of Self_Id. 205 -- This is a bit of common code for all entry calls. 206 -- The effect is to exit one level of ATC nesting. 207 208 -- If we have reached the desired ATC nesting level, reset the 209 -- requested level to effective infinity, to allow further calls. 210 -- In any case, reset Self_Id.Aborting, to allow re-raising of 211 -- Abort_Signal. 212 213 procedure Exit_One_ATC_Level (Self_ID : Task_Id) is 214 begin 215 Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level - 1; 216 217 pragma Debug 218 (Debug.Trace (Self_ID, "EOAL: exited to ATC level: " & 219 ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); 220 221 pragma Assert (Self_ID.ATC_Nesting_Level >= 1); 222 223 if Self_ID.Pending_ATC_Level < ATC_Level_Infinity then 224 if Self_ID.Pending_ATC_Level = Self_ID.ATC_Nesting_Level then 225 Self_ID.Pending_ATC_Level := ATC_Level_Infinity; 226 Self_ID.Aborting := False; 227 else 228 -- Force the next Undefer_Abort to re-raise Abort_Signal 229 230 pragma Assert 231 (Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level); 232 233 if Self_ID.Aborting then 234 Self_ID.ATC_Hack := True; 235 Self_ID.Pending_Action := True; 236 end if; 237 end if; 238 end if; 239 end Exit_One_ATC_Level; 240 241 ---------------------- 242 -- Make_Independent -- 243 ---------------------- 244 245 procedure Make_Independent is 246 Self_Id : constant Task_Id := STPO.Self; 247 Environment_Task : constant Task_Id := STPO.Environment_Task; 248 Parent : constant Task_Id := Self_Id.Common.Parent; 249 Parent_Needs_Updating : Boolean := False; 250 Master_of_Task : Integer; 251 252 begin 253 if Self_Id.Known_Tasks_Index /= -1 then 254 Known_Tasks (Self_Id.Known_Tasks_Index) := null; 255 end if; 256 257 Initialization.Defer_Abort (Self_Id); 258 259 if Single_Lock then 260 Lock_RTS; 261 end if; 262 263 Write_Lock (Environment_Task); 264 Write_Lock (Self_Id); 265 266 pragma Assert (Parent = Environment_Task 267 or else Self_Id.Master_of_Task = Library_Task_Level); 268 269 Master_of_Task := Self_Id.Master_of_Task; 270 Self_Id.Master_of_Task := Independent_Task_Level; 271 272 -- The run time assumes that the parent of an independent task is the 273 -- environment task. 274 275 if Parent /= Environment_Task then 276 277 -- We cannot lock three tasks at the same time, so defer the 278 -- operations on the parent. 279 280 Parent_Needs_Updating := True; 281 Self_Id.Common.Parent := Environment_Task; 282 end if; 283 284 -- Update Independent_Task_Count that is needed for the GLADE 285 -- termination rule. See also pending update in 286 -- System.Tasking.Stages.Check_Independent 287 288 Independent_Task_Count := Independent_Task_Count + 1; 289 290 Unlock (Self_Id); 291 292 -- Changing the parent after creation is not trivial. Do not forget 293 -- to update the old parent counts, and the new parent (i.e. the 294 -- Environment_Task) counts. 295 296 if Parent_Needs_Updating then 297 Write_Lock (Parent); 298 Parent.Awake_Count := Parent.Awake_Count - 1; 299 Parent.Alive_Count := Parent.Alive_Count - 1; 300 Environment_Task.Awake_Count := Environment_Task.Awake_Count + 1; 301 Environment_Task.Alive_Count := Environment_Task.Alive_Count + 1; 302 Unlock (Parent); 303 end if; 304 305 -- In case the environment task is already waiting for children to 306 -- complete. 307 -- ??? There may be a race condition if the environment task was not in 308 -- master completion sleep when this task was created, but now is 309 310 if Environment_Task.Common.State = Master_Completion_Sleep and then 311 Master_of_Task = Environment_Task.Master_Within 312 then 313 Environment_Task.Common.Wait_Count := 314 Environment_Task.Common.Wait_Count - 1; 315 end if; 316 317 Unlock (Environment_Task); 318 319 if Single_Lock then 320 Unlock_RTS; 321 end if; 322 323 Initialization.Undefer_Abort (Self_Id); 324 end Make_Independent; 325 326 ------------------ 327 -- Make_Passive -- 328 ------------------ 329 330 procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is 331 C : Task_Id := Self_ID; 332 P : Task_Id := C.Common.Parent; 333 334 Master_Completion_Phase : Integer; 335 336 begin 337 if P /= null then 338 Write_Lock (P); 339 end if; 340 341 Write_Lock (C); 342 343 if Task_Completed then 344 Self_ID.Common.State := Terminated; 345 346 if Self_ID.Awake_Count = 0 then 347 348 -- We are completing via a terminate alternative. 349 -- Our parent should wait in Phase 2 of Complete_Master. 350 351 Master_Completion_Phase := 2; 352 353 pragma Assert (Task_Completed); 354 pragma Assert (Self_ID.Terminate_Alternative); 355 pragma Assert (Self_ID.Alive_Count = 1); 356 357 else 358 -- We are NOT on a terminate alternative. 359 -- Our parent should wait in Phase 1 of Complete_Master. 360 361 Master_Completion_Phase := 1; 362 pragma Assert (Self_ID.Awake_Count >= 1); 363 end if; 364 365 -- We are accepting with a terminate alternative 366 367 else 368 if Self_ID.Open_Accepts = null then 369 370 -- Somebody started a rendezvous while we had our lock open. 371 -- Skip the terminate alternative. 372 373 Unlock (C); 374 375 if P /= null then 376 Unlock (P); 377 end if; 378 379 return; 380 end if; 381 382 Self_ID.Terminate_Alternative := True; 383 Master_Completion_Phase := 0; 384 385 pragma Assert (Self_ID.Terminate_Alternative); 386 pragma Assert (Self_ID.Awake_Count >= 1); 387 end if; 388 389 if Master_Completion_Phase = 2 then 390 391 -- Since our Awake_Count is zero but our Alive_Count 392 -- is nonzero, we have been accepting with a terminate 393 -- alternative, and we now have been told to terminate 394 -- by a completed master (in some ancestor task) that 395 -- is waiting (with zero Awake_Count) in Phase 2 of 396 -- Complete_Master. 397 398 pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M')); 399 400 pragma Assert (P /= null); 401 402 C.Alive_Count := C.Alive_Count - 1; 403 404 if C.Alive_Count > 0 then 405 Unlock (C); 406 Unlock (P); 407 return; 408 end if; 409 410 -- C's count just went to zero, indicating that 411 -- all of C's dependents are terminated. 412 -- C has a parent, P. 413 414 loop 415 -- C's count just went to zero, indicating that all of C's 416 -- dependents are terminated. C has a parent, P. Notify P that 417 -- C and its dependents have all terminated. 418 419 P.Alive_Count := P.Alive_Count - 1; 420 exit when P.Alive_Count > 0; 421 Unlock (C); 422 Unlock (P); 423 C := P; 424 P := C.Common.Parent; 425 426 -- Environment task cannot have terminated yet 427 428 pragma Assert (P /= null); 429 430 Write_Lock (P); 431 Write_Lock (C); 432 end loop; 433 434 if P.Common.State = Master_Phase_2_Sleep 435 and then C.Master_of_Task = P.Master_Within 436 then 437 pragma Assert (P.Common.Wait_Count > 0); 438 P.Common.Wait_Count := P.Common.Wait_Count - 1; 439 440 if P.Common.Wait_Count = 0 then 441 Wakeup (P, Master_Phase_2_Sleep); 442 end if; 443 end if; 444 445 Unlock (C); 446 Unlock (P); 447 return; 448 end if; 449 450 -- We are terminating in Phase 1 or Complete_Master, 451 -- or are accepting on a terminate alternative. 452 453 C.Awake_Count := C.Awake_Count - 1; 454 455 if Task_Completed then 456 C.Alive_Count := C.Alive_Count - 1; 457 end if; 458 459 if C.Awake_Count > 0 or else P = null then 460 Unlock (C); 461 462 if P /= null then 463 Unlock (P); 464 end if; 465 466 return; 467 end if; 468 469 -- C's count just went to zero, indicating that all of C's 470 -- dependents are terminated or accepting with terminate alt. 471 -- C has a parent, P. 472 473 loop 474 -- Notify P that C has gone passive 475 476 if P.Awake_Count > 0 then 477 P.Awake_Count := P.Awake_Count - 1; 478 end if; 479 480 if Task_Completed and then C.Alive_Count = 0 then 481 P.Alive_Count := P.Alive_Count - 1; 482 end if; 483 484 exit when P.Awake_Count > 0; 485 Unlock (C); 486 Unlock (P); 487 C := P; 488 P := C.Common.Parent; 489 490 if P = null then 491 return; 492 end if; 493 494 Write_Lock (P); 495 Write_Lock (C); 496 end loop; 497 498 -- P has non-passive dependents 499 500 if P.Common.State = Master_Completion_Sleep 501 and then C.Master_of_Task = P.Master_Within 502 then 503 pragma Debug 504 (Debug.Trace 505 (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M')); 506 507 -- If parent is in Master_Completion_Sleep, it cannot be on a 508 -- terminate alternative, hence it cannot have Wait_Count of 509 -- zero. ???Except that the race condition in Make_Independent can 510 -- cause Wait_Count to be zero, so we need to check for that. 511 512 if P.Common.Wait_Count > 0 then 513 P.Common.Wait_Count := P.Common.Wait_Count - 1; 514 end if; 515 516 if P.Common.Wait_Count = 0 then 517 Wakeup (P, Master_Completion_Sleep); 518 end if; 519 520 else 521 pragma Debug 522 (Debug.Trace 523 (Self_ID, "Make_Passive: Phase 1, parent awake", 'M')); 524 null; 525 end if; 526 527 Unlock (C); 528 Unlock (P); 529 end Make_Passive; 530 531end System.Tasking.Utilities; 532