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 . S T A G E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2003, 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 34pragma Polling (Off); 35-- Turn off polling, we do not want ATC polling to take place during 36-- tasking operations. It causes infinite loops and other problems. 37 38with Ada.Exceptions; 39-- used for Raise_Exception 40 41with System.Tasking.Debug; 42-- used for enabling tasking facilities with gdb 43 44with System.Address_Image; 45-- used for the function itself. 46 47with System.Parameters; 48-- used for Size_Type 49-- Single_Lock 50-- Runtime_Traces 51 52with System.Task_Info; 53-- used for Task_Info_Type 54 55with System.Task_Primitives.Operations; 56-- used for Finalize_Lock 57-- Enter_Task 58-- Write_Lock 59-- Unlock 60-- Sleep 61-- Wakeup 62-- Get_Priority 63-- Lock/Unlock_RTS 64-- New_ATCB 65 66with System.Soft_Links; 67-- These are procedure pointers to non-tasking routines that use 68-- task specific data. In the absence of tasking, these routines 69-- refer to global data. In the presense of tasking, they must be 70-- replaced with pointers to task-specific versions. 71-- Also used for Create_TSD, Destroy_TSD, Get_Current_Excep 72 73with System.Tasking.Initialization; 74-- Used for Remove_From_All_Tasks_List 75-- Defer_Abort 76-- Undefer_Abort 77-- Initialization.Poll_Base_Priority_Change 78-- Finalize_Attributes_Link 79-- Initialize_Attributes_Link 80 81pragma Elaborate_All (System.Tasking.Initialization); 82-- This insures that tasking is initialized if any tasks are created. 83 84with System.Tasking.Utilities; 85-- Used for Make_Passive 86-- Abort_One_Task 87 88with System.Tasking.Queuing; 89-- Used for Dequeue_Head 90 91with System.Tasking.Rendezvous; 92-- Used for Call_Simple 93 94with System.OS_Primitives; 95-- Used for Delay_Modes 96 97with System.Finalization_Implementation; 98-- Used for System.Finalization_Implementation.Finalize_Global_List 99 100with System.Secondary_Stack; 101-- used for SS_Init; 102 103with System.Storage_Elements; 104-- used for Storage_Array; 105 106with System.Standard_Library; 107-- used for Exception_Trace 108 109with System.Traces.Tasking; 110-- used for Send_Trace_Info 111 112package body System.Tasking.Stages is 113 114 package STPO renames System.Task_Primitives.Operations; 115 package SSL renames System.Soft_Links; 116 package SSE renames System.Storage_Elements; 117 package SST renames System.Secondary_Stack; 118 119 use Ada.Exceptions; 120 121 use Parameters; 122 use Task_Primitives; 123 use Task_Primitives.Operations; 124 use Task_Info; 125 126 use System.Traces; 127 use System.Traces.Tasking; 128 129 ----------------------- 130 -- Local Subprograms -- 131 ----------------------- 132 133 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_ID); 134 -- This procedure outputs the task specific message for exception 135 -- tracing purposes. 136 137 procedure Task_Wrapper (Self_ID : Task_ID); 138 -- This is the procedure that is called by the GNULL from the 139 -- new context when a task is created. It waits for activation 140 -- and then calls the task body procedure. When the task body 141 -- procedure completes, it terminates the task. 142 143 procedure Vulnerable_Complete_Task (Self_ID : Task_ID); 144 -- Complete the calling task. 145 -- This procedure must be called with abort deferred. 146 -- It should only be called by Complete_Task and 147 -- Finalizate_Global_Tasks (for the environment task). 148 149 procedure Vulnerable_Complete_Master (Self_ID : Task_ID); 150 -- Complete the current master of the calling task. 151 -- This procedure must be called with abort deferred. 152 -- It should only be called by Vulnerable_Complete_Task and 153 -- Complete_Master. 154 155 procedure Vulnerable_Complete_Activation (Self_ID : Task_ID); 156 -- Signal to Self_ID's activator that Self_ID has 157 -- completed activation. 158 -- 159 -- Call this procedure with abort deferred. 160 161 procedure Abort_Dependents (Self_ID : Task_ID); 162 -- Abort all the direct dependents of Self at its current master 163 -- nesting level, plus all of their dependents, transitively. 164 -- RTS_Lock should be locked by the caller. 165 166 procedure Vulnerable_Free_Task (T : Task_ID); 167 -- Recover all runtime system storage associated with the task T. 168 -- This should only be called after T has terminated and will no 169 -- longer be referenced. 170 -- 171 -- For tasks created by an allocator that fails, due to an exception, 172 -- it is called from Expunge_Unactivated_Tasks. 173 -- 174 -- It is also called from Unchecked_Deallocation, for objects that 175 -- are or contain tasks. 176 -- 177 -- Different code is used at master completion, in Terminate_Dependents, 178 -- due to a need for tighter synchronization with the master. 179 180 ---------------------- 181 -- Abort_Dependents -- 182 ---------------------- 183 184 procedure Abort_Dependents (Self_ID : Task_ID) is 185 C : Task_ID; 186 P : Task_ID; 187 188 begin 189 C := All_Tasks_List; 190 191 while C /= null loop 192 P := C.Common.Parent; 193 194 while P /= null loop 195 if P = Self_ID then 196 -- ??? C is supposed to take care of its own dependents, so 197 -- there should be no need to worry about them. Need to double 198 -- check this. 199 200 if C.Master_of_Task = Self_ID.Master_Within then 201 Utilities.Abort_One_Task (Self_ID, C); 202 C.Dependents_Aborted := True; 203 end if; 204 205 exit; 206 end if; 207 208 P := P.Common.Parent; 209 end loop; 210 211 C := C.Common.All_Tasks_Link; 212 end loop; 213 214 Self_ID.Dependents_Aborted := True; 215 end Abort_Dependents; 216 217 ----------------- 218 -- Abort_Tasks -- 219 ----------------- 220 221 procedure Abort_Tasks (Tasks : Task_List) is 222 begin 223 Utilities.Abort_Tasks (Tasks); 224 end Abort_Tasks; 225 226 -------------------- 227 -- Activate_Tasks -- 228 -------------------- 229 230 -- Note that locks of activator and activated task are both locked 231 -- here. This is necessary because C.Common.State and 232 -- Self.Common.Wait_Count have to be synchronized. This is safe from 233 -- deadlock because the activator is always created before the activated 234 -- task. That satisfies our in-order-of-creation ATCB locking policy. 235 236 -- At one point, we may also lock the parent, if the parent is 237 -- different from the activator. That is also consistent with the 238 -- lock ordering policy, since the activator cannot be created 239 -- before the parent. 240 241 -- Since we are holding both the activator's lock, and Task_Wrapper 242 -- locks that before it does anything more than initialize the 243 -- low-level ATCB components, it should be safe to wait to update 244 -- the counts until we see that the thread creation is successful. 245 246 -- If the thread creation fails, we do need to close the entries 247 -- of the task. The first phase, of dequeuing calls, only requires 248 -- locking the acceptor's ATCB, but the waking up of the callers 249 -- requires locking the caller's ATCB. We cannot safely do this 250 -- while we are holding other locks. Therefore, the queue-clearing 251 -- operation is done in a separate pass over the activation chain. 252 253 procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is 254 Self_ID : constant Task_ID := STPO.Self; 255 P : Task_ID; 256 C : Task_ID; 257 Next_C, Last_C : Task_ID; 258 Activate_Prio : System.Any_Priority; 259 Success : Boolean; 260 All_Elaborated : Boolean := True; 261 262 begin 263 pragma Debug 264 (Debug.Trace (Self_ID, "Activate_Tasks", 'C')); 265 266 Initialization.Defer_Abort_Nestable (Self_ID); 267 268 pragma Assert (Self_ID.Common.Wait_Count = 0); 269 270 -- Lock RTS_Lock, to prevent activated tasks 271 -- from racing ahead before we finish activating the chain. 272 273 Lock_RTS; 274 275 -- Check that all task bodies have been elaborated. 276 277 C := Chain_Access.T_ID; 278 Last_C := null; 279 280 while C /= null loop 281 if C.Common.Elaborated /= null 282 and then not C.Common.Elaborated.all 283 then 284 All_Elaborated := False; 285 end if; 286 287 -- Reverse the activation chain so that tasks are 288 -- activated in the same order they're declared. 289 290 Next_C := C.Common.Activation_Link; 291 C.Common.Activation_Link := Last_C; 292 Last_C := C; 293 C := Next_C; 294 end loop; 295 296 Chain_Access.T_ID := Last_C; 297 298 if not All_Elaborated then 299 Unlock_RTS; 300 Initialization.Undefer_Abort_Nestable (Self_ID); 301 Raise_Exception 302 (Program_Error'Identity, "Some tasks have not been elaborated"); 303 end if; 304 305 -- Activate all the tasks in the chain. 306 -- Creation of the thread of control was deferred until 307 -- activation. So create it now. 308 309 C := Chain_Access.T_ID; 310 311 while C /= null loop 312 if C.Common.State /= Terminated then 313 pragma Assert (C.Common.State = Unactivated); 314 315 P := C.Common.Parent; 316 Write_Lock (P); 317 Write_Lock (C); 318 319 if C.Common.Base_Priority < Get_Priority (Self_ID) then 320 Activate_Prio := Get_Priority (Self_ID); 321 else 322 Activate_Prio := C.Common.Base_Priority; 323 end if; 324 325 System.Task_Primitives.Operations.Create_Task 326 (C, Task_Wrapper'Address, 327 Parameters.Size_Type 328 (C.Common.Compiler_Data.Pri_Stack_Info.Size), 329 Activate_Prio, Success); 330 331 -- There would be a race between the created task and the 332 -- creator to do the following initialization, if we did not 333 -- have a Lock/Unlock_RTS pair in the task wrapper to prevent 334 -- it from racing ahead. 335 336 if Success then 337 C.Common.State := Runnable; 338 C.Awake_Count := 1; 339 C.Alive_Count := 1; 340 P.Awake_Count := P.Awake_Count + 1; 341 P.Alive_Count := P.Alive_Count + 1; 342 343 if P.Common.State = Master_Completion_Sleep and then 344 C.Master_of_Task = P.Master_Within 345 then 346 pragma Assert (Self_ID /= P); 347 P.Common.Wait_Count := P.Common.Wait_Count + 1; 348 end if; 349 350 Unlock (C); 351 Unlock (P); 352 353 else 354 -- No need to set Awake_Count, State, etc. here since the loop 355 -- below will do that for any Unactivated tasks. 356 357 Unlock (C); 358 Unlock (P); 359 Self_ID.Common.Activation_Failed := True; 360 end if; 361 end if; 362 363 C := C.Common.Activation_Link; 364 end loop; 365 366 if not Single_Lock then 367 Unlock_RTS; 368 end if; 369 370 -- Close the entries of any tasks that failed thread creation, 371 -- and count those that have not finished activation. 372 373 Write_Lock (Self_ID); 374 Self_ID.Common.State := Activator_Sleep; 375 376 C := Chain_Access.T_ID; 377 while C /= null loop 378 Write_Lock (C); 379 380 if C.Common.State = Unactivated then 381 C.Common.Activator := null; 382 C.Common.State := Terminated; 383 C.Callable := False; 384 Utilities.Cancel_Queued_Entry_Calls (C); 385 386 elsif C.Common.Activator /= null then 387 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; 388 end if; 389 390 Unlock (C); 391 P := C.Common.Activation_Link; 392 C.Common.Activation_Link := null; 393 C := P; 394 end loop; 395 396 -- Wait for the activated tasks to complete activation. It is 397 -- unsafe to abort any of these tasks until the count goes to zero. 398 399 loop 400 Initialization.Poll_Base_Priority_Change (Self_ID); 401 exit when Self_ID.Common.Wait_Count = 0; 402 Sleep (Self_ID, Activator_Sleep); 403 end loop; 404 405 Self_ID.Common.State := Runnable; 406 Unlock (Self_ID); 407 408 if Single_Lock then 409 Unlock_RTS; 410 end if; 411 412 -- Remove the tasks from the chain 413 414 Chain_Access.T_ID := null; 415 Initialization.Undefer_Abort_Nestable (Self_ID); 416 417 if Self_ID.Common.Activation_Failed then 418 Self_ID.Common.Activation_Failed := False; 419 Raise_Exception (Tasking_Error'Identity, 420 "Failure during activation"); 421 end if; 422 end Activate_Tasks; 423 424 ------------------------- 425 -- Complete_Activation -- 426 ------------------------- 427 428 procedure Complete_Activation is 429 Self_ID : constant Task_ID := STPO.Self; 430 begin 431 Initialization.Defer_Abort_Nestable (Self_ID); 432 433 if Single_Lock then 434 Lock_RTS; 435 end if; 436 437 Vulnerable_Complete_Activation (Self_ID); 438 439 if Single_Lock then 440 Unlock_RTS; 441 end if; 442 443 Initialization.Undefer_Abort_Nestable (Self_ID); 444 445 -- ??? 446 -- Why do we need to allow for nested deferral here? 447 448 if Runtime_Traces then 449 Send_Trace_Info (T_Activate); 450 end if; 451 end Complete_Activation; 452 453 --------------------- 454 -- Complete_Master -- 455 --------------------- 456 457 procedure Complete_Master is 458 Self_ID : constant Task_ID := STPO.Self; 459 460 begin 461 pragma Assert (Self_ID.Deferral_Level > 0); 462 463 Vulnerable_Complete_Master (Self_ID); 464 end Complete_Master; 465 466 ------------------- 467 -- Complete_Task -- 468 ------------------- 469 470 -- See comments on Vulnerable_Complete_Task for details 471 472 procedure Complete_Task is 473 Self_ID : constant Task_ID := STPO.Self; 474 begin 475 pragma Assert (Self_ID.Deferral_Level > 0); 476 477 Vulnerable_Complete_Task (Self_ID); 478 479 -- All of our dependents have terminated. Never undefer abort again! 480 481 end Complete_Task; 482 483 ----------------- 484 -- Create_Task -- 485 ----------------- 486 487 -- Compiler interface only. Do not call from within the RTS. 488 -- This must be called to create a new task. 489 490 procedure Create_Task 491 (Priority : Integer; 492 Size : System.Parameters.Size_Type; 493 Task_Info : System.Task_Info.Task_Info_Type; 494 Num_Entries : Task_Entry_Index; 495 Master : Master_Level; 496 State : Task_Procedure_Access; 497 Discriminants : System.Address; 498 Elaborated : Access_Boolean; 499 Chain : in out Activation_Chain; 500 Task_Image : String; 501 Created_Task : out Task_ID) 502 is 503 T, P : Task_ID; 504 Self_ID : constant Task_ID := STPO.Self; 505 Success : Boolean; 506 Base_Priority : System.Any_Priority; 507 Len : Natural; 508 509 begin 510 pragma Debug 511 (Debug.Trace (Self_ID, "Create_Task", 'C')); 512 513 if Priority = Unspecified_Priority then 514 Base_Priority := Self_ID.Common.Base_Priority; 515 else 516 Base_Priority := System.Any_Priority (Priority); 517 end if; 518 519 -- Find parent P of new Task, via master level number 520 521 P := Self_ID; 522 523 if P /= null then 524 while P.Master_of_Task >= Master loop 525 P := P.Common.Parent; 526 exit when P = null; 527 end loop; 528 end if; 529 530 Initialization.Defer_Abort_Nestable (Self_ID); 531 532 begin 533 T := New_ATCB (Num_Entries); 534 535 exception 536 when others => 537 Initialization.Undefer_Abort_Nestable (Self_ID); 538 Raise_Exception (Storage_Error'Identity, "Cannot allocate task"); 539 end; 540 541 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. 542 -- Up to this point, it is possible that we may be part of 543 -- a family of tasks that is being aborted. 544 545 Lock_RTS; 546 Write_Lock (Self_ID); 547 548 -- Now, we must check that we have not been aborted. 549 -- If so, we should give up on creating this task, 550 -- and simply return. 551 552 if not Self_ID.Callable then 553 pragma Assert (Self_ID.Pending_ATC_Level = 0); 554 pragma Assert (Self_ID.Pending_Action); 555 pragma Assert (Chain.T_ID = null 556 or else Chain.T_ID.Common.State = Unactivated); 557 558 Unlock (Self_ID); 559 Unlock_RTS; 560 Initialization.Undefer_Abort_Nestable (Self_ID); 561 562 -- ??? Should never get here 563 564 pragma Assert (False); 565 raise Standard'Abort_Signal; 566 end if; 567 568 Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, 569 Base_Priority, Task_Info, Size, T, Success); 570 571 if not Success then 572 Unlock (Self_ID); 573 Unlock_RTS; 574 Initialization.Undefer_Abort_Nestable (Self_ID); 575 Raise_Exception 576 (Storage_Error'Identity, "Failed to initialize task"); 577 end if; 578 579 T.Master_of_Task := Master; 580 T.Master_Within := T.Master_of_Task + 1; 581 582 for L in T.Entry_Calls'Range loop 583 T.Entry_Calls (L).Self := T; 584 T.Entry_Calls (L).Level := L; 585 end loop; 586 587 if Task_Image'Length = 0 then 588 T.Common.Task_Image_Len := 0; 589 else 590 Len := 1; 591 T.Common.Task_Image (1) := Task_Image (Task_Image'First); 592 593 for J in Task_Image'First + 1 .. Task_Image'Last loop 594 595 -- Remove unwanted blank space generated by 'Image 596 597 if Task_Image (J) /= ' ' 598 or else Task_Image (J - 1) /= '(' 599 then 600 Len := Len + 1; 601 T.Common.Task_Image (Len) := Task_Image (J); 602 603 exit when Len = T.Common.Task_Image'Last; 604 end if; 605 end loop; 606 607 T.Common.Task_Image_Len := Len; 608 end if; 609 610 Unlock (Self_ID); 611 Unlock_RTS; 612 613 -- Create TSD as early as possible in the creation of a task, since it 614 -- may be used by the operation of Ada code within the task. 615 616 SSL.Create_TSD (T.Common.Compiler_Data); 617 T.Common.Activation_Link := Chain.T_ID; 618 Chain.T_ID := T; 619 Initialization.Initialize_Attributes_Link.all (T); 620 Created_Task := T; 621 Initialization.Undefer_Abort_Nestable (Self_ID); 622 623 if Runtime_Traces then 624 Send_Trace_Info (T_Create, T); 625 end if; 626 end Create_Task; 627 628 -------------------- 629 -- Current_Master -- 630 -------------------- 631 632 function Current_Master return Master_Level is 633 begin 634 return STPO.Self.Master_Within; 635 end Current_Master; 636 637 ------------------ 638 -- Enter_Master -- 639 ------------------ 640 641 procedure Enter_Master is 642 Self_ID : constant Task_ID := STPO.Self; 643 644 begin 645 Self_ID.Master_Within := Self_ID.Master_Within + 1; 646 end Enter_Master; 647 648 ------------------------------- 649 -- Expunge_Unactivated_Tasks -- 650 ------------------------------- 651 652 -- See procedure Close_Entries for the general case. 653 654 procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is 655 Self_ID : constant Task_ID := STPO.Self; 656 C : Task_ID; 657 Call : Entry_Call_Link; 658 Temp : Task_ID; 659 660 begin 661 pragma Debug 662 (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C')); 663 664 Initialization.Defer_Abort_Nestable (Self_ID); 665 666 -- ??? 667 -- Experimentation has shown that abort is sometimes (but not 668 -- always) already deferred when this is called. 669 670 -- That may indicate an error. Find out what is going on. 671 672 C := Chain.T_ID; 673 674 while C /= null loop 675 pragma Assert (C.Common.State = Unactivated); 676 677 Temp := C.Common.Activation_Link; 678 679 if C.Common.State = Unactivated then 680 Lock_RTS; 681 Write_Lock (C); 682 683 for J in 1 .. C.Entry_Num loop 684 Queuing.Dequeue_Head (C.Entry_Queues (J), Call); 685 pragma Assert (Call = null); 686 end loop; 687 688 Unlock (C); 689 690 Initialization.Remove_From_All_Tasks_List (C); 691 Unlock_RTS; 692 693 Vulnerable_Free_Task (C); 694 C := Temp; 695 end if; 696 end loop; 697 698 Chain.T_ID := null; 699 Initialization.Undefer_Abort_Nestable (Self_ID); 700 end Expunge_Unactivated_Tasks; 701 702 --------------------------- 703 -- Finalize_Global_Tasks -- 704 --------------------------- 705 706 -- ??? 707 -- We have a potential problem here if finalization of global 708 -- objects does anything with signals or the timer server, since 709 -- by that time those servers have terminated. 710 711 -- It is hard to see how that would occur. 712 713 -- However, a better solution might be to do all this finalization 714 -- using the global finalization chain. 715 716 procedure Finalize_Global_Tasks is 717 Self_ID : constant Task_ID := STPO.Self; 718 Ignore : Boolean; 719 720 begin 721 if Self_ID.Deferral_Level = 0 then 722 -- ??? 723 -- In principle, we should be able to predict whether 724 -- abort is already deferred here (and it should not be deferred 725 -- yet but in practice it seems Finalize_Global_Tasks is being 726 -- called sometimes, from RTS code for exceptions, with abort already 727 -- deferred. 728 729 Initialization.Defer_Abort_Nestable (Self_ID); 730 731 -- Never undefer again!!! 732 end if; 733 734 -- This code is only executed by the environment task 735 736 pragma Assert (Self_ID = Environment_Task); 737 738 -- Set Environment_Task'Callable to false to notify library-level tasks 739 -- that it is waiting for them (cf 5619-003). 740 741 Self_ID.Callable := False; 742 743 -- Exit level 2 master, for normal tasks in library-level packages. 744 745 Complete_Master; 746 747 -- Force termination of "independent" library-level server tasks. 748 749 Lock_RTS; 750 751 Abort_Dependents (Self_ID); 752 753 if not Single_Lock then 754 Unlock_RTS; 755 end if; 756 757 -- We need to explicitely wait for the task to be terminated here 758 -- because on true concurrent system, we may end this procedure 759 -- before the tasks are really terminated. 760 761 Write_Lock (Self_ID); 762 763 loop 764 exit when Utilities.Independent_Task_Count = 0; 765 766 -- We used to yield here, but this did not take into account 767 -- low priority tasks that would cause dead lock in some cases. 768 -- See 8126-020. 769 770 Timed_Sleep 771 (Self_ID, 0.01, System.OS_Primitives.Relative, 772 Self_ID.Common.State, Ignore, Ignore); 773 end loop; 774 775 -- ??? On multi-processor environments, it seems that the above loop 776 -- isn't sufficient, so we need to add an additional delay. 777 778 Timed_Sleep 779 (Self_ID, 0.01, System.OS_Primitives.Relative, 780 Self_ID.Common.State, Ignore, Ignore); 781 782 Unlock (Self_ID); 783 784 if Single_Lock then 785 Unlock_RTS; 786 end if; 787 788 -- Complete the environment task 789 790 Vulnerable_Complete_Task (Self_ID); 791 792 System.Finalization_Implementation.Finalize_Global_List; 793 794 SSL.Abort_Defer := SSL.Abort_Defer_NT'Access; 795 SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access; 796 SSL.Lock_Task := SSL.Task_Lock_NT'Access; 797 SSL.Unlock_Task := SSL.Task_Unlock_NT'Access; 798 SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access; 799 SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access; 800 SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access; 801 SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access; 802 SSL.Get_Exc_Stack_Addr := SSL.Get_Exc_Stack_Addr_NT'Access; 803 SSL.Set_Exc_Stack_Addr := SSL.Set_Exc_Stack_Addr_NT'Access; 804 SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access; 805 SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access; 806 807 -- Don't bother trying to finalize Initialization.Global_Task_Lock 808 -- and System.Task_Primitives.RTS_Lock. 809 810 end Finalize_Global_Tasks; 811 812 --------------- 813 -- Free_Task -- 814 --------------- 815 816 procedure Free_Task (T : Task_ID) is 817 Self_Id : constant Task_ID := Self; 818 819 begin 820 if T.Common.State = Terminated then 821 822 -- It is not safe to call Abort_Defer or Write_Lock at this stage 823 824 Initialization.Task_Lock (Self_Id); 825 826 Lock_RTS; 827 Initialization.Remove_From_All_Tasks_List (T); 828 Unlock_RTS; 829 830 Initialization.Task_Unlock (Self_Id); 831 832 System.Task_Primitives.Operations.Finalize_TCB (T); 833 834 -- If the task is not terminated, then we simply ignore the call. This 835 -- happens when a user program attempts an unchecked deallocation on 836 -- a non-terminated task. 837 838 else 839 null; 840 end if; 841 end Free_Task; 842 843 ------------------ 844 -- Task_Wrapper -- 845 ------------------ 846 847 -- The task wrapper is a procedure that is called first for each task 848 -- task body, and which in turn calls the compiler-generated task body 849 -- procedure. The wrapper's main job is to do initialization for the task. 850 -- It also has some locally declared objects that server as per-task local 851 -- data. Task finalization is done by Complete_Task, which is called from 852 -- an at-end handler that the compiler generates. 853 854 procedure Task_Wrapper (Self_ID : Task_ID) is 855 use type System.Parameters.Size_Type; 856 use type SSE.Storage_Offset; 857 use System.Standard_Library; 858 859 Secondary_Stack : aliased SSE.Storage_Array 860 (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * 861 SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100); 862 Secondary_Stack_Address : System.Address := Secondary_Stack'Address; 863 864 begin 865 pragma Assert (Self_ID.Deferral_Level = 1); 866 867 if not Parameters.Sec_Stack_Dynamic then 868 Self_ID.Common.Compiler_Data.Sec_Stack_Addr := 869 Secondary_Stack'Address; 870 SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); 871 end if; 872 873 -- Set the guard page at the bottom of the stack. The call to 874 -- unprotect the page is done in Terminate_Task 875 876 Stack_Guard (Self_ID, True); 877 878 -- Initialize low-level TCB components, that cannot be initialized 879 -- by the creator. Enter_Task sets Self_ID.Known_Tasks_Index and 880 -- also Self_ID.LL.Thread 881 882 Enter_Task (Self_ID); 883 884 -- We lock RTS_Lock to wait for activator to finish activating 885 -- the rest of the chain, so that everyone in the chain comes out 886 -- in priority order. 887 888 -- This also protects the value of 889 -- Self_ID.Common.Activator.Common.Wait_Count. 890 891 Lock_RTS; 892 Unlock_RTS; 893 894 begin 895 -- We are separating the following portion of the code in order to 896 -- place the exception handlers in a different block. In this way, 897 -- we do not call Set_Jmpbuf_Address (which needs Self) before we 898 -- set Self in Enter_Task 899 900 -- Call the task body procedure 901 902 -- The task body is called with abort still deferred. That 903 -- eliminates a dangerous window, for which we had to patch-up in 904 -- Terminate_Task. 905 906 -- During the expansion of the task body, we insert an RTS-call 907 -- to Abort_Undefer, at the first point where abort should be 908 -- allowed. 909 910 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); 911 Initialization.Defer_Abort_Nestable (Self_ID); 912 913 exception 914 -- We can't call Terminate_Task in the exception handlers below, 915 -- since there may be (e.g. in the case of GCC exception handling) 916 -- clean ups associated with the exception handler that need to 917 -- access task specific data. 918 919 -- Defer abortion so that this task can't be aborted while exiting 920 921 when Standard'Abort_Signal => 922 Initialization.Defer_Abort_Nestable (Self_ID); 923 924 when others => 925 -- ??? Using an E : others here causes CD2C11A to fail on 926 -- DEC Unix, see 7925-005. 927 928 Initialization.Defer_Abort_Nestable (Self_ID); 929 930 -- Perform the task specific exception tracing duty. We handle 931 -- these outputs here and not in the common notification routine 932 -- because we need access to tasking related data and we don't 933 -- want to drag dependencies against tasking related units in the 934 -- the common notification units. Additionally, no trace is ever 935 -- triggered from the common routine for the Unhandled_Raise case 936 -- in tasks, since an exception never appears unhandled in this 937 -- context because of this handler. 938 939 if Exception_Trace = Unhandled_Raise then 940 Trace_Unhandled_Exception_In_Task (Self_ID); 941 end if; 942 end; 943 944 Terminate_Task (Self_ID); 945 end Task_Wrapper; 946 947 -------------------- 948 -- Terminate_Task -- 949 -------------------- 950 951 -- Before we allow the thread to exit, we must clean up. This is a 952 -- a delicate job. We must wake up the task's master, who may immediately 953 -- try to deallocate the ATCB out from under the current task WHILE IT IS 954 -- STILL EXECUTING. 955 956 -- To avoid this, the parent task must be blocked up to the latest 957 -- statement executed. The trouble is that we have another step that we 958 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD. 959 -- We have to postpone that until the end because compiler-generated code 960 -- is likely to try to access that data at just about any point. 961 962 -- We can't call Destroy_TSD while we are holding any other locks, because 963 -- it locks Global_Task_Lock, and our deadlock prevention rules require 964 -- that to be the outermost lock. Our first "solution" was to just lock 965 -- Global_Task_Lock in addition to the other locks, and force the parent 966 -- to also lock this lock between its wakeup and its freeing of the ATCB. 967 -- See Complete_Task for the parent-side of the code that has the matching 968 -- calls to Task_Lock and Task_Unlock. That was not really a solution, 969 -- since the operation Task_Unlock continued to access the ATCB after 970 -- unlocking, after which the parent was observed to race ahead, 971 -- deallocate the ATCB, and then reallocate it to another task. The 972 -- call to Undefer_Abortion in Task_Unlock by the "terminated" task was 973 -- overwriting the data of the new task that reused the ATCB! To solve 974 -- this problem, we introduced the new operation Final_Task_Unlock. 975 976 procedure Terminate_Task (Self_ID : Task_ID) is 977 Environment_Task : constant Task_ID := STPO.Environment_Task; 978 Master_of_Task : Integer; 979 980 begin 981 Debug.Task_Termination_Hook; 982 983 if Runtime_Traces then 984 Send_Trace_Info (T_Terminate); 985 end if; 986 987 -- Since GCC cannot allocate stack chunks efficiently without reordering 988 -- some of the allocations, we have to handle this unexpected situation 989 -- here. We should normally never have to call Vulnerable_Complete_Task 990 -- here. See 6602-003 for more details. 991 992 if Self_ID.Common.Activator /= null then 993 Vulnerable_Complete_Task (Self_ID); 994 end if; 995 996 Initialization.Task_Lock (Self_ID); 997 998 if Single_Lock then 999 Lock_RTS; 1000 end if; 1001 1002 Master_of_Task := Self_ID.Master_of_Task; 1003 1004 -- Check if the current task is an independent task 1005 -- If so, decrement the Independent_Task_Count value. 1006 1007 if Master_of_Task = 2 then 1008 if Single_Lock then 1009 Utilities.Independent_Task_Count := 1010 Utilities.Independent_Task_Count - 1; 1011 1012 else 1013 Write_Lock (Environment_Task); 1014 Utilities.Independent_Task_Count := 1015 Utilities.Independent_Task_Count - 1; 1016 Unlock (Environment_Task); 1017 end if; 1018 end if; 1019 1020 -- Unprotect the guard page if needed 1021 1022 Stack_Guard (Self_ID, False); 1023 1024 Utilities.Make_Passive (Self_ID, Task_Completed => True); 1025 1026 if Single_Lock then 1027 Unlock_RTS; 1028 end if; 1029 1030 pragma Assert (Check_Exit (Self_ID)); 1031 1032 SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); 1033 Initialization.Final_Task_Unlock (Self_ID); 1034 1035 -- WARNING 1036 -- past this point, this thread must assume that the ATCB 1037 -- has been deallocated. It should not be accessed again. 1038 1039 if Master_of_Task > 0 then 1040 STPO.Exit_Task; 1041 end if; 1042 end Terminate_Task; 1043 1044 ---------------- 1045 -- Terminated -- 1046 ---------------- 1047 1048 function Terminated (T : Task_ID) return Boolean is 1049 Self_ID : constant Task_ID := STPO.Self; 1050 Result : Boolean; 1051 1052 begin 1053 Initialization.Defer_Abort_Nestable (Self_ID); 1054 1055 if Single_Lock then 1056 Lock_RTS; 1057 end if; 1058 1059 Write_Lock (T); 1060 Result := T.Common.State = Terminated; 1061 Unlock (T); 1062 1063 if Single_Lock then 1064 Unlock_RTS; 1065 end if; 1066 1067 Initialization.Undefer_Abort_Nestable (Self_ID); 1068 return Result; 1069 end Terminated; 1070 1071 ---------------------------------------- 1072 -- Trace_Unhandled_Exception_In_Task -- 1073 ---------------------------------------- 1074 1075 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_ID) is 1076 procedure To_Stderr (S : String); 1077 pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); 1078 1079 use System.Task_Info; 1080 use System.Soft_Links; 1081 use System.Standard_Library; 1082 1083 function To_Address is new 1084 Unchecked_Conversion (Task_ID, System.Address); 1085 1086 function Tailored_Exception_Information 1087 (E : Exception_Occurrence) return String; 1088 pragma Import 1089 (Ada, Tailored_Exception_Information, 1090 "__gnat_tailored_exception_information"); 1091 1092 Excep : constant Exception_Occurrence_Access := 1093 SSL.Get_Current_Excep.all; 1094 1095 begin 1096 -- This procedure is called by the task outermost handler in 1097 -- Task_Wrapper below, so only once the task stack has been fully 1098 -- unwound. The common notification routine has been called at the 1099 -- raise point already. 1100 1101 To_Stderr ("task "); 1102 1103 if Self_Id.Common.Task_Image_Len /= 0 then 1104 To_Stderr 1105 (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len)); 1106 To_Stderr ("_"); 1107 end if; 1108 1109 To_Stderr (System.Address_Image (To_Address (Self_Id))); 1110 To_Stderr (" terminated by unhandled exception"); 1111 To_Stderr ((1 => ASCII.LF)); 1112 To_Stderr (Tailored_Exception_Information (Excep.all)); 1113 end Trace_Unhandled_Exception_In_Task; 1114 1115 ------------------------------------ 1116 -- Vulnerable_Complete_Activation -- 1117 ------------------------------------ 1118 1119 -- As in several other places, the locks of the activator and activated 1120 -- task are both locked here. This follows our deadlock prevention lock 1121 -- ordering policy, since the activated task must be created after the 1122 -- activator. 1123 1124 procedure Vulnerable_Complete_Activation (Self_ID : Task_ID) is 1125 Activator : constant Task_ID := Self_ID.Common.Activator; 1126 1127 begin 1128 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C')); 1129 1130 Write_Lock (Activator); 1131 Write_Lock (Self_ID); 1132 1133 pragma Assert (Self_ID.Common.Activator /= null); 1134 1135 -- Remove dangling reference to Activator, since a task may 1136 -- outlive its activator. 1137 1138 Self_ID.Common.Activator := null; 1139 1140 -- Wake up the activator, if it is waiting for a chain of tasks to 1141 -- activate, and we are the last in the chain to complete activation. 1142 1143 if Activator.Common.State = Activator_Sleep then 1144 Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; 1145 1146 if Activator.Common.Wait_Count = 0 then 1147 Wakeup (Activator, Activator_Sleep); 1148 end if; 1149 end if; 1150 1151 -- The activator raises a Tasking_Error if any task it is activating 1152 -- is completed before the activation is done. However, if the reason 1153 -- for the task completion is an abortion, we do not raise an exception. 1154 -- See RM 9.2(5). 1155 1156 if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then 1157 Activator.Common.Activation_Failed := True; 1158 end if; 1159 1160 Unlock (Self_ID); 1161 Unlock (Activator); 1162 1163 -- After the activation, active priority should be the same 1164 -- as base priority. We must unlock the Activator first, 1165 -- though, since it should not wait if we have lower priority. 1166 1167 if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then 1168 Write_Lock (Self_ID); 1169 Set_Priority (Self_ID, Self_ID.Common.Base_Priority); 1170 Unlock (Self_ID); 1171 end if; 1172 end Vulnerable_Complete_Activation; 1173 1174 -------------------------------- 1175 -- Vulnerable_Complete_Master -- 1176 -------------------------------- 1177 1178 procedure Vulnerable_Complete_Master (Self_ID : Task_ID) is 1179 C : Task_ID; 1180 P : Task_ID; 1181 CM : constant Master_Level := Self_ID.Master_Within; 1182 T : aliased Task_ID; 1183 1184 To_Be_Freed : Task_ID; 1185 -- This is a list of ATCBs to be freed, after we have released 1186 -- all RTS locks. This is necessary because of the locking order 1187 -- rules, since the storage manager uses Global_Task_Lock. 1188 1189 pragma Warnings (Off); 1190 function Check_Unactivated_Tasks return Boolean; 1191 pragma Warnings (On); 1192 -- Temporary error-checking code below. This is part of the checks 1193 -- added in the new run time. Call it only inside a pragma Assert. 1194 1195 ----------------------------- 1196 -- Check_Unactivated_Tasks -- 1197 ----------------------------- 1198 1199 function Check_Unactivated_Tasks return Boolean is 1200 begin 1201 if not Single_Lock then 1202 Lock_RTS; 1203 end if; 1204 1205 Write_Lock (Self_ID); 1206 C := All_Tasks_List; 1207 1208 while C /= null loop 1209 if C.Common.Activator = Self_ID then 1210 return False; 1211 end if; 1212 1213 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then 1214 Write_Lock (C); 1215 1216 if C.Common.State = Unactivated then 1217 return False; 1218 end if; 1219 1220 Unlock (C); 1221 end if; 1222 1223 C := C.Common.All_Tasks_Link; 1224 end loop; 1225 1226 Unlock (Self_ID); 1227 1228 if not Single_Lock then 1229 Unlock_RTS; 1230 end if; 1231 1232 return True; 1233 end Check_Unactivated_Tasks; 1234 1235 -- Start of processing for Vulnerable_Complete_Master 1236 1237 begin 1238 pragma Debug 1239 (Debug.Trace (Self_ID, "V_Complete_Master", 'C')); 1240 1241 pragma Assert (Self_ID.Common.Wait_Count = 0); 1242 pragma Assert (Self_ID.Deferral_Level > 0); 1243 1244 -- Count how many active dependent tasks this master currently 1245 -- has, and record this in Wait_Count. 1246 1247 -- This count should start at zero, since it is initialized to 1248 -- zero for new tasks, and the task should not exit the 1249 -- sleep-loops that use this count until the count reaches zero. 1250 1251 Lock_RTS; 1252 Write_Lock (Self_ID); 1253 C := All_Tasks_List; 1254 1255 while C /= null loop 1256 if C.Common.Activator = Self_ID then 1257 pragma Assert (C.Common.State = Unactivated); 1258 1259 Write_Lock (C); 1260 C.Common.Activator := null; 1261 C.Common.State := Terminated; 1262 C.Callable := False; 1263 Utilities.Cancel_Queued_Entry_Calls (C); 1264 Unlock (C); 1265 end if; 1266 1267 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then 1268 Write_Lock (C); 1269 1270 if C.Awake_Count /= 0 then 1271 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; 1272 end if; 1273 1274 Unlock (C); 1275 end if; 1276 1277 C := C.Common.All_Tasks_Link; 1278 end loop; 1279 1280 Self_ID.Common.State := Master_Completion_Sleep; 1281 Unlock (Self_ID); 1282 1283 if not Single_Lock then 1284 Unlock_RTS; 1285 end if; 1286 1287 -- Wait until dependent tasks are all terminated or ready to terminate. 1288 -- While waiting, the task may be awakened if the task's priority needs 1289 -- changing, or this master is aborted. In the latter case, we want 1290 -- to abort the dependents, and resume waiting until Wait_Count goes 1291 -- to zero. 1292 1293 Write_Lock (Self_ID); 1294 1295 loop 1296 Initialization.Poll_Base_Priority_Change (Self_ID); 1297 exit when Self_ID.Common.Wait_Count = 0; 1298 1299 -- Here is a difference as compared to Complete_Master 1300 1301 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 1302 and then not Self_ID.Dependents_Aborted 1303 then 1304 if Single_Lock then 1305 Abort_Dependents (Self_ID); 1306 else 1307 Unlock (Self_ID); 1308 Lock_RTS; 1309 Abort_Dependents (Self_ID); 1310 Unlock_RTS; 1311 Write_Lock (Self_ID); 1312 end if; 1313 else 1314 Sleep (Self_ID, Master_Completion_Sleep); 1315 end if; 1316 end loop; 1317 1318 Self_ID.Common.State := Runnable; 1319 Unlock (Self_ID); 1320 1321 -- Dependents are all terminated or on terminate alternatives. 1322 -- Now, force those on terminate alternatives to terminate, by 1323 -- aborting them. 1324 1325 pragma Assert (Check_Unactivated_Tasks); 1326 1327 if Self_ID.Alive_Count > 1 then 1328 -- ??? 1329 -- Consider finding a way to skip the following extra steps if there 1330 -- are no dependents with terminate alternatives. This could be done 1331 -- by adding another count to the ATCB, similar to Awake_Count, but 1332 -- keeping track of tasks that are on terminate alternatives. 1333 1334 pragma Assert (Self_ID.Common.Wait_Count = 0); 1335 1336 -- Force any remaining dependents to terminate, by aborting them. 1337 1338 if not Single_Lock then 1339 Lock_RTS; 1340 end if; 1341 1342 Abort_Dependents (Self_ID); 1343 1344 -- Above, when we "abort" the dependents we are simply using this 1345 -- operation for convenience. We are not required to support the full 1346 -- abort-statement semantics; in particular, we are not required to 1347 -- immediately cancel any queued or in-service entry calls. That is 1348 -- good, because if we tried to cancel a call we would need to lock 1349 -- the caller, in order to wake the caller up. Our anti-deadlock 1350 -- rules prevent us from doing that without releasing the locks on C 1351 -- and Self_ID. Releasing and retaking those locks would be wasteful 1352 -- at best, and should not be considered further without more 1353 -- detailed analysis of potential concurrent accesses to the 1354 -- ATCBs of C and Self_ID. 1355 1356 -- Count how many "alive" dependent tasks this master currently 1357 -- has, and record this in Wait_Count. This count should start at 1358 -- zero, since it is initialized to zero for new tasks, and the 1359 -- task should not exit the sleep-loops that use this count until 1360 -- the count reaches zero. 1361 1362 pragma Assert (Self_ID.Common.Wait_Count = 0); 1363 1364 Write_Lock (Self_ID); 1365 C := All_Tasks_List; 1366 1367 while C /= null loop 1368 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then 1369 Write_Lock (C); 1370 1371 pragma Assert (C.Awake_Count = 0); 1372 1373 if C.Alive_Count > 0 then 1374 pragma Assert (C.Terminate_Alternative); 1375 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; 1376 end if; 1377 1378 Unlock (C); 1379 end if; 1380 1381 C := C.Common.All_Tasks_Link; 1382 end loop; 1383 1384 Self_ID.Common.State := Master_Phase_2_Sleep; 1385 Unlock (Self_ID); 1386 1387 if not Single_Lock then 1388 Unlock_RTS; 1389 end if; 1390 1391 -- Wait for all counted tasks to finish terminating themselves. 1392 1393 Write_Lock (Self_ID); 1394 1395 loop 1396 Initialization.Poll_Base_Priority_Change (Self_ID); 1397 exit when Self_ID.Common.Wait_Count = 0; 1398 Sleep (Self_ID, Master_Phase_2_Sleep); 1399 end loop; 1400 1401 Self_ID.Common.State := Runnable; 1402 Unlock (Self_ID); 1403 end if; 1404 1405 -- We don't wake up for abortion here. We are already terminating 1406 -- just as fast as we can, so there is no point. 1407 1408 -- Remove terminated tasks from the list of Self_ID's dependents, but 1409 -- don't free their ATCBs yet, because of lock order restrictions, 1410 -- which don't allow us to call "free" or "malloc" while holding any 1411 -- other locks. Instead, we put those ATCBs to be freed onto a 1412 -- temporary list, called To_Be_Freed. 1413 1414 if not Single_Lock then 1415 Lock_RTS; 1416 end if; 1417 1418 C := All_Tasks_List; 1419 P := null; 1420 1421 while C /= null loop 1422 if C.Common.Parent = Self_ID and then C.Master_of_Task >= CM then 1423 if P /= null then 1424 P.Common.All_Tasks_Link := C.Common.All_Tasks_Link; 1425 else 1426 All_Tasks_List := C.Common.All_Tasks_Link; 1427 end if; 1428 1429 T := C.Common.All_Tasks_Link; 1430 C.Common.All_Tasks_Link := To_Be_Freed; 1431 To_Be_Freed := C; 1432 C := T; 1433 1434 else 1435 P := C; 1436 C := C.Common.All_Tasks_Link; 1437 end if; 1438 end loop; 1439 1440 Unlock_RTS; 1441 1442 -- Free all the ATCBs on the list To_Be_Freed. 1443 1444 -- The ATCBs in the list are no longer in All_Tasks_List, and after 1445 -- any interrupt entries are detached from them they should no longer 1446 -- be referenced. 1447 1448 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to 1449 -- avoid a race between a terminating task and its parent. The parent 1450 -- might try to deallocate the ACTB out from underneath the exiting 1451 -- task. Note that Free will also lock Global_Task_Lock, but that is 1452 -- OK, since this is the *one* lock for which we have a mechanism to 1453 -- support nested locking. See Task_Wrapper and its finalizer for more 1454 -- explanation. 1455 1456 -- ??? 1457 -- The check "T.Common.Parent /= null ..." below is to prevent dangling 1458 -- references to terminated library-level tasks, which could 1459 -- otherwise occur during finalization of library-level objects. 1460 -- A better solution might be to hook task objects into the 1461 -- finalization chain and deallocate the ATCB when the task 1462 -- object is deallocated. However, this change is not likely 1463 -- to gain anything significant, since all this storage should 1464 -- be recovered en-masse when the process exits. 1465 1466 while To_Be_Freed /= null loop 1467 T := To_Be_Freed; 1468 To_Be_Freed := T.Common.All_Tasks_Link; 1469 1470 -- ??? On SGI there is currently no Interrupt_Manager, that's 1471 -- why we need to check if the Interrupt_Manager_ID is null 1472 1473 if T.Interrupt_Entry and Interrupt_Manager_ID /= null then 1474 declare 1475 Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1; 1476 -- Corresponds to the entry index of System.Interrupts. 1477 -- Interrupt_Manager.Detach_Interrupt_Entries. 1478 -- Be sure to update this value when changing 1479 -- Interrupt_Manager specs. 1480 1481 type Param_Type is access all Task_ID; 1482 1483 Param : aliased Param_Type := T'Access; 1484 1485 begin 1486 System.Tasking.Rendezvous.Call_Simple 1487 (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index, 1488 Param'Address); 1489 end; 1490 end if; 1491 1492 if (T.Common.Parent /= null 1493 and then T.Common.Parent.Common.Parent /= null) 1494 or else T.Master_of_Task > 3 1495 then 1496 Initialization.Task_Lock (Self_ID); 1497 1498 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD 1499 -- has not been called yet (case of an unactivated task). 1500 1501 if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then 1502 SSL.Destroy_TSD (T.Common.Compiler_Data); 1503 end if; 1504 1505 Vulnerable_Free_Task (T); 1506 Initialization.Task_Unlock (Self_ID); 1507 end if; 1508 end loop; 1509 1510 -- It might seem nice to let the terminated task deallocate its own 1511 -- ATCB. That would not cover the case of unactivated tasks. It also 1512 -- would force us to keep the underlying thread around past termination, 1513 -- since references to the ATCB are possible past termination. 1514 -- Currently, we get rid of the thread as soon as the task terminates, 1515 -- and let the parent recover the ATCB later. 1516 1517 -- Some day, if we want to recover the ATCB earlier, at task 1518 -- termination, we could consider using "fat task IDs", that include the 1519 -- serial number with the ATCB pointer, to catch references to tasks 1520 -- that no longer have ATCBs. It is not clear how much this would gain, 1521 -- since the user-level task object would still be occupying storage. 1522 1523 -- Make next master level up active. 1524 -- We don't need to lock the ATCB, since the value is only updated by 1525 -- each task for itself. 1526 1527 Self_ID.Master_Within := CM - 1; 1528 end Vulnerable_Complete_Master; 1529 1530 ------------------------------ 1531 -- Vulnerable_Complete_Task -- 1532 ------------------------------ 1533 1534 -- Complete the calling task 1535 1536 -- This procedure must be called with abort deferred. (That's why the 1537 -- name has "Vulnerable" in it.) It should only be called by Complete_Task 1538 -- and Finalize_Global_Tasks (for the environment task). 1539 1540 -- The effect is similar to that of Complete_Master. Differences include 1541 -- the closing of entries here, and computation of the number of active 1542 -- dependent tasks in Complete_Master. 1543 1544 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation, 1545 -- because that does its own locking, and because we do not need the lock 1546 -- to test Self_ID.Common.Activator. That value should only be read and 1547 -- modified by Self. 1548 1549 procedure Vulnerable_Complete_Task (Self_ID : Task_ID) is 1550 begin 1551 pragma Assert (Self_ID.Deferral_Level > 0); 1552 pragma Assert (Self_ID = Self); 1553 pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1 1554 or else 1555 Self_ID.Master_Within = Self_ID.Master_of_Task + 2); 1556 pragma Assert (Self_ID.Common.Wait_Count = 0); 1557 pragma Assert (Self_ID.Open_Accepts = null); 1558 pragma Assert (Self_ID.ATC_Nesting_Level = 1); 1559 1560 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C')); 1561 1562 if Single_Lock then 1563 Lock_RTS; 1564 end if; 1565 1566 Write_Lock (Self_ID); 1567 Self_ID.Callable := False; 1568 1569 -- In theory, Self should have no pending entry calls left on its 1570 -- call-stack. Each async. select statement should clean its own call, 1571 -- and blocking entry calls should defer abort until the calls are 1572 -- cancelled, then clean up. 1573 1574 Utilities.Cancel_Queued_Entry_Calls (Self_ID); 1575 Unlock (Self_ID); 1576 1577 if Self_ID.Common.Activator /= null then 1578 Vulnerable_Complete_Activation (Self_ID); 1579 end if; 1580 1581 if Single_Lock then 1582 Unlock_RTS; 1583 end if; 1584 1585 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 1586 -- we may have dependent tasks for which we need to wait. 1587 -- Otherwise, we can just exit. 1588 1589 if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then 1590 Vulnerable_Complete_Master (Self_ID); 1591 end if; 1592 end Vulnerable_Complete_Task; 1593 1594 -------------------------- 1595 -- Vulnerable_Free_Task -- 1596 -------------------------- 1597 1598 -- Recover all runtime system storage associated with the task T. 1599 -- This should only be called after T has terminated and will no 1600 -- longer be referenced. 1601 1602 -- For tasks created by an allocator that fails, due to an exception, 1603 -- it is called from Expunge_Unactivated_Tasks. 1604 1605 -- For tasks created by elaboration of task object declarations it 1606 -- is called from the finalization code of the Task_Wrapper procedure. 1607 -- It is also called from Unchecked_Deallocation, for objects that 1608 -- are or contain tasks. 1609 1610 procedure Vulnerable_Free_Task (T : Task_ID) is 1611 begin 1612 pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T)); 1613 1614 if Single_Lock then 1615 Lock_RTS; 1616 end if; 1617 1618 Write_Lock (T); 1619 Initialization.Finalize_Attributes_Link.all (T); 1620 Unlock (T); 1621 1622 if Single_Lock then 1623 Unlock_RTS; 1624 end if; 1625 1626 System.Task_Primitives.Operations.Finalize_TCB (T); 1627 end Vulnerable_Free_Task; 1628 1629begin 1630 -- Establish the Adafinal softlink. 1631 1632 -- This is not done inside the central RTS initialization routine 1633 -- to avoid with-ing this package from System.Tasking.Initialization. 1634 1635 SSL.Adafinal := Finalize_Global_Tasks'Access; 1636 1637 -- Establish soft links for subprograms that manipulate master_id's. 1638 -- This cannot be done when the RTS is initialized, because of various 1639 -- elaboration constraints. 1640 1641 SSL.Current_Master := Stages.Current_Master'Access; 1642 SSL.Enter_Master := Stages.Enter_Master'Access; 1643 SSL.Complete_Master := Stages.Complete_Master'Access; 1644end System.Tasking.Stages; 1645