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-2014, 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 function Make_Independent return Boolean 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 250 begin 251 if Self_Id.Known_Tasks_Index /= -1 then 252 Known_Tasks (Self_Id.Known_Tasks_Index) := null; 253 end if; 254 255 Initialization.Defer_Abort (Self_Id); 256 257 if Single_Lock then 258 Lock_RTS; 259 end if; 260 261 Write_Lock (Environment_Task); 262 Write_Lock (Self_Id); 263 264 -- The run time assumes that the parent of an independent task is the 265 -- environment task. 266 267 pragma Assert (Parent = Environment_Task); 268 269 Self_Id.Master_of_Task := Independent_Task_Level; 270 271 -- Update Independent_Task_Count that is needed for the GLADE 272 -- termination rule. See also pending update in 273 -- System.Tasking.Stages.Check_Independent 274 275 Independent_Task_Count := Independent_Task_Count + 1; 276 277 -- This should be called before the task reaches its "begin" (see spec), 278 -- which ensures that the environment task cannot race ahead and be 279 -- already waiting for children to complete. 280 281 Unlock (Self_Id); 282 pragma Assert (Environment_Task.Common.State /= Master_Completion_Sleep); 283 284 Unlock (Environment_Task); 285 286 if Single_Lock then 287 Unlock_RTS; 288 end if; 289 290 Initialization.Undefer_Abort (Self_Id); 291 292 -- Return True. Actually the return value is junk, since we expect it 293 -- always to be ignored (see spec), but we have to return something! 294 295 return True; 296 end Make_Independent; 297 298 ------------------ 299 -- Make_Passive -- 300 ------------------ 301 302 procedure Make_Passive (Self_ID : Task_Id; Task_Completed : Boolean) is 303 C : Task_Id := Self_ID; 304 P : Task_Id := C.Common.Parent; 305 306 Master_Completion_Phase : Integer; 307 308 begin 309 if P /= null then 310 Write_Lock (P); 311 end if; 312 313 Write_Lock (C); 314 315 if Task_Completed then 316 Self_ID.Common.State := Terminated; 317 318 if Self_ID.Awake_Count = 0 then 319 320 -- We are completing via a terminate alternative. 321 -- Our parent should wait in Phase 2 of Complete_Master. 322 323 Master_Completion_Phase := 2; 324 325 pragma Assert (Task_Completed); 326 pragma Assert (Self_ID.Terminate_Alternative); 327 pragma Assert (Self_ID.Alive_Count = 1); 328 329 else 330 -- We are NOT on a terminate alternative. 331 -- Our parent should wait in Phase 1 of Complete_Master. 332 333 Master_Completion_Phase := 1; 334 pragma Assert (Self_ID.Awake_Count >= 1); 335 end if; 336 337 -- We are accepting with a terminate alternative 338 339 else 340 if Self_ID.Open_Accepts = null then 341 342 -- Somebody started a rendezvous while we had our lock open. 343 -- Skip the terminate alternative. 344 345 Unlock (C); 346 347 if P /= null then 348 Unlock (P); 349 end if; 350 351 return; 352 end if; 353 354 Self_ID.Terminate_Alternative := True; 355 Master_Completion_Phase := 0; 356 357 pragma Assert (Self_ID.Terminate_Alternative); 358 pragma Assert (Self_ID.Awake_Count >= 1); 359 end if; 360 361 if Master_Completion_Phase = 2 then 362 363 -- Since our Awake_Count is zero but our Alive_Count 364 -- is nonzero, we have been accepting with a terminate 365 -- alternative, and we now have been told to terminate 366 -- by a completed master (in some ancestor task) that 367 -- is waiting (with zero Awake_Count) in Phase 2 of 368 -- Complete_Master. 369 370 pragma Debug (Debug.Trace (Self_ID, "Make_Passive: Phase 2", 'M')); 371 372 pragma Assert (P /= null); 373 374 C.Alive_Count := C.Alive_Count - 1; 375 376 if C.Alive_Count > 0 then 377 Unlock (C); 378 Unlock (P); 379 return; 380 end if; 381 382 -- C's count just went to zero, indicating that 383 -- all of C's dependents are terminated. 384 -- C has a parent, P. 385 386 loop 387 -- C's count just went to zero, indicating that all of C's 388 -- dependents are terminated. C has a parent, P. Notify P that 389 -- C and its dependents have all terminated. 390 391 P.Alive_Count := P.Alive_Count - 1; 392 exit when P.Alive_Count > 0; 393 Unlock (C); 394 Unlock (P); 395 C := P; 396 P := C.Common.Parent; 397 398 -- Environment task cannot have terminated yet 399 400 pragma Assert (P /= null); 401 402 Write_Lock (P); 403 Write_Lock (C); 404 end loop; 405 406 if P.Common.State = Master_Phase_2_Sleep 407 and then C.Master_of_Task = P.Master_Within 408 then 409 pragma Assert (P.Common.Wait_Count > 0); 410 P.Common.Wait_Count := P.Common.Wait_Count - 1; 411 412 if P.Common.Wait_Count = 0 then 413 Wakeup (P, Master_Phase_2_Sleep); 414 end if; 415 end if; 416 417 Unlock (C); 418 Unlock (P); 419 return; 420 end if; 421 422 -- We are terminating in Phase 1 or Complete_Master, 423 -- or are accepting on a terminate alternative. 424 425 C.Awake_Count := C.Awake_Count - 1; 426 427 if Task_Completed then 428 C.Alive_Count := C.Alive_Count - 1; 429 end if; 430 431 if C.Awake_Count > 0 or else P = null then 432 Unlock (C); 433 434 if P /= null then 435 Unlock (P); 436 end if; 437 438 return; 439 end if; 440 441 -- C's count just went to zero, indicating that all of C's 442 -- dependents are terminated or accepting with terminate alt. 443 -- C has a parent, P. 444 445 loop 446 -- Notify P that C has gone passive 447 448 if P.Awake_Count > 0 then 449 P.Awake_Count := P.Awake_Count - 1; 450 end if; 451 452 if Task_Completed and then C.Alive_Count = 0 then 453 P.Alive_Count := P.Alive_Count - 1; 454 end if; 455 456 exit when P.Awake_Count > 0; 457 Unlock (C); 458 Unlock (P); 459 C := P; 460 P := C.Common.Parent; 461 462 if P = null then 463 return; 464 end if; 465 466 Write_Lock (P); 467 Write_Lock (C); 468 end loop; 469 470 -- P has non-passive dependents 471 472 if P.Common.State = Master_Completion_Sleep 473 and then C.Master_of_Task = P.Master_Within 474 then 475 pragma Debug 476 (Debug.Trace 477 (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M')); 478 479 -- If parent is in Master_Completion_Sleep, it cannot be on a 480 -- terminate alternative, hence it cannot have Wait_Count of zero. 481 482 pragma Assert (P.Common.Wait_Count > 0); 483 P.Common.Wait_Count := P.Common.Wait_Count - 1; 484 485 if P.Common.Wait_Count = 0 then 486 Wakeup (P, Master_Completion_Sleep); 487 end if; 488 489 else 490 pragma Debug 491 (Debug.Trace (Self_ID, "Make_Passive: Phase 1, parent awake", 'M')); 492 null; 493 end if; 494 495 Unlock (C); 496 Unlock (P); 497 end Make_Passive; 498 499end System.Tasking.Utilities; 500