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