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