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