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