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