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