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