1------------------------------------------------------------------------------ 2-- -- 3-- GNAT 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-2013, 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 32pragma Polling (Off); 33-- Turn off polling, we do not want ATC polling to take place during tasking 34-- operations. It causes infinite loops and other problems. 35 36pragma Partition_Elaboration_Policy (Concurrent); 37-- This package only implements the concurrent elaboration policy. This pragma 38-- will enforce it (and detect conflicts with user specified policy). 39 40with Ada.Exceptions; 41with Ada.Unchecked_Deallocation; 42 43with System.Interrupt_Management; 44with System.Tasking.Debug; 45with System.Address_Image; 46with System.Task_Primitives; 47with System.Task_Primitives.Operations; 48with System.Tasking.Utilities; 49with System.Tasking.Queuing; 50with System.Tasking.Rendezvous; 51with System.OS_Primitives; 52with System.Secondary_Stack; 53with System.Storage_Elements; 54with System.Restrictions; 55with System.Standard_Library; 56with System.Traces.Tasking; 57with System.Stack_Usage; 58 59with System.Soft_Links; 60-- These are procedure pointers to non-tasking routines that use task 61-- specific data. In the absence of tasking, these routines refer to global 62-- data. In the presence of tasking, they must be replaced with pointers to 63-- task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current 64-- _Excep, Finalize_Library_Objects, Task_Termination, Handler. 65 66with System.Tasking.Initialization; 67pragma Elaborate_All (System.Tasking.Initialization); 68-- This insures that tasking is initialized if any tasks are created 69 70package body System.Tasking.Stages is 71 72 package STPO renames System.Task_Primitives.Operations; 73 package SSL renames System.Soft_Links; 74 package SSE renames System.Storage_Elements; 75 package SST renames System.Secondary_Stack; 76 77 use Ada.Exceptions; 78 79 use Parameters; 80 use Task_Primitives; 81 use Task_Primitives.Operations; 82 use Task_Info; 83 84 use System.Traces; 85 use System.Traces.Tasking; 86 87 ----------------------- 88 -- Local Subprograms -- 89 ----------------------- 90 91 procedure Free is new 92 Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); 93 94 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id); 95 -- This procedure outputs the task specific message for exception 96 -- tracing purposes. 97 98 procedure Task_Wrapper (Self_ID : Task_Id); 99 pragma Convention (C, Task_Wrapper); 100 -- This is the procedure that is called by the GNULL from the new context 101 -- when a task is created. It waits for activation and then calls the task 102 -- body procedure. When the task body procedure completes, it terminates 103 -- the task. 104 -- 105 -- The Task_Wrapper's address will be provided to the underlying threads 106 -- library as the task entry point. Convention C is what makes most sense 107 -- for that purpose (Export C would make the function globally visible, 108 -- and affect the link name on which GDB depends). This will in addition 109 -- trigger an automatic stack alignment suitable for GCC's assumptions if 110 -- need be. 111 112 -- "Vulnerable_..." in the procedure names below means they must be called 113 -- with abort deferred. 114 115 procedure Vulnerable_Complete_Task (Self_ID : Task_Id); 116 -- Complete the calling task. This procedure must be called with 117 -- abort deferred. It should only be called by Complete_Task and 118 -- Finalize_Global_Tasks (for the environment task). 119 120 procedure Vulnerable_Complete_Master (Self_ID : Task_Id); 121 -- Complete the current master of the calling task. This procedure 122 -- must be called with abort deferred. It should only be called by 123 -- Vulnerable_Complete_Task and Complete_Master. 124 125 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id); 126 -- Signal to Self_ID's activator that Self_ID has completed activation. 127 -- This procedure must be called with abort deferred. 128 129 procedure Abort_Dependents (Self_ID : Task_Id); 130 -- Abort all the direct dependents of Self at its current master nesting 131 -- level, plus all of their dependents, transitively. RTS_Lock should be 132 -- locked by the caller. 133 134 procedure Vulnerable_Free_Task (T : Task_Id); 135 -- Recover all runtime system storage associated with the task T. This 136 -- should only be called after T has terminated and will no longer be 137 -- referenced. 138 -- 139 -- For tasks created by an allocator that fails, due to an exception, it is 140 -- called from Expunge_Unactivated_Tasks. 141 -- 142 -- Different code is used at master completion, in Terminate_Dependents, 143 -- due to a need for tighter synchronization with the master. 144 145 ---------------------- 146 -- Abort_Dependents -- 147 ---------------------- 148 149 procedure Abort_Dependents (Self_ID : Task_Id) is 150 C : Task_Id; 151 P : Task_Id; 152 153 -- Each task C will take care of its own dependents, so there is no 154 -- need to worry about them here. In fact, it would be wrong to abort 155 -- indirect dependents here, because we can't distinguish between 156 -- duplicate master ids. For example, suppose we have three nested 157 -- task bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and 158 -- both P and Q are task masters). Q will have the same master id as 159 -- Master_of_Task of T3. Previous versions of this would abort T3 when 160 -- Q calls Complete_Master, which was completely wrong. 161 162 begin 163 C := All_Tasks_List; 164 while C /= null loop 165 P := C.Common.Parent; 166 167 if P = Self_ID then 168 if C.Master_of_Task = Self_ID.Master_Within then 169 pragma Debug 170 (Debug.Trace (Self_ID, "Aborting", 'X', C)); 171 Utilities.Abort_One_Task (Self_ID, C); 172 C.Dependents_Aborted := True; 173 end if; 174 end if; 175 176 C := C.Common.All_Tasks_Link; 177 end loop; 178 179 Self_ID.Dependents_Aborted := True; 180 end Abort_Dependents; 181 182 ----------------- 183 -- Abort_Tasks -- 184 ----------------- 185 186 procedure Abort_Tasks (Tasks : Task_List) is 187 begin 188 Utilities.Abort_Tasks (Tasks); 189 end Abort_Tasks; 190 191 -------------------- 192 -- Activate_Tasks -- 193 -------------------- 194 195 -- Note that locks of activator and activated task are both locked here. 196 -- This is necessary because C.Common.State and Self.Common.Wait_Count have 197 -- to be synchronized. This is safe from deadlock because the activator is 198 -- always created before the activated task. That satisfies our 199 -- in-order-of-creation ATCB locking policy. 200 201 -- At one point, we may also lock the parent, if the parent is different 202 -- from the activator. That is also consistent with the lock ordering 203 -- policy, since the activator cannot be created before the parent. 204 205 -- Since we are holding both the activator's lock, and Task_Wrapper locks 206 -- that before it does anything more than initialize the low-level ATCB 207 -- components, it should be safe to wait to update the counts until we see 208 -- that the thread creation is successful. 209 210 -- If the thread creation fails, we do need to close the entries of the 211 -- task. The first phase, of dequeuing calls, only requires locking the 212 -- acceptor's ATCB, but the waking up of the callers requires locking the 213 -- caller's ATCB. We cannot safely do this while we are holding other 214 -- locks. Therefore, the queue-clearing operation is done in a separate 215 -- pass over the activation chain. 216 217 procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is 218 Self_ID : constant Task_Id := STPO.Self; 219 P : Task_Id; 220 C : Task_Id; 221 Next_C, Last_C : Task_Id; 222 Activate_Prio : System.Any_Priority; 223 Success : Boolean; 224 All_Elaborated : Boolean := True; 225 226 begin 227 -- If pragma Detect_Blocking is active, then we must check whether this 228 -- potentially blocking operation is called from a protected action. 229 230 if System.Tasking.Detect_Blocking 231 and then Self_ID.Common.Protected_Action_Nesting > 0 232 then 233 raise Program_Error with "potentially blocking operation"; 234 end if; 235 236 pragma Debug 237 (Debug.Trace (Self_ID, "Activate_Tasks", 'C')); 238 239 Initialization.Defer_Abort_Nestable (Self_ID); 240 241 pragma Assert (Self_ID.Common.Wait_Count = 0); 242 243 -- Lock RTS_Lock, to prevent activated tasks from racing ahead before 244 -- we finish activating the chain. 245 246 Lock_RTS; 247 248 -- Check that all task bodies have been elaborated 249 250 C := Chain_Access.T_ID; 251 Last_C := null; 252 while C /= null loop 253 if C.Common.Elaborated /= null 254 and then not C.Common.Elaborated.all 255 then 256 All_Elaborated := False; 257 end if; 258 259 -- Reverse the activation chain so that tasks are activated in the 260 -- same order they're declared. 261 262 Next_C := C.Common.Activation_Link; 263 C.Common.Activation_Link := Last_C; 264 Last_C := C; 265 C := Next_C; 266 end loop; 267 268 Chain_Access.T_ID := Last_C; 269 270 if not All_Elaborated then 271 Unlock_RTS; 272 Initialization.Undefer_Abort_Nestable (Self_ID); 273 raise Program_Error with "Some tasks have not been elaborated"; 274 end if; 275 276 -- Activate all the tasks in the chain. Creation of the thread of 277 -- control was deferred until activation. So create it now. 278 279 C := Chain_Access.T_ID; 280 while C /= null loop 281 if C.Common.State /= Terminated then 282 pragma Assert (C.Common.State = Unactivated); 283 284 P := C.Common.Parent; 285 Write_Lock (P); 286 Write_Lock (C); 287 288 Activate_Prio := 289 (if C.Common.Base_Priority < Get_Priority (Self_ID) 290 then Get_Priority (Self_ID) 291 else C.Common.Base_Priority); 292 293 System.Task_Primitives.Operations.Create_Task 294 (C, Task_Wrapper'Address, 295 Parameters.Size_Type 296 (C.Common.Compiler_Data.Pri_Stack_Info.Size), 297 Activate_Prio, Success); 298 299 -- There would be a race between the created task and the creator 300 -- to do the following initialization, if we did not have a 301 -- Lock/Unlock_RTS pair in the task wrapper to prevent it from 302 -- racing ahead. 303 304 if Success then 305 C.Common.State := Activating; 306 C.Awake_Count := 1; 307 C.Alive_Count := 1; 308 P.Awake_Count := P.Awake_Count + 1; 309 P.Alive_Count := P.Alive_Count + 1; 310 311 if P.Common.State = Master_Completion_Sleep and then 312 C.Master_of_Task = P.Master_Within 313 then 314 pragma Assert (Self_ID /= P); 315 P.Common.Wait_Count := P.Common.Wait_Count + 1; 316 end if; 317 318 for J in System.Tasking.Debug.Known_Tasks'Range loop 319 if System.Tasking.Debug.Known_Tasks (J) = null then 320 System.Tasking.Debug.Known_Tasks (J) := C; 321 C.Known_Tasks_Index := J; 322 exit; 323 end if; 324 end loop; 325 326 if Global_Task_Debug_Event_Set then 327 Debug.Signal_Debug_Event 328 (Debug.Debug_Event_Activating, C); 329 end if; 330 331 C.Common.State := Runnable; 332 333 Unlock (C); 334 Unlock (P); 335 336 else 337 -- No need to set Awake_Count, State, etc. here since the loop 338 -- below will do that for any Unactivated tasks. 339 340 Unlock (C); 341 Unlock (P); 342 Self_ID.Common.Activation_Failed := True; 343 end if; 344 end if; 345 346 C := C.Common.Activation_Link; 347 end loop; 348 349 if not Single_Lock then 350 Unlock_RTS; 351 end if; 352 353 -- Close the entries of any tasks that failed thread creation, and count 354 -- those that have not finished activation. 355 356 Write_Lock (Self_ID); 357 Self_ID.Common.State := Activator_Sleep; 358 359 C := Chain_Access.T_ID; 360 while C /= null loop 361 Write_Lock (C); 362 363 if C.Common.State = Unactivated then 364 C.Common.Activator := null; 365 C.Common.State := Terminated; 366 C.Callable := False; 367 Utilities.Cancel_Queued_Entry_Calls (C); 368 369 elsif C.Common.Activator /= null then 370 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; 371 end if; 372 373 Unlock (C); 374 P := C.Common.Activation_Link; 375 C.Common.Activation_Link := null; 376 C := P; 377 end loop; 378 379 -- Wait for the activated tasks to complete activation. It is 380 -- unsafe to abort any of these tasks until the count goes to zero. 381 382 loop 383 exit when Self_ID.Common.Wait_Count = 0; 384 Sleep (Self_ID, Activator_Sleep); 385 end loop; 386 387 Self_ID.Common.State := Runnable; 388 Unlock (Self_ID); 389 390 if Single_Lock then 391 Unlock_RTS; 392 end if; 393 394 -- Remove the tasks from the chain 395 396 Chain_Access.T_ID := null; 397 Initialization.Undefer_Abort_Nestable (Self_ID); 398 399 if Self_ID.Common.Activation_Failed then 400 Self_ID.Common.Activation_Failed := False; 401 raise Tasking_Error with "Failure during activation"; 402 end if; 403 end Activate_Tasks; 404 405 ------------------------- 406 -- Complete_Activation -- 407 ------------------------- 408 409 procedure Complete_Activation is 410 Self_ID : constant Task_Id := STPO.Self; 411 412 begin 413 Initialization.Defer_Abort_Nestable (Self_ID); 414 415 if Single_Lock then 416 Lock_RTS; 417 end if; 418 419 Vulnerable_Complete_Activation (Self_ID); 420 421 if Single_Lock then 422 Unlock_RTS; 423 end if; 424 425 Initialization.Undefer_Abort_Nestable (Self_ID); 426 427 -- ??? Why do we need to allow for nested deferral here? 428 429 if Runtime_Traces then 430 Send_Trace_Info (T_Activate); 431 end if; 432 end Complete_Activation; 433 434 --------------------- 435 -- Complete_Master -- 436 --------------------- 437 438 procedure Complete_Master is 439 Self_ID : constant Task_Id := STPO.Self; 440 begin 441 pragma Assert 442 (Self_ID.Deferral_Level > 0 443 or else not System.Restrictions.Abort_Allowed); 444 Vulnerable_Complete_Master (Self_ID); 445 end Complete_Master; 446 447 ------------------- 448 -- Complete_Task -- 449 ------------------- 450 451 -- See comments on Vulnerable_Complete_Task for details 452 453 procedure Complete_Task is 454 Self_ID : constant Task_Id := STPO.Self; 455 456 begin 457 pragma Assert 458 (Self_ID.Deferral_Level > 0 459 or else not System.Restrictions.Abort_Allowed); 460 461 Vulnerable_Complete_Task (Self_ID); 462 463 -- All of our dependents have terminated, never undefer abort again 464 465 end Complete_Task; 466 467 ----------------- 468 -- Create_Task -- 469 ----------------- 470 471 -- Compiler interface only. Do not call from within the RTS. This must be 472 -- called to create a new task. 473 474 procedure Create_Task 475 (Priority : Integer; 476 Size : System.Parameters.Size_Type; 477 Task_Info : System.Task_Info.Task_Info_Type; 478 CPU : Integer; 479 Relative_Deadline : Ada.Real_Time.Time_Span; 480 Domain : Dispatching_Domain_Access; 481 Num_Entries : Task_Entry_Index; 482 Master : Master_Level; 483 State : Task_Procedure_Access; 484 Discriminants : System.Address; 485 Elaborated : Access_Boolean; 486 Chain : in out Activation_Chain; 487 Task_Image : String; 488 Created_Task : out Task_Id) 489 is 490 T, P : Task_Id; 491 Self_ID : constant Task_Id := STPO.Self; 492 Success : Boolean; 493 Base_Priority : System.Any_Priority; 494 Len : Natural; 495 Base_CPU : System.Multiprocessors.CPU_Range; 496 497 use type System.Multiprocessors.CPU_Range; 498 499 pragma Unreferenced (Relative_Deadline); 500 -- EDF scheduling is not supported by any of the target platforms so 501 -- this parameter is not passed any further. 502 503 begin 504 -- If Master is greater than the current master, it means that Master 505 -- has already awaited its dependent tasks. This raises Program_Error, 506 -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads. 507 508 if Self_ID.Master_of_Task /= Foreign_Task_Level 509 and then Master > Self_ID.Master_Within 510 then 511 raise Program_Error with 512 "create task after awaiting termination"; 513 end if; 514 515 -- If pragma Detect_Blocking is active must be checked whether this 516 -- potentially blocking operation is called from a protected action. 517 518 if System.Tasking.Detect_Blocking 519 and then Self_ID.Common.Protected_Action_Nesting > 0 520 then 521 raise Program_Error with "potentially blocking operation"; 522 end if; 523 524 pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C')); 525 526 Base_Priority := 527 (if Priority = Unspecified_Priority 528 then Self_ID.Common.Base_Priority 529 else System.Any_Priority (Priority)); 530 531 -- Legal values of CPU are the special Unspecified_CPU value which is 532 -- inserted by the compiler for tasks without CPU aspect, and those in 533 -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise 534 -- the task is defined to have failed, and it becomes a completed task 535 -- (RM D.16(14/3)). 536 537 if CPU /= Unspecified_CPU 538 and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) 539 or else 540 CPU > Integer (System.Multiprocessors.CPU_Range'Last) 541 or else 542 CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) 543 then 544 raise Tasking_Error with "CPU not in range"; 545 546 -- Normal CPU affinity 547 548 else 549 -- When the application code says nothing about the task affinity 550 -- (task without CPU aspect) then the compiler inserts the 551 -- Unspecified_CPU value which indicates to the run-time library that 552 -- the task will activate and execute on the same processor as its 553 -- activating task if the activating task is assigned a processor 554 -- (RM D.16(14/3)). 555 556 Base_CPU := 557 (if CPU = Unspecified_CPU 558 then Self_ID.Common.Base_CPU 559 else System.Multiprocessors.CPU_Range (CPU)); 560 end if; 561 562 -- Find parent P of new Task, via master level number 563 564 P := Self_ID; 565 566 if P /= null then 567 while P.Master_of_Task >= Master loop 568 P := P.Common.Parent; 569 exit when P = null; 570 end loop; 571 end if; 572 573 Initialization.Defer_Abort_Nestable (Self_ID); 574 575 begin 576 T := New_ATCB (Num_Entries); 577 exception 578 when others => 579 Initialization.Undefer_Abort_Nestable (Self_ID); 580 raise Storage_Error with "Cannot allocate task"; 581 end; 582 583 -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this 584 -- point, it is possible that we may be part of a family of tasks that 585 -- is being aborted. 586 587 Lock_RTS; 588 Write_Lock (Self_ID); 589 590 -- Now, we must check that we have not been aborted. If so, we should 591 -- give up on creating this task, and simply return. 592 593 if not Self_ID.Callable then 594 pragma Assert (Self_ID.Pending_ATC_Level = 0); 595 pragma Assert (Self_ID.Pending_Action); 596 pragma Assert 597 (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated); 598 599 Unlock (Self_ID); 600 Unlock_RTS; 601 Initialization.Undefer_Abort_Nestable (Self_ID); 602 603 -- ??? Should never get here 604 605 pragma Assert (False); 606 raise Standard'Abort_Signal; 607 end if; 608 609 Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, 610 Base_Priority, Base_CPU, Domain, Task_Info, Size, T, Success); 611 612 if not Success then 613 Free (T); 614 Unlock (Self_ID); 615 Unlock_RTS; 616 Initialization.Undefer_Abort_Nestable (Self_ID); 617 raise Storage_Error with "Failed to initialize task"; 618 end if; 619 620 if Master = Foreign_Task_Level + 2 then 621 622 -- This should not happen, except when a foreign task creates non 623 -- library-level Ada tasks. In this case, we pretend the master is 624 -- a regular library level task, otherwise the run-time will get 625 -- confused when waiting for these tasks to terminate. 626 627 T.Master_of_Task := Library_Task_Level; 628 629 else 630 T.Master_of_Task := Master; 631 end if; 632 633 T.Master_Within := T.Master_of_Task + 1; 634 635 for L in T.Entry_Calls'Range loop 636 T.Entry_Calls (L).Self := T; 637 T.Entry_Calls (L).Level := L; 638 end loop; 639 640 if Task_Image'Length = 0 then 641 T.Common.Task_Image_Len := 0; 642 else 643 Len := 1; 644 T.Common.Task_Image (1) := Task_Image (Task_Image'First); 645 646 -- Remove unwanted blank space generated by 'Image 647 648 for J in Task_Image'First + 1 .. Task_Image'Last loop 649 if Task_Image (J) /= ' ' 650 or else Task_Image (J - 1) /= '(' 651 then 652 Len := Len + 1; 653 T.Common.Task_Image (Len) := Task_Image (J); 654 exit when Len = T.Common.Task_Image'Last; 655 end if; 656 end loop; 657 658 T.Common.Task_Image_Len := Len; 659 end if; 660 661 -- The task inherits the dispatching domain of the parent only if no 662 -- specific domain has been defined in the spec of the task (using the 663 -- dispatching domain pragma or aspect). 664 665 if T.Common.Domain /= null then 666 null; 667 elsif T.Common.Activator /= null then 668 T.Common.Domain := T.Common.Activator.Common.Domain; 669 else 670 T.Common.Domain := System.Tasking.System_Domain; 671 end if; 672 673 Unlock (Self_ID); 674 Unlock_RTS; 675 676 -- The CPU associated to the task (if any) must belong to the 677 -- dispatching domain. 678 679 if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU 680 and then 681 (Base_CPU not in T.Common.Domain'Range 682 or else not T.Common.Domain (Base_CPU)) 683 then 684 Initialization.Undefer_Abort_Nestable (Self_ID); 685 raise Tasking_Error with "CPU not in dispatching domain"; 686 end if; 687 688 -- To handle the interaction between pragma CPU and dispatching domains 689 -- we need to signal that this task is being allocated to a processor. 690 -- This is needed only for tasks belonging to the system domain (the 691 -- creation of new dispatching domains can only take processors from the 692 -- system domain) and only before the environment task calls the main 693 -- procedure (dispatching domains cannot be created after this). 694 695 if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU 696 and then T.Common.Domain = System.Tasking.System_Domain 697 and then not System.Tasking.Dispatching_Domains_Frozen 698 then 699 -- Increase the number of tasks attached to the CPU to which this 700 -- task is being moved. 701 702 Dispatching_Domain_Tasks (Base_CPU) := 703 Dispatching_Domain_Tasks (Base_CPU) + 1; 704 end if; 705 706 -- Create TSD as early as possible in the creation of a task, since it 707 -- may be used by the operation of Ada code within the task. 708 709 SSL.Create_TSD (T.Common.Compiler_Data); 710 T.Common.Activation_Link := Chain.T_ID; 711 Chain.T_ID := T; 712 Initialization.Initialize_Attributes_Link.all (T); 713 Created_Task := T; 714 Initialization.Undefer_Abort_Nestable (Self_ID); 715 716 if Runtime_Traces then 717 Send_Trace_Info (T_Create, T); 718 end if; 719 720 pragma Debug 721 (Debug.Trace 722 (Self_ID, "Created task in " & T.Master_of_Task'Img, 'C', T)); 723 end Create_Task; 724 725 -------------------- 726 -- Current_Master -- 727 -------------------- 728 729 function Current_Master return Master_Level is 730 begin 731 return STPO.Self.Master_Within; 732 end Current_Master; 733 734 ------------------ 735 -- Enter_Master -- 736 ------------------ 737 738 procedure Enter_Master is 739 Self_ID : constant Task_Id := STPO.Self; 740 begin 741 Self_ID.Master_Within := Self_ID.Master_Within + 1; 742 pragma Debug 743 (Debug.Trace 744 (Self_ID, "Enter_Master ->" & Self_ID.Master_Within'Img, 'M')); 745 end Enter_Master; 746 747 ------------------------------- 748 -- Expunge_Unactivated_Tasks -- 749 ------------------------------- 750 751 -- See procedure Close_Entries for the general case 752 753 procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is 754 Self_ID : constant Task_Id := STPO.Self; 755 C : Task_Id; 756 Call : Entry_Call_Link; 757 Temp : Task_Id; 758 759 begin 760 pragma Debug 761 (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C')); 762 763 Initialization.Defer_Abort_Nestable (Self_ID); 764 765 -- ??? 766 -- Experimentation has shown that abort is sometimes (but not always) 767 -- already deferred when this is called. 768 769 -- That may indicate an error. Find out what is going on 770 771 C := Chain.T_ID; 772 while C /= null loop 773 pragma Assert (C.Common.State = Unactivated); 774 775 Temp := C.Common.Activation_Link; 776 777 if C.Common.State = Unactivated then 778 Lock_RTS; 779 Write_Lock (C); 780 781 for J in 1 .. C.Entry_Num loop 782 Queuing.Dequeue_Head (C.Entry_Queues (J), Call); 783 pragma Assert (Call = null); 784 end loop; 785 786 Unlock (C); 787 788 Initialization.Remove_From_All_Tasks_List (C); 789 Unlock_RTS; 790 791 Vulnerable_Free_Task (C); 792 C := Temp; 793 end if; 794 end loop; 795 796 Chain.T_ID := null; 797 Initialization.Undefer_Abort_Nestable (Self_ID); 798 end Expunge_Unactivated_Tasks; 799 800 --------------------------- 801 -- Finalize_Global_Tasks -- 802 --------------------------- 803 804 -- ??? 805 -- We have a potential problem here if finalization of global objects does 806 -- anything with signals or the timer server, since by that time those 807 -- servers have terminated. 808 809 -- It is hard to see how that would occur 810 811 -- However, a better solution might be to do all this finalization 812 -- using the global finalization chain. 813 814 procedure Finalize_Global_Tasks is 815 Self_ID : constant Task_Id := STPO.Self; 816 817 Ignore_1 : Boolean; 818 Ignore_2 : Boolean; 819 pragma Unreferenced (Ignore_1, Ignore_2); 820 821 function State 822 (Int : System.Interrupt_Management.Interrupt_ID) return Character; 823 pragma Import (C, State, "__gnat_get_interrupt_state"); 824 -- Get interrupt state for interrupt number Int. Defined in init.c 825 826 Default : constant Character := 's'; 827 -- 's' Interrupt_State pragma set state to System (use "default" 828 -- system handler) 829 830 begin 831 if Self_ID.Deferral_Level = 0 then 832 -- ??? 833 -- In principle, we should be able to predict whether abort is 834 -- already deferred here (and it should not be deferred yet but in 835 -- practice it seems Finalize_Global_Tasks is being called sometimes, 836 -- from RTS code for exceptions, with abort already deferred. 837 838 Initialization.Defer_Abort_Nestable (Self_ID); 839 840 -- Never undefer again 841 end if; 842 843 -- This code is only executed by the environment task 844 845 pragma Assert (Self_ID = Environment_Task); 846 847 -- Set Environment_Task'Callable to false to notify library-level tasks 848 -- that it is waiting for them. 849 850 Self_ID.Callable := False; 851 852 -- Exit level 2 master, for normal tasks in library-level packages 853 854 Complete_Master; 855 856 -- Force termination of "independent" library-level server tasks 857 858 Lock_RTS; 859 860 Abort_Dependents (Self_ID); 861 862 if not Single_Lock then 863 Unlock_RTS; 864 end if; 865 866 -- We need to explicitly wait for the task to be terminated here 867 -- because on true concurrent system, we may end this procedure before 868 -- the tasks are really terminated. 869 870 Write_Lock (Self_ID); 871 872 -- If the Abort_Task signal is set to system, it means that we may 873 -- not have been able to abort all independent tasks (in particular 874 -- Server_Task may be blocked, waiting for a signal), in which case, do 875 -- not wait for Independent_Task_Count to go down to 0. We arbitrarily 876 -- limit the number of loop iterations; if an independent task does not 877 -- terminate, we do not want to hang here. In that case, the thread will 878 -- be terminated when the process exits. 879 880 if State (System.Interrupt_Management.Abort_Task_Interrupt) /= 881 Default 882 then 883 for J in 1 .. 10 loop 884 exit when Utilities.Independent_Task_Count = 0; 885 886 -- We used to yield here, but this did not take into account low 887 -- priority tasks that would cause dead lock in some cases (true 888 -- FIFO scheduling). 889 890 Timed_Sleep 891 (Self_ID, 0.01, System.OS_Primitives.Relative, 892 Self_ID.Common.State, Ignore_1, Ignore_2); 893 end loop; 894 end if; 895 896 -- ??? On multi-processor environments, it seems that the above loop 897 -- isn't sufficient, so we need to add an additional delay. 898 899 Timed_Sleep 900 (Self_ID, 0.01, System.OS_Primitives.Relative, 901 Self_ID.Common.State, Ignore_1, Ignore_2); 902 903 Unlock (Self_ID); 904 905 if Single_Lock then 906 Unlock_RTS; 907 end if; 908 909 -- Complete the environment task 910 911 Vulnerable_Complete_Task (Self_ID); 912 913 -- Handle normal task termination by the environment task, but only 914 -- for the normal task termination. In the case of Abnormal and 915 -- Unhandled_Exception they must have been handled before, and the 916 -- task termination soft link must have been changed so the task 917 -- termination routine is not executed twice. 918 919 SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); 920 921 -- Finalize all library-level controlled objects 922 923 if not SSL."=" (SSL.Finalize_Library_Objects, null) then 924 SSL.Finalize_Library_Objects.all; 925 end if; 926 927 -- Reset the soft links to non-tasking 928 929 SSL.Abort_Defer := SSL.Abort_Defer_NT'Access; 930 SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access; 931 SSL.Lock_Task := SSL.Task_Lock_NT'Access; 932 SSL.Unlock_Task := SSL.Task_Unlock_NT'Access; 933 SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access; 934 SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access; 935 SSL.Get_Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT'Access; 936 SSL.Set_Sec_Stack_Addr := SSL.Set_Sec_Stack_Addr_NT'Access; 937 SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access; 938 SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access; 939 940 -- Don't bother trying to finalize Initialization.Global_Task_Lock 941 -- and System.Task_Primitives.RTS_Lock. 942 943 end Finalize_Global_Tasks; 944 945 --------------- 946 -- Free_Task -- 947 --------------- 948 949 procedure Free_Task (T : Task_Id) is 950 Self_Id : constant Task_Id := Self; 951 952 begin 953 if T.Common.State = Terminated then 954 955 -- It is not safe to call Abort_Defer or Write_Lock at this stage 956 957 Initialization.Task_Lock (Self_Id); 958 959 Lock_RTS; 960 Initialization.Finalize_Attributes_Link.all (T); 961 Initialization.Remove_From_All_Tasks_List (T); 962 Unlock_RTS; 963 964 Initialization.Task_Unlock (Self_Id); 965 966 System.Task_Primitives.Operations.Finalize_TCB (T); 967 968 else 969 -- If the task is not terminated, then mark the task as to be freed 970 -- upon termination. 971 972 T.Free_On_Termination := True; 973 end if; 974 end Free_Task; 975 976 --------------------------- 977 -- Move_Activation_Chain -- 978 --------------------------- 979 980 procedure Move_Activation_Chain 981 (From, To : Activation_Chain_Access; 982 New_Master : Master_ID) 983 is 984 Self_ID : constant Task_Id := STPO.Self; 985 C : Task_Id; 986 987 begin 988 pragma Debug 989 (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C')); 990 991 -- Nothing to do if From is empty, and we can check that without 992 -- deferring aborts. 993 994 C := From.all.T_ID; 995 996 if C = null then 997 return; 998 end if; 999 1000 Initialization.Defer_Abort (Self_ID); 1001 1002 -- Loop through the From chain, changing their Master_of_Task fields, 1003 -- and to find the end of the chain. 1004 1005 loop 1006 C.Master_of_Task := New_Master; 1007 exit when C.Common.Activation_Link = null; 1008 C := C.Common.Activation_Link; 1009 end loop; 1010 1011 -- Hook From in at the start of To 1012 1013 C.Common.Activation_Link := To.all.T_ID; 1014 To.all.T_ID := From.all.T_ID; 1015 1016 -- Set From to empty 1017 1018 From.all.T_ID := null; 1019 1020 Initialization.Undefer_Abort (Self_ID); 1021 end Move_Activation_Chain; 1022 1023 ------------------ 1024 -- Task_Wrapper -- 1025 ------------------ 1026 1027 -- The task wrapper is a procedure that is called first for each task body 1028 -- and which in turn calls the compiler-generated task body procedure. 1029 -- The wrapper's main job is to do initialization for the task. It also 1030 -- has some locally declared objects that serve as per-task local data. 1031 -- Task finalization is done by Complete_Task, which is called from an 1032 -- at-end handler that the compiler generates. 1033 1034 procedure Task_Wrapper (Self_ID : Task_Id) is 1035 use type SSE.Storage_Offset; 1036 use System.Standard_Library; 1037 use System.Stack_Usage; 1038 1039 Bottom_Of_Stack : aliased Integer; 1040 1041 Task_Alternate_Stack : 1042 aliased SSE.Storage_Array (1 .. Alternate_Stack_Size); 1043 -- The alternate signal stack for this task, if any 1044 1045 Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; 1046 -- Whether to use above alternate signal stack for stack overflows 1047 1048 Secondary_Stack_Size : 1049 constant SSE.Storage_Offset := 1050 Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * 1051 SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100; 1052 1053 Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size); 1054 -- Actual area allocated for secondary stack 1055 1056 Secondary_Stack_Address : System.Address := Secondary_Stack'Address; 1057 -- Address of secondary stack. In the fixed secondary stack case, this 1058 -- value is not modified, causing a warning, hence the bracketing with 1059 -- Warnings (Off/On). But why is so much *more* bracketed??? 1060 1061 SEH_Table : aliased SSE.Storage_Array (1 .. 8); 1062 -- Structured Exception Registration table (2 words) 1063 1064 procedure Install_SEH_Handler (Addr : System.Address); 1065 pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler"); 1066 -- Install the SEH (Structured Exception Handling) handler 1067 1068 Cause : Cause_Of_Termination := Normal; 1069 -- Indicates the reason why this task terminates. Normal corresponds to 1070 -- a task terminating due to completing the last statement of its body, 1071 -- or as a result of waiting on a terminate alternative. If the task 1072 -- terminates because it is being aborted then Cause will be set 1073 -- to Abnormal. If the task terminates because of an exception 1074 -- raised by the execution of its task body, then Cause is set 1075 -- to Unhandled_Exception. 1076 1077 EO : Exception_Occurrence; 1078 -- If the task terminates because of an exception raised by the 1079 -- execution of its task body, then EO will contain the associated 1080 -- exception occurrence. Otherwise, it will contain Null_Occurrence. 1081 1082 TH : Termination_Handler := null; 1083 -- Pointer to the protected procedure to be executed upon task 1084 -- termination. 1085 1086 procedure Search_Fall_Back_Handler (ID : Task_Id); 1087 -- Procedure that searches recursively a fall-back handler through the 1088 -- master relationship. If the handler is found, its pointer is stored 1089 -- in TH. It stops when the handler is found or when the ID is null. 1090 1091 ------------------------------ 1092 -- Search_Fall_Back_Handler -- 1093 ------------------------------ 1094 1095 procedure Search_Fall_Back_Handler (ID : Task_Id) is 1096 begin 1097 -- A null Task_Id indicates that we have reached the root of the 1098 -- task hierarchy and no handler has been found. 1099 1100 if ID = null then 1101 return; 1102 1103 -- If there is a fall back handler, store its pointer for later 1104 -- execution. 1105 1106 elsif ID.Common.Fall_Back_Handler /= null then 1107 TH := ID.Common.Fall_Back_Handler; 1108 1109 -- Otherwise look for a fall back handler in the parent 1110 1111 else 1112 Search_Fall_Back_Handler (ID.Common.Parent); 1113 end if; 1114 end Search_Fall_Back_Handler; 1115 1116 -- Start of processing for Task_Wrapper 1117 1118 begin 1119 pragma Assert (Self_ID.Deferral_Level = 1); 1120 1121 -- Assume a size of the stack taken at this stage 1122 1123 if not Parameters.Sec_Stack_Dynamic then 1124 Self_ID.Common.Compiler_Data.Sec_Stack_Addr := 1125 Secondary_Stack'Address; 1126 SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); 1127 end if; 1128 1129 if Use_Alternate_Stack then 1130 Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; 1131 end if; 1132 1133 -- Set the guard page at the bottom of the stack. The call to unprotect 1134 -- the page is done in Terminate_Task 1135 1136 Stack_Guard (Self_ID, True); 1137 1138 -- Initialize low-level TCB components, that cannot be initialized by 1139 -- the creator. Enter_Task sets Self_ID.LL.Thread. 1140 1141 Enter_Task (Self_ID); 1142 1143 -- Initialize dynamic stack usage 1144 1145 if System.Stack_Usage.Is_Enabled then 1146 declare 1147 Guard_Page_Size : constant := 16 * 1024; 1148 -- Part of the stack used as a guard page. This is an OS dependent 1149 -- value, so we need to use the maximum. This value is only used 1150 -- when the stack address is known, that is currently Windows. 1151 1152 Small_Overflow_Guard : constant := 12 * 1024; 1153 -- Note: this used to be 4K, but was changed to 12K, since 1154 -- smaller values resulted in segmentation faults from dynamic 1155 -- stack analysis. 1156 1157 Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024; 1158 Small_Stack_Limit : constant := 64 * 1024; 1159 -- ??? These three values are experimental, and seem to work on 1160 -- most platforms. They still need to be analyzed further. They 1161 -- also need documentation, what are they and why does the logic 1162 -- differ depending on whether the stack is large or small??? 1163 1164 Pattern_Size : Natural := 1165 Natural (Self_ID.Common. 1166 Compiler_Data.Pri_Stack_Info.Size); 1167 -- Size of the pattern 1168 1169 Stack_Base : Address; 1170 -- Address of the base of the stack 1171 1172 begin 1173 Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base; 1174 1175 if Stack_Base = Null_Address then 1176 1177 -- On many platforms, we don't know the real stack base 1178 -- address. Estimate it using an address in the frame. 1179 1180 Stack_Base := Bottom_Of_Stack'Address; 1181 1182 -- Also reduce the size of the stack to take into account the 1183 -- secondary stack array declared in this frame. This is for 1184 -- sure very conservative. 1185 1186 if not Parameters.Sec_Stack_Dynamic then 1187 Pattern_Size := 1188 Pattern_Size - Natural (Secondary_Stack_Size); 1189 end if; 1190 1191 -- Adjustments for inner frames 1192 1193 Pattern_Size := Pattern_Size - 1194 (if Pattern_Size < Small_Stack_Limit 1195 then Small_Overflow_Guard 1196 else Big_Overflow_Guard); 1197 else 1198 -- Reduce by the size of the final guard page 1199 1200 Pattern_Size := Pattern_Size - Guard_Page_Size; 1201 end if; 1202 1203 STPO.Lock_RTS; 1204 Initialize_Analyzer 1205 (Self_ID.Common.Analyzer, 1206 Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len), 1207 Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), 1208 SSE.To_Integer (Stack_Base), 1209 Pattern_Size); 1210 STPO.Unlock_RTS; 1211 Fill_Stack (Self_ID.Common.Analyzer); 1212 end; 1213 end if; 1214 1215 -- We setup the SEH (Structured Exception Handling) handler if supported 1216 -- on the target. 1217 1218 Install_SEH_Handler (SEH_Table'Address); 1219 1220 -- Initialize exception occurrence 1221 1222 Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); 1223 1224 -- We lock RTS_Lock to wait for activator to finish activating the rest 1225 -- of the chain, so that everyone in the chain comes out in priority 1226 -- order. 1227 1228 -- This also protects the value of 1229 -- Self_ID.Common.Activator.Common.Wait_Count. 1230 1231 Lock_RTS; 1232 Unlock_RTS; 1233 1234 if not System.Restrictions.Abort_Allowed then 1235 1236 -- If Abort is not allowed, reset the deferral level since it will 1237 -- not get changed by the generated code. Keeping a default value 1238 -- of one would prevent some operations (e.g. select or delay) to 1239 -- proceed successfully. 1240 1241 Self_ID.Deferral_Level := 0; 1242 end if; 1243 1244 if Global_Task_Debug_Event_Set then 1245 Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID); 1246 end if; 1247 1248 begin 1249 -- We are separating the following portion of the code in order to 1250 -- place the exception handlers in a different block. In this way, 1251 -- we do not call Set_Jmpbuf_Address (which needs Self) before we 1252 -- set Self in Enter_Task 1253 1254 -- Call the task body procedure 1255 1256 -- The task body is called with abort still deferred. That 1257 -- eliminates a dangerous window, for which we had to patch-up in 1258 -- Terminate_Task. 1259 1260 -- During the expansion of the task body, we insert an RTS-call 1261 -- to Abort_Undefer, at the first point where abort should be 1262 -- allowed. 1263 1264 Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); 1265 Initialization.Defer_Abort_Nestable (Self_ID); 1266 1267 exception 1268 -- We can't call Terminate_Task in the exception handlers below, 1269 -- since there may be (e.g. in the case of GCC exception handling) 1270 -- clean ups associated with the exception handler that need to 1271 -- access task specific data. 1272 1273 -- Defer abort so that this task can't be aborted while exiting 1274 1275 when Standard'Abort_Signal => 1276 Initialization.Defer_Abort_Nestable (Self_ID); 1277 1278 -- Update the cause that motivated the task termination so that 1279 -- the appropriate information is passed to the task termination 1280 -- procedure. Task termination as a result of waiting on a 1281 -- terminate alternative is a normal termination, although it is 1282 -- implemented using the abort mechanisms. 1283 1284 if Self_ID.Terminate_Alternative then 1285 Cause := Normal; 1286 1287 if Global_Task_Debug_Event_Set then 1288 Debug.Signal_Debug_Event 1289 (Debug.Debug_Event_Terminated, Self_ID); 1290 end if; 1291 else 1292 Cause := Abnormal; 1293 1294 if Global_Task_Debug_Event_Set then 1295 Debug.Signal_Debug_Event 1296 (Debug.Debug_Event_Abort_Terminated, Self_ID); 1297 end if; 1298 end if; 1299 1300 when others => 1301 -- ??? Using an E : others here causes CD2C11A to fail on Tru64 1302 1303 Initialization.Defer_Abort_Nestable (Self_ID); 1304 1305 -- Perform the task specific exception tracing duty. We handle 1306 -- these outputs here and not in the common notification routine 1307 -- because we need access to tasking related data and we don't 1308 -- want to drag dependencies against tasking related units in the 1309 -- the common notification units. Additionally, no trace is ever 1310 -- triggered from the common routine for the Unhandled_Raise case 1311 -- in tasks, since an exception never appears unhandled in this 1312 -- context because of this handler. 1313 1314 if Exception_Trace = Unhandled_Raise then 1315 Trace_Unhandled_Exception_In_Task (Self_ID); 1316 end if; 1317 1318 -- Update the cause that motivated the task termination so that 1319 -- the appropriate information is passed to the task termination 1320 -- procedure, as well as the associated Exception_Occurrence. 1321 1322 Cause := Unhandled_Exception; 1323 1324 Save_Occurrence (EO, SSL.Get_Current_Excep.all.all); 1325 1326 if Global_Task_Debug_Event_Set then 1327 Debug.Signal_Debug_Event 1328 (Debug.Debug_Event_Exception_Terminated, Self_ID); 1329 end if; 1330 end; 1331 1332 -- Look for a task termination handler. This code is for all tasks but 1333 -- the environment task. The task termination code for the environment 1334 -- task is executed by SSL.Task_Termination_Handler. 1335 1336 if Single_Lock then 1337 Lock_RTS; 1338 end if; 1339 1340 Write_Lock (Self_ID); 1341 1342 if Self_ID.Common.Specific_Handler /= null then 1343 TH := Self_ID.Common.Specific_Handler; 1344 else 1345 -- Look for a fall-back handler following the master relationship 1346 -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back 1347 -- handler applies only to the dependent tasks of the task". Hence, 1348 -- if the terminating tasks (Self_ID) had a fall-back handler, it 1349 -- would not apply to itself, so we start the search with the parent. 1350 1351 Search_Fall_Back_Handler (Self_ID.Common.Parent); 1352 end if; 1353 1354 Unlock (Self_ID); 1355 1356 if Single_Lock then 1357 Unlock_RTS; 1358 end if; 1359 1360 -- Execute the task termination handler if we found it 1361 1362 if TH /= null then 1363 begin 1364 TH.all (Cause, Self_ID, EO); 1365 1366 exception 1367 1368 -- RM-C.7.3 requires all exceptions raised here to be ignored 1369 1370 when others => 1371 null; 1372 end; 1373 end if; 1374 1375 if System.Stack_Usage.Is_Enabled then 1376 Compute_Result (Self_ID.Common.Analyzer); 1377 Report_Result (Self_ID.Common.Analyzer); 1378 end if; 1379 1380 Terminate_Task (Self_ID); 1381 end Task_Wrapper; 1382 1383 -------------------- 1384 -- Terminate_Task -- 1385 -------------------- 1386 1387 -- Before we allow the thread to exit, we must clean up. This is a delicate 1388 -- job. We must wake up the task's master, who may immediately try to 1389 -- deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING. 1390 1391 -- To avoid this, the parent task must be blocked up to the latest 1392 -- statement executed. The trouble is that we have another step that we 1393 -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD. 1394 -- We have to postpone that until the end because compiler-generated code 1395 -- is likely to try to access that data at just about any point. 1396 1397 -- We can't call Destroy_TSD while we are holding any other locks, because 1398 -- it locks Global_Task_Lock, and our deadlock prevention rules require 1399 -- that to be the outermost lock. Our first "solution" was to just lock 1400 -- Global_Task_Lock in addition to the other locks, and force the parent to 1401 -- also lock this lock between its wakeup and its freeing of the ATCB. See 1402 -- Complete_Task for the parent-side of the code that has the matching 1403 -- calls to Task_Lock and Task_Unlock. That was not really a solution, 1404 -- since the operation Task_Unlock continued to access the ATCB after 1405 -- unlocking, after which the parent was observed to race ahead, deallocate 1406 -- the ATCB, and then reallocate it to another task. The call to 1407 -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting 1408 -- the data of the new task that reused the ATCB. To solve this problem, we 1409 -- introduced the new operation Final_Task_Unlock. 1410 1411 procedure Terminate_Task (Self_ID : Task_Id) is 1412 Environment_Task : constant Task_Id := STPO.Environment_Task; 1413 Master_of_Task : Integer; 1414 Deallocate : Boolean; 1415 1416 begin 1417 Debug.Task_Termination_Hook; 1418 1419 if Runtime_Traces then 1420 Send_Trace_Info (T_Terminate); 1421 end if; 1422 1423 -- Since GCC cannot allocate stack chunks efficiently without reordering 1424 -- some of the allocations, we have to handle this unexpected situation 1425 -- here. Normally we never have to call Vulnerable_Complete_Task here. 1426 1427 if Self_ID.Common.Activator /= null then 1428 Vulnerable_Complete_Task (Self_ID); 1429 end if; 1430 1431 Initialization.Task_Lock (Self_ID); 1432 1433 if Single_Lock then 1434 Lock_RTS; 1435 end if; 1436 1437 Master_of_Task := Self_ID.Master_of_Task; 1438 1439 -- Check if the current task is an independent task If so, decrement 1440 -- the Independent_Task_Count value. 1441 1442 if Master_of_Task = Independent_Task_Level then 1443 if Single_Lock then 1444 Utilities.Independent_Task_Count := 1445 Utilities.Independent_Task_Count - 1; 1446 1447 else 1448 Write_Lock (Environment_Task); 1449 Utilities.Independent_Task_Count := 1450 Utilities.Independent_Task_Count - 1; 1451 Unlock (Environment_Task); 1452 end if; 1453 end if; 1454 1455 -- Unprotect the guard page if needed 1456 1457 Stack_Guard (Self_ID, False); 1458 1459 Utilities.Make_Passive (Self_ID, Task_Completed => True); 1460 Deallocate := Self_ID.Free_On_Termination; 1461 1462 if Single_Lock then 1463 Unlock_RTS; 1464 end if; 1465 1466 pragma Assert (Check_Exit (Self_ID)); 1467 1468 SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); 1469 Initialization.Final_Task_Unlock (Self_ID); 1470 1471 -- WARNING: past this point, this thread must assume that the ATCB has 1472 -- been deallocated, and can't access it anymore (which is why we have 1473 -- saved the Free_On_Termination flag in a temporary variable). 1474 1475 if Deallocate then 1476 Free_Task (Self_ID); 1477 end if; 1478 1479 if Master_of_Task > 0 then 1480 STPO.Exit_Task; 1481 end if; 1482 end Terminate_Task; 1483 1484 ---------------- 1485 -- Terminated -- 1486 ---------------- 1487 1488 function Terminated (T : Task_Id) return Boolean is 1489 Self_ID : constant Task_Id := STPO.Self; 1490 Result : Boolean; 1491 1492 begin 1493 Initialization.Defer_Abort_Nestable (Self_ID); 1494 1495 if Single_Lock then 1496 Lock_RTS; 1497 end if; 1498 1499 Write_Lock (T); 1500 Result := T.Common.State = Terminated; 1501 Unlock (T); 1502 1503 if Single_Lock then 1504 Unlock_RTS; 1505 end if; 1506 1507 Initialization.Undefer_Abort_Nestable (Self_ID); 1508 return Result; 1509 end Terminated; 1510 1511 ---------------------------------------- 1512 -- Trace_Unhandled_Exception_In_Task -- 1513 ---------------------------------------- 1514 1515 procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is 1516 procedure To_Stderr (S : String); 1517 pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); 1518 1519 use System.Soft_Links; 1520 use System.Standard_Library; 1521 1522 function To_Address is new 1523 Ada.Unchecked_Conversion 1524 (Task_Id, System.Task_Primitives.Task_Address); 1525 1526 function Tailored_Exception_Information 1527 (E : Exception_Occurrence) return String; 1528 pragma Import 1529 (Ada, Tailored_Exception_Information, 1530 "__gnat_tailored_exception_information"); 1531 1532 Excep : constant Exception_Occurrence_Access := 1533 SSL.Get_Current_Excep.all; 1534 1535 begin 1536 -- This procedure is called by the task outermost handler in 1537 -- Task_Wrapper below, so only once the task stack has been fully 1538 -- unwound. The common notification routine has been called at the 1539 -- raise point already. 1540 1541 -- Lock to prevent unsynchronized output 1542 1543 Initialization.Task_Lock (Self_Id); 1544 To_Stderr ("task "); 1545 1546 if Self_Id.Common.Task_Image_Len /= 0 then 1547 To_Stderr 1548 (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len)); 1549 To_Stderr ("_"); 1550 end if; 1551 1552 To_Stderr (System.Address_Image (To_Address (Self_Id))); 1553 To_Stderr (" terminated by unhandled exception"); 1554 To_Stderr ((1 => ASCII.LF)); 1555 To_Stderr (Tailored_Exception_Information (Excep.all)); 1556 Initialization.Task_Unlock (Self_Id); 1557 end Trace_Unhandled_Exception_In_Task; 1558 1559 ------------------------------------ 1560 -- Vulnerable_Complete_Activation -- 1561 ------------------------------------ 1562 1563 -- As in several other places, the locks of the activator and activated 1564 -- task are both locked here. This follows our deadlock prevention lock 1565 -- ordering policy, since the activated task must be created after the 1566 -- activator. 1567 1568 procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is 1569 Activator : constant Task_Id := Self_ID.Common.Activator; 1570 1571 begin 1572 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C')); 1573 1574 Write_Lock (Activator); 1575 Write_Lock (Self_ID); 1576 1577 pragma Assert (Self_ID.Common.Activator /= null); 1578 1579 -- Remove dangling reference to Activator, since a task may outlive its 1580 -- activator. 1581 1582 Self_ID.Common.Activator := null; 1583 1584 -- Wake up the activator, if it is waiting for a chain of tasks to 1585 -- activate, and we are the last in the chain to complete activation. 1586 1587 if Activator.Common.State = Activator_Sleep then 1588 Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; 1589 1590 if Activator.Common.Wait_Count = 0 then 1591 Wakeup (Activator, Activator_Sleep); 1592 end if; 1593 end if; 1594 1595 -- The activator raises a Tasking_Error if any task it is activating 1596 -- is completed before the activation is done. However, if the reason 1597 -- for the task completion is an abort, we do not raise an exception. 1598 -- See RM 9.2(5). 1599 1600 if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then 1601 Activator.Common.Activation_Failed := True; 1602 end if; 1603 1604 Unlock (Self_ID); 1605 Unlock (Activator); 1606 1607 -- After the activation, active priority should be the same as base 1608 -- priority. We must unlock the Activator first, though, since it 1609 -- should not wait if we have lower priority. 1610 1611 if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then 1612 Write_Lock (Self_ID); 1613 Set_Priority (Self_ID, Self_ID.Common.Base_Priority); 1614 Unlock (Self_ID); 1615 end if; 1616 end Vulnerable_Complete_Activation; 1617 1618 -------------------------------- 1619 -- Vulnerable_Complete_Master -- 1620 -------------------------------- 1621 1622 procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is 1623 C : Task_Id; 1624 P : Task_Id; 1625 CM : constant Master_Level := Self_ID.Master_Within; 1626 T : aliased Task_Id; 1627 1628 To_Be_Freed : Task_Id; 1629 -- This is a list of ATCBs to be freed, after we have released all RTS 1630 -- locks. This is necessary because of the locking order rules, since 1631 -- the storage manager uses Global_Task_Lock. 1632 1633 pragma Warnings (Off); 1634 function Check_Unactivated_Tasks return Boolean; 1635 pragma Warnings (On); 1636 -- Temporary error-checking code below. This is part of the checks 1637 -- added in the new run time. Call it only inside a pragma Assert. 1638 1639 ----------------------------- 1640 -- Check_Unactivated_Tasks -- 1641 ----------------------------- 1642 1643 function Check_Unactivated_Tasks return Boolean is 1644 begin 1645 if not Single_Lock then 1646 Lock_RTS; 1647 end if; 1648 1649 Write_Lock (Self_ID); 1650 1651 C := All_Tasks_List; 1652 while C /= null loop 1653 if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then 1654 return False; 1655 end if; 1656 1657 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then 1658 Write_Lock (C); 1659 1660 if C.Common.State = Unactivated then 1661 return False; 1662 end if; 1663 1664 Unlock (C); 1665 end if; 1666 1667 C := C.Common.All_Tasks_Link; 1668 end loop; 1669 1670 Unlock (Self_ID); 1671 1672 if not Single_Lock then 1673 Unlock_RTS; 1674 end if; 1675 1676 return True; 1677 end Check_Unactivated_Tasks; 1678 1679 -- Start of processing for Vulnerable_Complete_Master 1680 1681 begin 1682 pragma Debug 1683 (Debug.Trace (Self_ID, "V_Complete_Master(" & CM'Img & ")", 'C')); 1684 1685 pragma Assert (Self_ID.Common.Wait_Count = 0); 1686 pragma Assert 1687 (Self_ID.Deferral_Level > 0 1688 or else not System.Restrictions.Abort_Allowed); 1689 1690 -- Count how many active dependent tasks this master currently has, and 1691 -- record this in Wait_Count. 1692 1693 -- This count should start at zero, since it is initialized to zero for 1694 -- new tasks, and the task should not exit the sleep-loops that use this 1695 -- count until the count reaches zero. 1696 1697 -- While we're counting, if we run across any unactivated tasks that 1698 -- belong to this master, we summarily terminate them as required by 1699 -- RM-9.2(6). 1700 1701 Lock_RTS; 1702 Write_Lock (Self_ID); 1703 1704 C := All_Tasks_List; 1705 while C /= null loop 1706 1707 -- Terminate unactivated (never-to-be activated) tasks 1708 1709 if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then 1710 1711 -- Usually, C.Common.Activator = Self_ID implies C.Master_of_Task 1712 -- = CM. The only case where C is pending activation by this 1713 -- task, but the master of C is not CM is in Ada 2005, when C is 1714 -- part of a return object of a build-in-place function. 1715 1716 pragma Assert (C.Common.State = Unactivated); 1717 1718 Write_Lock (C); 1719 C.Common.Activator := null; 1720 C.Common.State := Terminated; 1721 C.Callable := False; 1722 Utilities.Cancel_Queued_Entry_Calls (C); 1723 Unlock (C); 1724 end if; 1725 1726 -- Count it if directly dependent on this master 1727 1728 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then 1729 Write_Lock (C); 1730 1731 if C.Awake_Count /= 0 then 1732 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; 1733 end if; 1734 1735 Unlock (C); 1736 end if; 1737 1738 C := C.Common.All_Tasks_Link; 1739 end loop; 1740 1741 Self_ID.Common.State := Master_Completion_Sleep; 1742 Unlock (Self_ID); 1743 1744 if not Single_Lock then 1745 Unlock_RTS; 1746 end if; 1747 1748 -- Wait until dependent tasks are all terminated or ready to terminate. 1749 -- While waiting, the task may be awakened if the task's priority needs 1750 -- changing, or this master is aborted. In the latter case, we abort the 1751 -- dependents, and resume waiting until Wait_Count goes to zero. 1752 1753 Write_Lock (Self_ID); 1754 1755 loop 1756 exit when Self_ID.Common.Wait_Count = 0; 1757 1758 -- Here is a difference as compared to Complete_Master 1759 1760 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 1761 and then not Self_ID.Dependents_Aborted 1762 then 1763 if Single_Lock then 1764 Abort_Dependents (Self_ID); 1765 else 1766 Unlock (Self_ID); 1767 Lock_RTS; 1768 Abort_Dependents (Self_ID); 1769 Unlock_RTS; 1770 Write_Lock (Self_ID); 1771 end if; 1772 else 1773 pragma Debug 1774 (Debug.Trace (Self_ID, "master_completion_sleep", 'C')); 1775 Sleep (Self_ID, Master_Completion_Sleep); 1776 end if; 1777 end loop; 1778 1779 Self_ID.Common.State := Runnable; 1780 Unlock (Self_ID); 1781 1782 -- Dependents are all terminated or on terminate alternatives. Now, 1783 -- force those on terminate alternatives to terminate, by aborting them. 1784 1785 pragma Assert (Check_Unactivated_Tasks); 1786 1787 if Self_ID.Alive_Count > 1 then 1788 -- ??? 1789 -- Consider finding a way to skip the following extra steps if there 1790 -- are no dependents with terminate alternatives. This could be done 1791 -- by adding another count to the ATCB, similar to Awake_Count, but 1792 -- keeping track of tasks that are on terminate alternatives. 1793 1794 pragma Assert (Self_ID.Common.Wait_Count = 0); 1795 1796 -- Force any remaining dependents to terminate by aborting them 1797 1798 if not Single_Lock then 1799 Lock_RTS; 1800 end if; 1801 1802 Abort_Dependents (Self_ID); 1803 1804 -- Above, when we "abort" the dependents we are simply using this 1805 -- operation for convenience. We are not required to support the full 1806 -- abort-statement semantics; in particular, we are not required to 1807 -- immediately cancel any queued or in-service entry calls. That is 1808 -- good, because if we tried to cancel a call we would need to lock 1809 -- the caller, in order to wake the caller up. Our anti-deadlock 1810 -- rules prevent us from doing that without releasing the locks on C 1811 -- and Self_ID. Releasing and retaking those locks would be wasteful 1812 -- at best, and should not be considered further without more 1813 -- detailed analysis of potential concurrent accesses to the ATCBs 1814 -- of C and Self_ID. 1815 1816 -- Count how many "alive" dependent tasks this master currently has, 1817 -- and record this in Wait_Count. This count should start at zero, 1818 -- since it is initialized to zero for new tasks, and the task should 1819 -- not exit the sleep-loops that use this count until the count 1820 -- reaches zero. 1821 1822 pragma Assert (Self_ID.Common.Wait_Count = 0); 1823 1824 Write_Lock (Self_ID); 1825 1826 C := All_Tasks_List; 1827 while C /= null loop 1828 if C.Common.Parent = Self_ID and then C.Master_of_Task = CM then 1829 Write_Lock (C); 1830 1831 pragma Assert (C.Awake_Count = 0); 1832 1833 if C.Alive_Count > 0 then 1834 pragma Assert (C.Terminate_Alternative); 1835 Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; 1836 end if; 1837 1838 Unlock (C); 1839 end if; 1840 1841 C := C.Common.All_Tasks_Link; 1842 end loop; 1843 1844 Self_ID.Common.State := Master_Phase_2_Sleep; 1845 Unlock (Self_ID); 1846 1847 if not Single_Lock then 1848 Unlock_RTS; 1849 end if; 1850 1851 -- Wait for all counted tasks to finish terminating themselves 1852 1853 Write_Lock (Self_ID); 1854 1855 loop 1856 exit when Self_ID.Common.Wait_Count = 0; 1857 Sleep (Self_ID, Master_Phase_2_Sleep); 1858 end loop; 1859 1860 Self_ID.Common.State := Runnable; 1861 Unlock (Self_ID); 1862 end if; 1863 1864 -- We don't wake up for abort here. We are already terminating just as 1865 -- fast as we can, so there is no point. 1866 1867 -- Remove terminated tasks from the list of Self_ID's dependents, but 1868 -- don't free their ATCBs yet, because of lock order restrictions, which 1869 -- don't allow us to call "free" or "malloc" while holding any other 1870 -- locks. Instead, we put those ATCBs to be freed onto a temporary list, 1871 -- called To_Be_Freed. 1872 1873 if not Single_Lock then 1874 Lock_RTS; 1875 end if; 1876 1877 C := All_Tasks_List; 1878 P := null; 1879 while C /= null loop 1880 1881 -- If Free_On_Termination is set, do nothing here, and let the 1882 -- task free itself if not already done, otherwise we risk a race 1883 -- condition where Vulnerable_Free_Task is called in the loop below, 1884 -- while the task calls Free_Task itself, in Terminate_Task. 1885 1886 if C.Common.Parent = Self_ID 1887 and then C.Master_of_Task >= CM 1888 and then not C.Free_On_Termination 1889 then 1890 if P /= null then 1891 P.Common.All_Tasks_Link := C.Common.All_Tasks_Link; 1892 else 1893 All_Tasks_List := C.Common.All_Tasks_Link; 1894 end if; 1895 1896 T := C.Common.All_Tasks_Link; 1897 C.Common.All_Tasks_Link := To_Be_Freed; 1898 To_Be_Freed := C; 1899 C := T; 1900 1901 else 1902 P := C; 1903 C := C.Common.All_Tasks_Link; 1904 end if; 1905 end loop; 1906 1907 Unlock_RTS; 1908 1909 -- Free all the ATCBs on the list To_Be_Freed 1910 1911 -- The ATCBs in the list are no longer in All_Tasks_List, and after 1912 -- any interrupt entries are detached from them they should no longer 1913 -- be referenced. 1914 1915 -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to 1916 -- avoid a race between a terminating task and its parent. The parent 1917 -- might try to deallocate the ACTB out from underneath the exiting 1918 -- task. Note that Free will also lock Global_Task_Lock, but that is 1919 -- OK, since this is the *one* lock for which we have a mechanism to 1920 -- support nested locking. See Task_Wrapper and its finalizer for more 1921 -- explanation. 1922 1923 -- ??? 1924 -- The check "T.Common.Parent /= null ..." below is to prevent dangling 1925 -- references to terminated library-level tasks, which could otherwise 1926 -- occur during finalization of library-level objects. A better solution 1927 -- might be to hook task objects into the finalization chain and 1928 -- deallocate the ATCB when the task object is deallocated. However, 1929 -- this change is not likely to gain anything significant, since all 1930 -- this storage should be recovered en-masse when the process exits. 1931 1932 while To_Be_Freed /= null loop 1933 T := To_Be_Freed; 1934 To_Be_Freed := T.Common.All_Tasks_Link; 1935 1936 -- ??? On SGI there is currently no Interrupt_Manager, that's why we 1937 -- need to check if the Interrupt_Manager_ID is null. 1938 1939 if T.Interrupt_Entry and then Interrupt_Manager_ID /= null then 1940 declare 1941 Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1; 1942 -- Corresponds to the entry index of System.Interrupts. 1943 -- Interrupt_Manager.Detach_Interrupt_Entries. Be sure 1944 -- to update this value when changing Interrupt_Manager specs. 1945 1946 type Param_Type is access all Task_Id; 1947 1948 Param : aliased Param_Type := T'Access; 1949 1950 begin 1951 System.Tasking.Rendezvous.Call_Simple 1952 (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index, 1953 Param'Address); 1954 end; 1955 end if; 1956 1957 if (T.Common.Parent /= null 1958 and then T.Common.Parent.Common.Parent /= null) 1959 or else T.Master_of_Task > Library_Task_Level 1960 then 1961 Initialization.Task_Lock (Self_ID); 1962 1963 -- If Sec_Stack_Addr is not null, it means that Destroy_TSD 1964 -- has not been called yet (case of an unactivated task). 1965 1966 if T.Common.Compiler_Data.Sec_Stack_Addr /= Null_Address then 1967 SSL.Destroy_TSD (T.Common.Compiler_Data); 1968 end if; 1969 1970 Vulnerable_Free_Task (T); 1971 Initialization.Task_Unlock (Self_ID); 1972 end if; 1973 end loop; 1974 1975 -- It might seem nice to let the terminated task deallocate its own 1976 -- ATCB. That would not cover the case of unactivated tasks. It also 1977 -- would force us to keep the underlying thread around past termination, 1978 -- since references to the ATCB are possible past termination. 1979 1980 -- Currently, we get rid of the thread as soon as the task terminates, 1981 -- and let the parent recover the ATCB later. 1982 1983 -- Some day, if we want to recover the ATCB earlier, at task 1984 -- termination, we could consider using "fat task IDs", that include the 1985 -- serial number with the ATCB pointer, to catch references to tasks 1986 -- that no longer have ATCBs. It is not clear how much this would gain, 1987 -- since the user-level task object would still be occupying storage. 1988 1989 -- Make next master level up active. We don't need to lock the ATCB, 1990 -- since the value is only updated by each task for itself. 1991 1992 Self_ID.Master_Within := CM - 1; 1993 end Vulnerable_Complete_Master; 1994 1995 ------------------------------ 1996 -- Vulnerable_Complete_Task -- 1997 ------------------------------ 1998 1999 -- Complete the calling task 2000 2001 -- This procedure must be called with abort deferred. It should only be 2002 -- called by Complete_Task and Finalize_Global_Tasks (for the environment 2003 -- task). 2004 2005 -- The effect is similar to that of Complete_Master. Differences include 2006 -- the closing of entries here, and computation of the number of active 2007 -- dependent tasks in Complete_Master. 2008 2009 -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation, 2010 -- because that does its own locking, and because we do not need the lock 2011 -- to test Self_ID.Common.Activator. That value should only be read and 2012 -- modified by Self. 2013 2014 procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is 2015 begin 2016 pragma Assert 2017 (Self_ID.Deferral_Level > 0 2018 or else not System.Restrictions.Abort_Allowed); 2019 pragma Assert (Self_ID = Self); 2020 pragma Assert (Self_ID.Master_Within = Self_ID.Master_of_Task + 1 2021 or else 2022 Self_ID.Master_Within = Self_ID.Master_of_Task + 2); 2023 pragma Assert (Self_ID.Common.Wait_Count = 0); 2024 pragma Assert (Self_ID.Open_Accepts = null); 2025 pragma Assert (Self_ID.ATC_Nesting_Level = 1); 2026 2027 pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C')); 2028 2029 if Single_Lock then 2030 Lock_RTS; 2031 end if; 2032 2033 Write_Lock (Self_ID); 2034 Self_ID.Callable := False; 2035 2036 -- In theory, Self should have no pending entry calls left on its 2037 -- call-stack. Each async. select statement should clean its own call, 2038 -- and blocking entry calls should defer abort until the calls are 2039 -- cancelled, then clean up. 2040 2041 Utilities.Cancel_Queued_Entry_Calls (Self_ID); 2042 Unlock (Self_ID); 2043 2044 if Self_ID.Common.Activator /= null then 2045 Vulnerable_Complete_Activation (Self_ID); 2046 end if; 2047 2048 if Single_Lock then 2049 Unlock_RTS; 2050 end if; 2051 2052 -- If Self_ID.Master_Within = Self_ID.Master_of_Task + 2 we may have 2053 -- dependent tasks for which we need to wait. Otherwise we just exit. 2054 2055 if Self_ID.Master_Within = Self_ID.Master_of_Task + 2 then 2056 Vulnerable_Complete_Master (Self_ID); 2057 end if; 2058 end Vulnerable_Complete_Task; 2059 2060 -------------------------- 2061 -- Vulnerable_Free_Task -- 2062 -------------------------- 2063 2064 -- Recover all runtime system storage associated with the task T. This 2065 -- should only be called after T has terminated and will no longer be 2066 -- referenced. 2067 2068 -- For tasks created by an allocator that fails, due to an exception, it 2069 -- is called from Expunge_Unactivated_Tasks. 2070 2071 -- For tasks created by elaboration of task object declarations it is 2072 -- called from the finalization code of the Task_Wrapper procedure. 2073 2074 procedure Vulnerable_Free_Task (T : Task_Id) is 2075 begin 2076 pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T)); 2077 2078 if Single_Lock then 2079 Lock_RTS; 2080 end if; 2081 2082 Write_Lock (T); 2083 Initialization.Finalize_Attributes_Link.all (T); 2084 Unlock (T); 2085 2086 if Single_Lock then 2087 Unlock_RTS; 2088 end if; 2089 2090 System.Task_Primitives.Operations.Finalize_TCB (T); 2091 end Vulnerable_Free_Task; 2092 2093-- Package elaboration code 2094 2095begin 2096 -- Establish the Adafinal softlink 2097 2098 -- This is not done inside the central RTS initialization routine 2099 -- to avoid with'ing this package from System.Tasking.Initialization. 2100 2101 SSL.Adafinal := Finalize_Global_Tasks'Access; 2102 2103 -- Establish soft links for subprograms that manipulate master_id's. 2104 -- This cannot be done when the RTS is initialized, because of various 2105 -- elaboration constraints. 2106 2107 SSL.Current_Master := Stages.Current_Master'Access; 2108 SSL.Enter_Master := Stages.Enter_Master'Access; 2109 SSL.Complete_Master := Stages.Complete_Master'Access; 2110end System.Tasking.Stages; 2111