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