| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- |
| -- -- |
| -- S Y S T E M . T A S K I N G . S T A G E S -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNARL is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- GNARL was developed by the GNARL team at Florida State University. -- |
| -- Extensive contributions were provided by Ada Core Technologies, Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| pragma Partition_Elaboration_Policy (Concurrent); |
| -- This package only implements the concurrent elaboration policy. This pragma |
| -- will enforce it (and detect conflicts with user specified policy). |
| |
| with Ada.Exceptions; |
| with Ada.Unchecked_Deallocation; |
| with Ada.Task_Initialization; |
| |
| with System.Interrupt_Management; |
| with System.Tasking.Debug; |
| with System.Address_Image; |
| with System.Task_Primitives; |
| with System.Task_Primitives.Operations; |
| with System.Tasking.Utilities; |
| with System.Tasking.Queuing; |
| with System.Tasking.Rendezvous; |
| with System.OS_Primitives; |
| with System.Secondary_Stack; |
| with System.Restrictions; |
| with System.Standard_Library; |
| with System.Stack_Usage; |
| with System.Storage_Elements; |
| |
| with System.Soft_Links; |
| -- These are procedure pointers to non-tasking routines that use task |
| -- specific data. In the absence of tasking, these routines refer to global |
| -- data. In the presence of tasking, they must be replaced with pointers to |
| -- task-specific versions. Also used for Create_TSD, Destroy_TSD, Get_Current |
| -- _Excep, Finalize_Library_Objects, Task_Termination, Handler. |
| |
| with System.Tasking.Initialization; |
| pragma Elaborate_All (System.Tasking.Initialization); |
| -- This insures that tasking is initialized if any tasks are created |
| |
| package body System.Tasking.Stages is |
| |
| package STPO renames System.Task_Primitives.Operations; |
| package SSL renames System.Soft_Links; |
| package SSE renames System.Storage_Elements; |
| |
| use Ada.Exceptions; |
| |
| use Secondary_Stack; |
| use Task_Primitives; |
| use Task_Primitives.Operations; |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| procedure Free is new |
| Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); |
| |
| procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id); |
| -- This procedure outputs the task specific message for exception |
| -- tracing purposes. |
| |
| procedure Task_Wrapper (Self_ID : Task_Id); |
| pragma Convention (C, Task_Wrapper); |
| -- This is the procedure that is called by the GNULL from the new context |
| -- when a task is created. It waits for activation and then calls the task |
| -- body procedure. When the task body procedure completes, it terminates |
| -- the task. |
| -- |
| -- The Task_Wrapper's address will be provided to the underlying threads |
| -- library as the task entry point. Convention C is what makes most sense |
| -- for that purpose (Export C would make the function globally visible, |
| -- and affect the link name on which GDB depends). This will in addition |
| -- trigger an automatic stack alignment suitable for GCC's assumptions if |
| -- need be. |
| |
| -- "Vulnerable_..." in the procedure names below means they must be called |
| -- with abort deferred. |
| |
| procedure Vulnerable_Complete_Task (Self_ID : Task_Id); |
| -- Complete the calling task. This procedure must be called with |
| -- abort deferred. It should only be called by Complete_Task and |
| -- Finalize_Global_Tasks (for the environment task). |
| |
| procedure Vulnerable_Complete_Master (Self_ID : Task_Id); |
| -- Complete the current master of the calling task. This procedure |
| -- must be called with abort deferred. It should only be called by |
| -- Vulnerable_Complete_Task and Complete_Master. |
| |
| procedure Vulnerable_Complete_Activation (Self_ID : Task_Id); |
| -- Signal to Self_ID's activator that Self_ID has completed activation. |
| -- This procedure must be called with abort deferred. |
| |
| procedure Abort_Dependents (Self_ID : Task_Id); |
| -- Abort all the direct dependents of Self at its current master nesting |
| -- level, plus all of their dependents, transitively. RTS_Lock should be |
| -- locked by the caller. |
| |
| procedure Vulnerable_Free_Task (T : Task_Id); |
| -- Recover all runtime system storage associated with the task T. This |
| -- should only be called after T has terminated and will no longer be |
| -- referenced. |
| -- |
| -- For tasks created by an allocator that fails, due to an exception, it is |
| -- called from Expunge_Unactivated_Tasks. |
| -- |
| -- Different code is used at master completion, in Terminate_Dependents, |
| -- due to a need for tighter synchronization with the master. |
| |
| ---------------------- |
| -- Abort_Dependents -- |
| ---------------------- |
| |
| procedure Abort_Dependents (Self_ID : Task_Id) is |
| C : Task_Id; |
| P : Task_Id; |
| |
| -- Each task C will take care of its own dependents, so there is no |
| -- need to worry about them here. In fact, it would be wrong to abort |
| -- indirect dependents here, because we can't distinguish between |
| -- duplicate master ids. For example, suppose we have three nested |
| -- task bodies T1,T2,T3. And suppose T1 also calls P which calls Q (and |
| -- both P and Q are task masters). Q will have the same master id as |
| -- Master_Of_Task of T3. Previous versions of this would abort T3 when |
| -- Q calls Complete_Master, which was completely wrong. |
| |
| begin |
| C := All_Tasks_List; |
| while C /= null loop |
| P := C.Common.Parent; |
| |
| if P = Self_ID then |
| if C.Master_Of_Task = Self_ID.Master_Within then |
| pragma Debug |
| (Debug.Trace (Self_ID, "Aborting", 'X', C)); |
| Utilities.Abort_One_Task (Self_ID, C); |
| C.Dependents_Aborted := True; |
| end if; |
| end if; |
| |
| C := C.Common.All_Tasks_Link; |
| end loop; |
| |
| Self_ID.Dependents_Aborted := True; |
| end Abort_Dependents; |
| |
| ----------------- |
| -- Abort_Tasks -- |
| ----------------- |
| |
| procedure Abort_Tasks (Tasks : Task_List) is |
| begin |
| Utilities.Abort_Tasks (Tasks); |
| end Abort_Tasks; |
| |
| -------------------- |
| -- Activate_Tasks -- |
| -------------------- |
| |
| -- Note that locks of activator and activated task are both locked here. |
| -- This is necessary because C.Common.State and Self.Common.Wait_Count have |
| -- to be synchronized. This is safe from deadlock because the activator is |
| -- always created before the activated task. That satisfies our |
| -- in-order-of-creation ATCB locking policy. |
| |
| -- At one point, we may also lock the parent, if the parent is different |
| -- from the activator. That is also consistent with the lock ordering |
| -- policy, since the activator cannot be created before the parent. |
| |
| -- Since we are holding both the activator's lock, and Task_Wrapper locks |
| -- that before it does anything more than initialize the low-level ATCB |
| -- components, it should be safe to wait to update the counts until we see |
| -- that the thread creation is successful. |
| |
| -- If the thread creation fails, we do need to close the entries of the |
| -- task. The first phase, of dequeuing calls, only requires locking the |
| -- acceptor's ATCB, but the waking up of the callers requires locking the |
| -- caller's ATCB. We cannot safely do this while we are holding other |
| -- locks. Therefore, the queue-clearing operation is done in a separate |
| -- pass over the activation chain. |
| |
| procedure Activate_Tasks (Chain_Access : Activation_Chain_Access) is |
| Self_ID : constant Task_Id := STPO.Self; |
| P : Task_Id; |
| C : Task_Id; |
| Next_C, Last_C : Task_Id; |
| Activate_Prio : System.Any_Priority; |
| Success : Boolean; |
| All_Elaborated : Boolean := True; |
| |
| begin |
| -- If pragma Detect_Blocking is active, then we must check whether this |
| -- potentially blocking operation is called from a protected action. |
| |
| if System.Tasking.Detect_Blocking |
| and then Self_ID.Common.Protected_Action_Nesting > 0 |
| then |
| raise Program_Error with "potentially blocking operation"; |
| end if; |
| |
| pragma Debug |
| (Debug.Trace (Self_ID, "Activate_Tasks", 'C')); |
| |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| |
| pragma Assert (Self_ID.Common.Wait_Count = 0); |
| |
| -- Lock RTS_Lock, to prevent activated tasks from racing ahead before |
| -- we finish activating the chain. |
| |
| Lock_RTS; |
| |
| -- Check that all task bodies have been elaborated |
| |
| C := Chain_Access.T_ID; |
| Last_C := null; |
| while C /= null loop |
| if C.Common.Elaborated /= null |
| and then not C.Common.Elaborated.all |
| then |
| All_Elaborated := False; |
| end if; |
| |
| -- Reverse the activation chain so that tasks are activated in the |
| -- same order they're declared. |
| |
| Next_C := C.Common.Activation_Link; |
| C.Common.Activation_Link := Last_C; |
| Last_C := C; |
| C := Next_C; |
| end loop; |
| |
| Chain_Access.T_ID := Last_C; |
| |
| if not All_Elaborated then |
| Unlock_RTS; |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| raise Program_Error with "Some tasks have not been elaborated"; |
| end if; |
| |
| -- Activate all the tasks in the chain. Creation of the thread of |
| -- control was deferred until activation. So create it now. |
| |
| C := Chain_Access.T_ID; |
| while C /= null loop |
| if C.Common.State /= Terminated then |
| pragma Assert (C.Common.State = Unactivated); |
| |
| P := C.Common.Parent; |
| Write_Lock (P); |
| Write_Lock (C); |
| |
| Activate_Prio := |
| (if C.Common.Base_Priority < Get_Priority (Self_ID) |
| then Get_Priority (Self_ID) |
| else C.Common.Base_Priority); |
| |
| System.Task_Primitives.Operations.Create_Task |
| (C, Task_Wrapper'Address, |
| Parameters.Size_Type |
| (C.Common.Compiler_Data.Pri_Stack_Info.Size), |
| Activate_Prio, Success); |
| |
| -- There would be a race between the created task and the creator |
| -- to do the following initialization, if we did not have a |
| -- Lock/Unlock_RTS pair in the task wrapper to prevent it from |
| -- racing ahead. |
| |
| if Success then |
| C.Common.State := Activating; |
| C.Awake_Count := 1; |
| C.Alive_Count := 1; |
| P.Awake_Count := P.Awake_Count + 1; |
| P.Alive_Count := P.Alive_Count + 1; |
| |
| if P.Common.State = Master_Completion_Sleep and then |
| C.Master_Of_Task = P.Master_Within |
| then |
| pragma Assert (Self_ID /= P); |
| P.Common.Wait_Count := P.Common.Wait_Count + 1; |
| end if; |
| |
| for J in System.Tasking.Debug.Known_Tasks'Range loop |
| if System.Tasking.Debug.Known_Tasks (J) = null then |
| System.Tasking.Debug.Known_Tasks (J) := C; |
| C.Known_Tasks_Index := J; |
| exit; |
| end if; |
| end loop; |
| |
| if Global_Task_Debug_Event_Set then |
| Debug.Signal_Debug_Event |
| (Debug.Debug_Event_Activating, C); |
| end if; |
| |
| C.Common.State := Runnable; |
| |
| Unlock (C); |
| Unlock (P); |
| |
| else |
| -- No need to set Awake_Count, State, etc. here since the loop |
| -- below will do that for any Unactivated tasks. |
| |
| Unlock (C); |
| Unlock (P); |
| Self_ID.Common.Activation_Failed := True; |
| end if; |
| end if; |
| |
| C := C.Common.Activation_Link; |
| end loop; |
| |
| Unlock_RTS; |
| |
| -- Close the entries of any tasks that failed thread creation, and count |
| -- those that have not finished activation. |
| |
| Write_Lock (Self_ID); |
| Self_ID.Common.State := Activator_Sleep; |
| |
| C := Chain_Access.T_ID; |
| while C /= null loop |
| Write_Lock (C); |
| |
| if C.Common.State = Unactivated then |
| C.Common.Activator := null; |
| C.Common.State := Terminated; |
| C.Callable := False; |
| Utilities.Cancel_Queued_Entry_Calls (C); |
| |
| elsif C.Common.Activator /= null then |
| Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; |
| end if; |
| |
| Unlock (C); |
| P := C.Common.Activation_Link; |
| C.Common.Activation_Link := null; |
| C := P; |
| end loop; |
| |
| -- Wait for the activated tasks to complete activation. It is |
| -- unsafe to abort any of these tasks until the count goes to zero. |
| |
| loop |
| exit when Self_ID.Common.Wait_Count = 0; |
| Sleep (Self_ID, Activator_Sleep); |
| end loop; |
| |
| Self_ID.Common.State := Runnable; |
| Unlock (Self_ID); |
| |
| -- Remove the tasks from the chain |
| |
| Chain_Access.T_ID := null; |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| |
| if Self_ID.Common.Activation_Failed then |
| Self_ID.Common.Activation_Failed := False; |
| raise Tasking_Error with "Failure during activation"; |
| end if; |
| end Activate_Tasks; |
| |
| ------------------------- |
| -- Complete_Activation -- |
| ------------------------- |
| |
| procedure Complete_Activation is |
| Self_ID : constant Task_Id := STPO.Self; |
| |
| begin |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| Vulnerable_Complete_Activation (Self_ID); |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| |
| -- ??? Why do we need to allow for nested deferral here? |
| |
| end Complete_Activation; |
| |
| --------------------- |
| -- Complete_Master -- |
| --------------------- |
| |
| procedure Complete_Master is |
| Self_ID : constant Task_Id := STPO.Self; |
| begin |
| pragma Assert |
| (Self_ID.Deferral_Level > 0 |
| or else not System.Restrictions.Abort_Allowed); |
| Vulnerable_Complete_Master (Self_ID); |
| end Complete_Master; |
| |
| ------------------- |
| -- Complete_Task -- |
| ------------------- |
| |
| -- See comments on Vulnerable_Complete_Task for details |
| |
| procedure Complete_Task is |
| Self_ID : constant Task_Id := STPO.Self; |
| |
| begin |
| pragma Assert |
| (Self_ID.Deferral_Level > 0 |
| or else not System.Restrictions.Abort_Allowed); |
| |
| Vulnerable_Complete_Task (Self_ID); |
| |
| -- All of our dependents have terminated, never undefer abort again |
| |
| end Complete_Task; |
| |
| ----------------- |
| -- Create_Task -- |
| ----------------- |
| |
| -- Compiler interface only. Do not call from within the RTS. This must be |
| -- called to create a new task. |
| |
| procedure Create_Task |
| (Priority : Integer; |
| Stack_Size : System.Parameters.Size_Type; |
| Secondary_Stack_Size : System.Parameters.Size_Type; |
| Task_Info : System.Task_Info.Task_Info_Type; |
| CPU : Integer; |
| Relative_Deadline : Ada.Real_Time.Time_Span; |
| Domain : Dispatching_Domain_Access; |
| Num_Entries : Task_Entry_Index; |
| Master : Master_Level; |
| State : Task_Procedure_Access; |
| Discriminants : System.Address; |
| Elaborated : Access_Boolean; |
| Chain : in out Activation_Chain; |
| Task_Image : String; |
| Created_Task : out Task_Id) |
| is |
| T, P : Task_Id; |
| Self_ID : constant Task_Id := STPO.Self; |
| Success : Boolean; |
| Base_Priority : System.Any_Priority; |
| Len : Natural; |
| Base_CPU : System.Multiprocessors.CPU_Range; |
| |
| use type System.Multiprocessors.CPU_Range; |
| |
| pragma Unreferenced (Relative_Deadline); |
| -- EDF scheduling is not supported by any of the target platforms so |
| -- this parameter is not passed any further. |
| |
| begin |
| -- If Master is greater than the current master, it means that Master |
| -- has already awaited its dependent tasks. This raises Program_Error, |
| -- by 4.8(10.3/2). See AI-280. Ignore this check for foreign threads. |
| |
| if Self_ID.Master_Of_Task /= Foreign_Task_Level |
| and then Master > Self_ID.Master_Within |
| then |
| raise Program_Error with |
| "create task after awaiting termination"; |
| end if; |
| |
| -- If pragma Detect_Blocking is active must be checked whether this |
| -- potentially blocking operation is called from a protected action. |
| |
| if System.Tasking.Detect_Blocking |
| and then Self_ID.Common.Protected_Action_Nesting > 0 |
| then |
| raise Program_Error with "potentially blocking operation"; |
| end if; |
| |
| pragma Debug (Debug.Trace (Self_ID, "Create_Task", 'C')); |
| |
| Base_Priority := |
| (if Priority = Unspecified_Priority |
| then Self_ID.Common.Base_Priority |
| else System.Any_Priority (Priority)); |
| |
| -- Legal values of CPU are the special Unspecified_CPU value which is |
| -- inserted by the compiler for tasks without CPU aspect, and those in |
| -- the range of CPU_Range but no greater than Number_Of_CPUs. Otherwise |
| -- the task is defined to have failed, and it becomes a completed task |
| -- (RM D.16(14/3)). |
| |
| if CPU /= Unspecified_CPU |
| and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) |
| or else |
| CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) |
| then |
| raise Tasking_Error with "CPU not in range"; |
| |
| -- Normal CPU affinity |
| |
| else |
| -- When the application code says nothing about the task affinity |
| -- (task without CPU aspect) then the compiler inserts the value |
| -- Unspecified_CPU which indicates to the run-time library that |
| -- the task will activate and execute on the same processor as its |
| -- activating task if the activating task is assigned a processor |
| -- (RM D.16(14/3)). |
| |
| Base_CPU := |
| (if CPU = Unspecified_CPU |
| then Self_ID.Common.Base_CPU |
| else System.Multiprocessors.CPU_Range (CPU)); |
| end if; |
| |
| -- Find parent P of new Task, via master level number. Independent |
| -- tasks should have Parent = Environment_Task, and all tasks created |
| -- by independent tasks are also independent. See, for example, |
| -- s-interr.adb, where Interrupt_Manager does "new Server_Task". The |
| -- access type is at library level, so the parent of the Server_Task |
| -- is Environment_Task. |
| |
| P := Self_ID; |
| |
| if P.Master_Of_Task <= Independent_Task_Level then |
| P := Environment_Task; |
| else |
| while P /= null and then P.Master_Of_Task >= Master loop |
| P := P.Common.Parent; |
| end loop; |
| end if; |
| |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| |
| begin |
| T := New_ATCB (Num_Entries); |
| exception |
| when others => |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| raise Storage_Error with "Cannot allocate task"; |
| end; |
| |
| -- RTS_Lock is used by Abort_Dependents and Abort_Tasks. Up to this |
| -- point, it is possible that we may be part of a family of tasks that |
| -- is being aborted. |
| |
| Lock_RTS; |
| Write_Lock (Self_ID); |
| |
| -- Now, we must check that we have not been aborted. If so, we should |
| -- give up on creating this task, and simply return. |
| |
| if not Self_ID.Callable then |
| pragma Assert (Self_ID.Pending_ATC_Level = Level_Completed_Task); |
| pragma Assert (Self_ID.Pending_Action); |
| pragma Assert |
| (Chain.T_ID = null or else Chain.T_ID.Common.State = Unactivated); |
| |
| Unlock (Self_ID); |
| Unlock_RTS; |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| |
| -- ??? Should never get here |
| |
| pragma Assert (Standard.False); |
| raise Standard'Abort_Signal; |
| end if; |
| |
| Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated, |
| Base_Priority, Base_CPU, Domain, Task_Info, Stack_Size, T, Success); |
| |
| if not Success then |
| Free (T); |
| Unlock (Self_ID); |
| Unlock_RTS; |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| raise Storage_Error with "Failed to initialize task"; |
| end if; |
| |
| if Master = Foreign_Task_Level + 2 then |
| |
| -- This should not happen, except when a foreign task creates non |
| -- library-level Ada tasks. In this case, we pretend the master is |
| -- a regular library level task, otherwise the run-time will get |
| -- confused when waiting for these tasks to terminate. |
| |
| T.Master_Of_Task := Library_Task_Level; |
| |
| else |
| T.Master_Of_Task := Master; |
| end if; |
| |
| T.Master_Within := T.Master_Of_Task + 1; |
| |
| for L in T.Entry_Calls'Range loop |
| T.Entry_Calls (L).Self := T; |
| T.Entry_Calls (L).Level := L; |
| end loop; |
| |
| if Task_Image'Length = 0 then |
| T.Common.Task_Image_Len := 0; |
| else |
| Len := 1; |
| T.Common.Task_Image (1) := Task_Image (Task_Image'First); |
| |
| -- Remove unwanted blank space generated by 'Image |
| |
| for J in Task_Image'First + 1 .. Task_Image'Last loop |
| if Task_Image (J) /= ' ' |
| or else Task_Image (J - 1) /= '(' |
| then |
| Len := Len + 1; |
| T.Common.Task_Image (Len) := Task_Image (J); |
| exit when Len = T.Common.Task_Image'Last; |
| end if; |
| end loop; |
| |
| T.Common.Task_Image_Len := Len; |
| end if; |
| |
| -- Note: we used to have code here to initialize T.Common.Domain, but |
| -- that is not needed, since this is initialized in System.Tasking. |
| |
| Unlock (Self_ID); |
| Unlock_RTS; |
| |
| -- The CPU associated to the task (if any) must belong to the |
| -- dispatching domain. |
| |
| if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU |
| and then |
| (Base_CPU not in T.Common.Domain'Range |
| or else not T.Common.Domain (Base_CPU)) |
| then |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| raise Tasking_Error with "CPU not in dispatching domain"; |
| end if; |
| |
| -- To handle the interaction between pragma CPU and dispatching domains |
| -- we need to signal that this task is being allocated to a processor. |
| -- This is needed only for tasks belonging to the system domain (the |
| -- creation of new dispatching domains can only take processors from the |
| -- system domain) and only before the environment task calls the main |
| -- procedure (dispatching domains cannot be created after this). |
| |
| if Base_CPU /= System.Multiprocessors.Not_A_Specific_CPU |
| and then T.Common.Domain = System.Tasking.System_Domain |
| and then not System.Tasking.Dispatching_Domains_Frozen |
| then |
| -- Increase the number of tasks attached to the CPU to which this |
| -- task is being moved. |
| |
| Dispatching_Domain_Tasks (Base_CPU) := |
| Dispatching_Domain_Tasks (Base_CPU) + 1; |
| end if; |
| |
| -- Create the secondary stack for the task as early as possible during |
| -- in the creation of a task, since it may be used by the operation of |
| -- Ada code within the task. |
| |
| begin |
| SSL.Create_TSD (T.Common.Compiler_Data, null, Secondary_Stack_Size); |
| exception |
| when others => |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| raise Storage_Error with "Secondary stack could not be allocated"; |
| end; |
| |
| T.Common.Activation_Link := Chain.T_ID; |
| Chain.T_ID := T; |
| Created_Task := T; |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| |
| pragma Debug |
| (Debug.Trace |
| (Self_ID, "Created task in " & T.Master_Of_Task'Img, 'C', T)); |
| end Create_Task; |
| |
| -------------------- |
| -- Current_Master -- |
| -------------------- |
| |
| function Current_Master return Master_Level is |
| begin |
| return STPO.Self.Master_Within; |
| end Current_Master; |
| |
| ------------------ |
| -- Enter_Master -- |
| ------------------ |
| |
| procedure Enter_Master is |
| Self_ID : constant Task_Id := STPO.Self; |
| begin |
| Self_ID.Master_Within := Self_ID.Master_Within + 1; |
| pragma Debug |
| (Debug.Trace |
| (Self_ID, "Enter_Master ->" & Self_ID.Master_Within'Img, 'M')); |
| end Enter_Master; |
| |
| ------------------------------- |
| -- Expunge_Unactivated_Tasks -- |
| ------------------------------- |
| |
| -- See procedure Close_Entries for the general case |
| |
| procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain) is |
| Self_ID : constant Task_Id := STPO.Self; |
| C : Task_Id; |
| Call : Entry_Call_Link; |
| Temp : Task_Id; |
| |
| begin |
| pragma Debug |
| (Debug.Trace (Self_ID, "Expunge_Unactivated_Tasks", 'C')); |
| |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| |
| -- ??? |
| -- Experimentation has shown that abort is sometimes (but not always) |
| -- already deferred when this is called. |
| |
| -- That may indicate an error. Find out what is going on |
| |
| C := Chain.T_ID; |
| while C /= null loop |
| pragma Assert (C.Common.State = Unactivated); |
| |
| Temp := C.Common.Activation_Link; |
| |
| if C.Common.State = Unactivated then |
| Lock_RTS; |
| Write_Lock (C); |
| |
| for J in 1 .. C.Entry_Num loop |
| Queuing.Dequeue_Head (C.Entry_Queues (J), Call); |
| pragma Assert (Call = null); |
| end loop; |
| |
| Unlock (C); |
| |
| Initialization.Remove_From_All_Tasks_List (C); |
| Unlock_RTS; |
| |
| Vulnerable_Free_Task (C); |
| C := Temp; |
| end if; |
| end loop; |
| |
| Chain.T_ID := null; |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| end Expunge_Unactivated_Tasks; |
| |
| --------------------------- |
| -- Finalize_Global_Tasks -- |
| --------------------------- |
| |
| -- ??? |
| -- We have a potential problem here if finalization of global objects does |
| -- anything with signals or the timer server, since by that time those |
| -- servers have terminated. |
| |
| -- It is hard to see how that would occur |
| |
| -- However, a better solution might be to do all this finalization |
| -- using the global finalization chain. |
| |
| procedure Finalize_Global_Tasks is |
| Self_ID : constant Task_Id := STPO.Self; |
| |
| Ignore_1 : Boolean; |
| Ignore_2 : Boolean; |
| |
| function State |
| (Int : System.Interrupt_Management.Interrupt_ID) return Character; |
| pragma Import (C, State, "__gnat_get_interrupt_state"); |
| -- Get interrupt state for interrupt number Int. Defined in init.c |
| |
| Default : constant Character := 's'; |
| -- 's' Interrupt_State pragma set state to System (use "default" |
| -- system handler) |
| |
| begin |
| if Self_ID.Deferral_Level = 0 then |
| -- ??? |
| -- In principle, we should be able to predict whether abort is |
| -- already deferred here (and it should not be deferred yet but in |
| -- practice it seems Finalize_Global_Tasks is being called sometimes, |
| -- from RTS code for exceptions, with abort already deferred. |
| |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| |
| -- Never undefer again |
| end if; |
| |
| -- This code is only executed by the environment task |
| |
| pragma Assert (Self_ID = Environment_Task); |
| |
| -- Set Environment_Task'Callable to false to notify library-level tasks |
| -- that it is waiting for them. |
| |
| Self_ID.Callable := False; |
| |
| -- Exit level 2 master, for normal tasks in library-level packages |
| |
| Complete_Master; |
| |
| -- Force termination of "independent" library-level server tasks |
| |
| Lock_RTS; |
| Abort_Dependents (Self_ID); |
| Unlock_RTS; |
| |
| -- We need to explicitly wait for the task to be terminated here |
| -- because on true concurrent system, we may end this procedure before |
| -- the tasks are really terminated. |
| |
| Write_Lock (Self_ID); |
| |
| -- If the Abort_Task signal is set to system, it means that we may |
| -- not have been able to abort all independent tasks (in particular, |
| -- Server_Task may be blocked, waiting for a signal), in which case, do |
| -- not wait for Independent_Task_Count to go down to 0. We arbitrarily |
| -- limit the number of loop iterations; if an independent task does not |
| -- terminate, we do not want to hang here. In that case, the thread will |
| -- be terminated when the process exits. |
| |
| if State (System.Interrupt_Management.Abort_Task_Interrupt) /= Default |
| then |
| for J in 1 .. 10 loop |
| exit when Utilities.Independent_Task_Count = 0; |
| |
| -- We used to yield here, but this did not take into account low |
| -- priority tasks that would cause dead lock in some cases (true |
| -- FIFO scheduling). |
| |
| Timed_Sleep |
| (Self_ID, 0.01, System.OS_Primitives.Relative, |
| Self_ID.Common.State, Ignore_1, Ignore_2); |
| end loop; |
| end if; |
| |
| -- ??? On multi-processor environments, it seems that the above loop |
| -- isn't sufficient, so we need to add an additional delay. |
| |
| Timed_Sleep |
| (Self_ID, 0.01, System.OS_Primitives.Relative, |
| Self_ID.Common.State, Ignore_1, Ignore_2); |
| |
| Unlock (Self_ID); |
| |
| -- Complete the environment task |
| |
| Vulnerable_Complete_Task (Self_ID); |
| |
| -- Handle normal task termination by the environment task, but only |
| -- for the normal task termination. In the case of Abnormal and |
| -- Unhandled_Exception they must have been handled before, and the |
| -- task termination soft link must have been changed so the task |
| -- termination routine is not executed twice. |
| |
| SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); |
| |
| -- Finalize all library-level controlled objects |
| |
| if not SSL."=" (SSL.Finalize_Library_Objects, null) then |
| SSL.Finalize_Library_Objects.all; |
| end if; |
| |
| -- Reset the soft links to non-tasking |
| |
| SSL.Abort_Defer := SSL.Abort_Defer_NT'Access; |
| SSL.Abort_Undefer := SSL.Abort_Undefer_NT'Access; |
| SSL.Lock_Task := SSL.Task_Lock_NT'Access; |
| SSL.Unlock_Task := SSL.Task_Unlock_NT'Access; |
| SSL.Get_Jmpbuf_Address := SSL.Get_Jmpbuf_Address_NT'Access; |
| SSL.Set_Jmpbuf_Address := SSL.Set_Jmpbuf_Address_NT'Access; |
| SSL.Get_Sec_Stack := SSL.Get_Sec_Stack_NT'Access; |
| SSL.Set_Sec_Stack := SSL.Set_Sec_Stack_NT'Access; |
| SSL.Check_Abort_Status := SSL.Check_Abort_Status_NT'Access; |
| SSL.Get_Stack_Info := SSL.Get_Stack_Info_NT'Access; |
| |
| -- Don't bother trying to finalize Initialization.Global_Task_Lock |
| -- and System.Task_Primitives.RTS_Lock. |
| |
| end Finalize_Global_Tasks; |
| |
| --------------- |
| -- Free_Task -- |
| --------------- |
| |
| procedure Free_Task (T : Task_Id) is |
| Self_Id : constant Task_Id := Self; |
| |
| begin |
| Initialization.Task_Lock (Self_Id); |
| |
| if T.Common.State = Terminated then |
| |
| -- It is not safe to call Abort_Defer or Write_Lock at this stage |
| |
| Lock_RTS; |
| Initialization.Finalize_Attributes (T); |
| Initialization.Remove_From_All_Tasks_List (T); |
| Unlock_RTS; |
| |
| Initialization.Task_Unlock (Self_Id); |
| |
| System.Task_Primitives.Operations.Finalize_TCB (T); |
| |
| else |
| -- If the task is not terminated, then mark the task as to be freed |
| -- upon termination. |
| |
| T.Free_On_Termination := True; |
| Initialization.Task_Unlock (Self_Id); |
| end if; |
| end Free_Task; |
| |
| --------------------------- |
| -- Move_Activation_Chain -- |
| --------------------------- |
| |
| procedure Move_Activation_Chain |
| (From, To : Activation_Chain_Access; |
| New_Master : Master_ID) |
| is |
| Self_ID : constant Task_Id := STPO.Self; |
| C : Task_Id; |
| |
| begin |
| pragma Debug |
| (Debug.Trace (Self_ID, "Move_Activation_Chain", 'C')); |
| |
| -- Nothing to do if From is empty, and we can check that without |
| -- deferring aborts. |
| |
| C := From.all.T_ID; |
| |
| if C = null then |
| return; |
| end if; |
| |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| |
| -- Loop through the From chain, changing their Master_Of_Task fields, |
| -- and to find the end of the chain. |
| |
| loop |
| C.Master_Of_Task := New_Master; |
| exit when C.Common.Activation_Link = null; |
| C := C.Common.Activation_Link; |
| end loop; |
| |
| -- Hook From in at the start of To |
| |
| C.Common.Activation_Link := To.all.T_ID; |
| To.all.T_ID := From.all.T_ID; |
| |
| -- Set From to empty |
| |
| From.all.T_ID := null; |
| |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| end Move_Activation_Chain; |
| |
| ------------------ |
| -- Task_Wrapper -- |
| ------------------ |
| |
| -- The task wrapper is a procedure that is called first for each task body |
| -- and which in turn calls the compiler-generated task body procedure. |
| -- The wrapper's main job is to do initialization for the task. It also |
| -- has some locally declared objects that serve as per-task local data. |
| -- Task finalization is done by Complete_Task, which is called from an |
| -- at-end handler that the compiler generates. |
| |
| procedure Task_Wrapper (Self_ID : Task_Id) is |
| use System.Standard_Library; |
| use System.Stack_Usage; |
| |
| Bottom_Of_Stack : aliased Integer; |
| |
| Task_Alternate_Stack : |
| aliased SSE.Storage_Array (1 .. Alternate_Stack_Size); |
| -- The alternate signal stack for this task, if any |
| |
| Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0; |
| -- Whether to use above alternate signal stack for stack overflows |
| |
| SEH_Table : aliased SSE.Storage_Array (1 .. 8); |
| -- Structured Exception Registration table (2 words) |
| |
| procedure Install_SEH_Handler (Addr : System.Address); |
| pragma Import (C, Install_SEH_Handler, "__gnat_install_SEH_handler"); |
| -- Install the SEH (Structured Exception Handling) handler |
| |
| Cause : Cause_Of_Termination := Normal; |
| -- Indicates the reason why this task terminates. Normal corresponds to |
| -- a task terminating due to completing the last statement of its body, |
| -- or as a result of waiting on a terminate alternative. If the task |
| -- terminates because it is being aborted then Cause will be set |
| -- to Abnormal. If the task terminates because of an exception |
| -- raised by the execution of its task body, then Cause is set |
| -- to Unhandled_Exception. |
| |
| EO : Exception_Occurrence; |
| -- If the task terminates because of an exception raised by the |
| -- execution of its task body, then EO will contain the associated |
| -- exception occurrence. Otherwise, it will contain Null_Occurrence. |
| |
| TH : Termination_Handler := null; |
| -- Pointer to the protected procedure to be executed upon task |
| -- termination. |
| |
| procedure Search_Fall_Back_Handler (ID : Task_Id); |
| -- Procedure that searches recursively a fall-back handler through the |
| -- master relationship. If the handler is found, its pointer is stored |
| -- in TH. It stops when the handler is found or when the ID is null. |
| |
| ------------------------------ |
| -- Search_Fall_Back_Handler -- |
| ------------------------------ |
| |
| procedure Search_Fall_Back_Handler (ID : Task_Id) is |
| begin |
| -- A null Task_Id indicates that we have reached the root of the |
| -- task hierarchy and no handler has been found. |
| |
| if ID = null then |
| return; |
| |
| -- If there is a fall back handler, store its pointer for later |
| -- execution. |
| |
| elsif ID.Common.Fall_Back_Handler /= null then |
| TH := ID.Common.Fall_Back_Handler; |
| |
| -- Otherwise look for a fall back handler in the parent |
| |
| else |
| Search_Fall_Back_Handler (ID.Common.Parent); |
| end if; |
| end Search_Fall_Back_Handler; |
| |
| -- Start of processing for Task_Wrapper |
| |
| begin |
| pragma Assert (Self_ID.Deferral_Level = 1); |
| |
| Debug.Master_Hook |
| (Self_ID, Self_ID.Common.Parent, Self_ID.Master_Of_Task); |
| |
| if Use_Alternate_Stack then |
| Self_ID.Common.Task_Alternate_Stack := Task_Alternate_Stack'Address; |
| end if; |
| |
| -- Set the guard page at the bottom of the stack. The call to unprotect |
| -- the page is done in Terminate_Task |
| |
| Stack_Guard (Self_ID, True); |
| |
| -- Initialize low-level TCB components, that cannot be initialized by |
| -- the creator. Enter_Task sets Self_ID.LL.Thread. |
| |
| Enter_Task (Self_ID); |
| |
| -- Initialize dynamic stack usage |
| |
| if System.Stack_Usage.Is_Enabled then |
| declare |
| Guard_Page_Size : constant := 16 * 1024; |
| -- Part of the stack used as a guard page. This is an OS dependent |
| -- value, so we need to use the maximum. This value is only used |
| -- when the stack address is known, that is currently Windows. |
| |
| Small_Overflow_Guard : constant := 12 * 1024; |
| -- Note: this used to be 4K, but was changed to 12K, since |
| -- smaller values resulted in segmentation faults from dynamic |
| -- stack analysis. |
| |
| Big_Overflow_Guard : constant := 64 * 1024 + 8 * 1024; |
| -- These two values are experimental, and seem to work on most |
| -- platforms. They still need to be analyzed further. They also |
| -- need documentation, what are they and why does the logic differ |
| -- depending on whether the stack is large or small??? |
| |
| Pattern_Size : Natural := |
| Natural (Self_ID.Common. |
| Compiler_Data.Pri_Stack_Info.Size); |
| -- Size of the pattern |
| |
| Stack_Base : Address; |
| -- Address of the base of the stack |
| |
| begin |
| Stack_Base := Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base; |
| |
| if Stack_Base = Null_Address then |
| |
| -- On many platforms, we don't know the real stack base |
| -- address. Estimate it using an address in the frame. |
| |
| Stack_Base := Bottom_Of_Stack'Address; |
| |
| -- Adjustments for inner frames |
| |
| Pattern_Size := Pattern_Size - |
| (if Pattern_Size < Big_Overflow_Guard |
| then Small_Overflow_Guard |
| else Big_Overflow_Guard); |
| else |
| -- Reduce by the size of the final guard page |
| |
| Pattern_Size := Pattern_Size - Guard_Page_Size; |
| end if; |
| |
| STPO.Lock_RTS; |
| Initialize_Analyzer |
| (Self_ID.Common.Analyzer, |
| Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len), |
| Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size), |
| SSE.To_Integer (Stack_Base), |
| Pattern_Size); |
| STPO.Unlock_RTS; |
| Fill_Stack (Self_ID.Common.Analyzer); |
| end; |
| end if; |
| |
| -- We setup the SEH (Structured Exception Handling) handler if supported |
| -- on the target. |
| |
| Install_SEH_Handler (SEH_Table'Address); |
| |
| -- Initialize exception occurrence |
| |
| Save_Occurrence (EO, Ada.Exceptions.Null_Occurrence); |
| |
| -- We lock RTS_Lock to wait for activator to finish activating the rest |
| -- of the chain, so that everyone in the chain comes out in priority |
| -- order. |
| |
| -- This also protects the value of |
| -- Self_ID.Common.Activator.Common.Wait_Count. |
| |
| Lock_RTS; |
| Unlock_RTS; |
| |
| if not System.Restrictions.Abort_Allowed then |
| |
| -- If Abort is not allowed, reset the deferral level since it will |
| -- not get changed by the generated code. Keeping a default value |
| -- of one would prevent some operations (e.g. select or delay) to |
| -- proceed successfully. |
| |
| Self_ID.Deferral_Level := 0; |
| end if; |
| |
| if Global_Task_Debug_Event_Set then |
| Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID); |
| end if; |
| |
| declare |
| use Ada.Task_Initialization; |
| |
| Global_Initialization_Handler : Initialization_Handler; |
| pragma Atomic (Global_Initialization_Handler); |
| pragma Import (Ada, Global_Initialization_Handler, |
| "__gnat_global_initialization_handler"); |
| |
| begin |
| -- We are separating the following portion of the code in order to |
| -- place the exception handlers in a different block. In this way, |
| -- we do not call Set_Jmpbuf_Address (which needs Self) before we |
| -- set Self in Enter_Task |
| |
| -- Call the initialization hook if any |
| |
| if Global_Initialization_Handler /= null then |
| Global_Initialization_Handler.all; |
| end if; |
| |
| -- Call the task body procedure |
| |
| -- The task body is called with abort still deferred. That |
| -- eliminates a dangerous window, for which we had to patch-up in |
| -- Terminate_Task. |
| |
| -- During the expansion of the task body, we insert an RTS-call |
| -- to Abort_Undefer, at the first point where abort should be |
| -- allowed. |
| |
| Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg); |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| |
| exception |
| -- We can't call Terminate_Task in the exception handlers below, |
| -- since there may be (e.g. in the case of GCC exception handling) |
| -- clean ups associated with the exception handler that need to |
| -- access task specific data. |
| |
| -- Defer abort so that this task can't be aborted while exiting |
| |
| when Standard'Abort_Signal => |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| |
| -- Update the cause that motivated the task termination so that |
| -- the appropriate information is passed to the task termination |
| -- procedure. Task termination as a result of waiting on a |
| -- terminate alternative is a normal termination, although it is |
| -- implemented using the abort mechanisms. |
| |
| if Self_ID.Terminate_Alternative then |
| Cause := Normal; |
| |
| if Global_Task_Debug_Event_Set then |
| Debug.Signal_Debug_Event |
| (Debug.Debug_Event_Terminated, Self_ID); |
| end if; |
| else |
| Cause := Abnormal; |
| |
| if Global_Task_Debug_Event_Set then |
| Debug.Signal_Debug_Event |
| (Debug.Debug_Event_Abort_Terminated, Self_ID); |
| end if; |
| end if; |
| |
| when others => |
| -- ??? Using an E : others here causes CD2C11A to fail on Tru64 |
| |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| |
| -- Perform the task specific exception tracing duty. We handle |
| -- these outputs here and not in the common notification routine |
| -- because we need access to tasking related data and we don't |
| -- want to drag dependencies against tasking related units in the |
| -- the common notification units. Additionally, no trace is ever |
| -- triggered from the common routine for the Unhandled_Raise case |
| -- in tasks, since an exception never appears unhandled in this |
| -- context because of this handler. |
| |
| if Exception_Trace = Unhandled_Raise then |
| Trace_Unhandled_Exception_In_Task (Self_ID); |
| end if; |
| |
| -- Update the cause that motivated the task termination so that |
| -- the appropriate information is passed to the task termination |
| -- procedure, as well as the associated Exception_Occurrence. |
| |
| Cause := Unhandled_Exception; |
| |
| Save_Occurrence (EO, SSL.Get_Current_Excep.all.all); |
| |
| if Global_Task_Debug_Event_Set then |
| Debug.Signal_Debug_Event |
| (Debug.Debug_Event_Exception_Terminated, Self_ID); |
| end if; |
| end; |
| |
| -- Look for a task termination handler. This code is for all tasks but |
| -- the environment task. The task termination code for the environment |
| -- task is executed by SSL.Task_Termination_Handler. |
| |
| Write_Lock (Self_ID); |
| |
| if Self_ID.Common.Specific_Handler /= null then |
| TH := Self_ID.Common.Specific_Handler; |
| |
| -- Independent tasks should not call the Fall_Back_Handler (of the |
| -- environment task), because they are implementation artifacts that |
| -- should be invisible to Ada programs. |
| |
| elsif Self_ID.Master_Of_Task /= Independent_Task_Level then |
| |
| -- Look for a fall-back handler following the master relationship |
| -- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back |
| -- handler applies only to the dependent tasks of the task". Hence, |
| -- if the terminating tasks (Self_ID) had a fall-back handler, it |
| -- would not apply to itself, so we start the search with the parent. |
| |
| Search_Fall_Back_Handler (Self_ID.Common.Parent); |
| end if; |
| |
| Unlock (Self_ID); |
| |
| -- Execute the task termination handler if we found it |
| |
| if TH /= null then |
| begin |
| TH.all (Cause, Self_ID, EO); |
| exception |
| -- RM-C.7.3(16) requires all exceptions raised here to be ignored |
| |
| when others => |
| null; |
| end; |
| end if; |
| |
| if System.Stack_Usage.Is_Enabled then |
| Compute_Result (Self_ID.Common.Analyzer); |
| Report_Result (Self_ID.Common.Analyzer); |
| end if; |
| |
| Terminate_Task (Self_ID); |
| end Task_Wrapper; |
| |
| -------------------- |
| -- Terminate_Task -- |
| -------------------- |
| |
| -- Before we allow the thread to exit, we must clean up. This is a delicate |
| -- job. We must wake up the task's master, who may immediately try to |
| -- deallocate the ATCB from the current task WHILE IT IS STILL EXECUTING. |
| |
| -- To avoid this, the parent task must be blocked up to the latest |
| -- statement executed. The trouble is that we have another step that we |
| -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD. |
| -- We have to postpone that until the end because compiler-generated code |
| -- is likely to try to access that data at just about any point. |
| |
| -- We can't call Destroy_TSD while we are holding any other locks, because |
| -- it locks Global_Task_Lock, and our deadlock prevention rules require |
| -- that to be the outermost lock. Our first "solution" was to just lock |
| -- Global_Task_Lock in addition to the other locks, and force the parent to |
| -- also lock this lock between its wakeup and its freeing of the ATCB. See |
| -- Complete_Task for the parent-side of the code that has the matching |
| -- calls to Task_Lock and Task_Unlock. That was not really a solution, |
| -- since the operation Task_Unlock continued to access the ATCB after |
| -- unlocking, after which the parent was observed to race ahead, deallocate |
| -- the ATCB, and then reallocate it to another task. The call to |
| -- Undefer_Abort in Task_Unlock by the "terminated" task was overwriting |
| -- the data of the new task that reused the ATCB. To solve this problem, we |
| -- introduced the new operation Final_Task_Unlock. |
| |
| procedure Terminate_Task (Self_ID : Task_Id) is |
| Environment_Task : constant Task_Id := STPO.Environment_Task; |
| Master_Of_Task : Integer; |
| Deallocate : Boolean; |
| |
| begin |
| Debug.Task_Termination_Hook; |
| |
| -- Since GCC cannot allocate stack chunks efficiently without reordering |
| -- some of the allocations, we have to handle this unexpected situation |
| -- here. Normally we never have to call Vulnerable_Complete_Task here. |
| |
| if Self_ID.Common.Activator /= null then |
| Vulnerable_Complete_Task (Self_ID); |
| end if; |
| |
| Initialization.Task_Lock (Self_ID); |
| |
| Master_Of_Task := Self_ID.Master_Of_Task; |
| |
| -- Check if the current task is an independent task If so, decrement |
| -- the Independent_Task_Count value. |
| |
| if Master_Of_Task = Independent_Task_Level then |
| Write_Lock (Environment_Task); |
| Utilities.Independent_Task_Count := |
| Utilities.Independent_Task_Count - 1; |
| Unlock (Environment_Task); |
| end if; |
| |
| -- Unprotect the guard page if needed |
| |
| Stack_Guard (Self_ID, False); |
| |
| Utilities.Make_Passive (Self_ID, Task_Completed => True); |
| Deallocate := Self_ID.Free_On_Termination; |
| |
| pragma Assert (Check_Exit (Self_ID)); |
| |
| SSL.Destroy_TSD (Self_ID.Common.Compiler_Data); |
| Initialization.Final_Task_Unlock (Self_ID); |
| |
| -- WARNING: past this point, this thread must assume that the ATCB has |
| -- been deallocated, and can't access it anymore (which is why we have |
| -- saved the Free_On_Termination flag in a temporary variable). |
| |
| if Deallocate then |
| Free_Task (Self_ID); |
| end if; |
| |
| if Master_Of_Task > 0 then |
| STPO.Exit_Task; |
| end if; |
| end Terminate_Task; |
| |
| ---------------- |
| -- Terminated -- |
| ---------------- |
| |
| function Terminated (T : Task_Id) return Boolean is |
| Self_ID : constant Task_Id := STPO.Self; |
| Result : Boolean; |
| |
| begin |
| Initialization.Defer_Abort_Nestable (Self_ID); |
| Write_Lock (T); |
| Result := T.Common.State = Terminated; |
| Unlock (T); |
| Initialization.Undefer_Abort_Nestable (Self_ID); |
| |
| return Result; |
| end Terminated; |
| |
| ---------------------------------------- |
| -- Trace_Unhandled_Exception_In_Task -- |
| ---------------------------------------- |
| |
| procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id) is |
| procedure To_Stderr (S : String); |
| pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); |
| |
| use System.Soft_Links; |
| |
| function To_Address is new |
| Ada.Unchecked_Conversion |
| (Task_Id, System.Task_Primitives.Task_Address); |
| |
| Excep : constant Exception_Occurrence_Access := |
| SSL.Get_Current_Excep.all; |
| |
| begin |
| -- This procedure is called by the task outermost handler in |
| -- Task_Wrapper below, so only once the task stack has been fully |
| -- unwound. The common notification routine has been called at the |
| -- raise point already. |
| |
| -- Lock to prevent unsynchronized output |
| |
| Initialization.Task_Lock (Self_Id); |
| To_Stderr ("task "); |
| |
| if Self_Id.Common.Task_Image_Len /= 0 then |
| To_Stderr |
| (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len)); |
| To_Stderr ("_"); |
| end if; |
| |
| To_Stderr (System.Address_Image (To_Address (Self_Id))); |
| To_Stderr (" terminated by unhandled exception"); |
| To_Stderr ([ASCII.LF]); |
| To_Stderr (Exception_Information (Excep.all)); |
| Initialization.Task_Unlock (Self_Id); |
| end Trace_Unhandled_Exception_In_Task; |
| |
| ------------------------------------ |
| -- Vulnerable_Complete_Activation -- |
| ------------------------------------ |
| |
| -- As in several other places, the locks of the activator and activated |
| -- task are both locked here. This follows our deadlock prevention lock |
| -- ordering policy, since the activated task must be created after the |
| -- activator. |
| |
| procedure Vulnerable_Complete_Activation (Self_ID : Task_Id) is |
| Activator : constant Task_Id := Self_ID.Common.Activator; |
| |
| begin |
| pragma Debug (Debug.Trace (Self_ID, "V_Complete_Activation", 'C')); |
| |
| Write_Lock (Activator); |
| Write_Lock (Self_ID); |
| |
| pragma Assert (Self_ID.Common.Activator /= null); |
| |
| -- Remove dangling reference to Activator, since a task may outlive its |
| -- activator. |
| |
| Self_ID.Common.Activator := null; |
| |
| -- Wake up the activator, if it is waiting for a chain of tasks to |
| -- activate, and we are the last in the chain to complete activation. |
| |
| if Activator.Common.State = Activator_Sleep then |
| Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1; |
| |
| if Activator.Common.Wait_Count = 0 then |
| Wakeup (Activator, Activator_Sleep); |
| end if; |
| end if; |
| |
| -- The activator raises a Tasking_Error if any task it is activating |
| -- is completed before the activation is done. However, if the reason |
| -- for the task completion is an abort, we do not raise an exception. |
| -- See RM 9.2(5). |
| |
| if not Self_ID.Callable |
| and then Self_ID.Pending_ATC_Level /= Level_Completed_Task |
| then |
| Activator.Common.Activation_Failed := True; |
| end if; |
| |
| Unlock (Self_ID); |
| Unlock (Activator); |
| |
| -- After the activation, active priority should be the same as base |
| -- priority. We must unlock the Activator first, though, since it |
| -- should not wait if we have lower priority. |
| |
| if Get_Priority (Self_ID) /= Self_ID.Common.Base_Priority then |
| Write_Lock (Self_ID); |
| Set_Priority (Self_ID, Self_ID.Common.Base_Priority); |
| Unlock (Self_ID); |
| end if; |
| end Vulnerable_Complete_Activation; |
| |
| -------------------------------- |
| -- Vulnerable_Complete_Master -- |
| -------------------------------- |
| |
| procedure Vulnerable_Complete_Master (Self_ID : Task_Id) is |
| C : Task_Id; |
| P : Task_Id; |
| CM : constant Master_Level := Self_ID.Master_Within; |
| T : aliased Task_Id; |
| |
| To_Be_Freed : Task_Id; |
| -- This is a list of ATCBs to be freed, after we have released all RTS |
| -- locks. This is necessary because of the locking order rules, since |
| -- the storage manager uses Global_Task_Lock. |
| |
| pragma Warnings (Off); |
| function Check_Unactivated_Tasks return Boolean; |
| pragma Warnings (On); |
| -- Temporary error-checking code below. This is part of the checks |
| -- added in the new run time. Call it only inside a pragma Assert. |
| |
| ----------------------------- |
| -- Check_Unactivated_Tasks -- |
| ----------------------------- |
| |
| function Check_Unactivated_Tasks return Boolean is |
| begin |
| Lock_RTS; |
| Write_Lock (Self_ID); |
| |
| C := All_Tasks_List; |
| while C /= null loop |
| if C.Common.Activator = Self_ID and then C.Master_Of_Task = CM then |
| return False; |
| end if; |
| |
| if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then |
| Write_Lock (C); |
| |
| if C.Common.State = Unactivated then |
| return False; |
| end if; |
| |
| Unlock (C); |
| end if; |
| |
| C := C.Common.All_Tasks_Link; |
| end loop; |
| |
| Unlock (Self_ID); |
| Unlock_RTS; |
| |
| return True; |
| end Check_Unactivated_Tasks; |
| |
| -- Start of processing for Vulnerable_Complete_Master |
| |
| begin |
| pragma Debug |
| (Debug.Trace (Self_ID, "V_Complete_Master(" & CM'Img & ")", 'C')); |
| |
| pragma Assert (Self_ID.Common.Wait_Count = 0); |
| pragma Assert |
| (Self_ID.Deferral_Level > 0 |
| or else not System.Restrictions.Abort_Allowed); |
| |
| -- Count how many active dependent tasks this master currently has, and |
| -- record this in Wait_Count. |
| |
| -- This count should start at zero, since it is initialized to zero for |
| -- new tasks, and the task should not exit the sleep-loops that use this |
| -- count until the count reaches zero. |
| |
| -- While we're counting, if we run across any unactivated tasks that |
| -- belong to this master, we summarily terminate them as required by |
| -- RM-9.2(6). |
| |
| Lock_RTS; |
| Write_Lock (Self_ID); |
| |
| C := All_Tasks_List; |
| while C /= null loop |
| |
| -- Terminate unactivated (never-to-be activated) tasks |
| |
| if C.Common.Activator = Self_ID and then C.Master_Of_Task = CM then |
| |
| -- Usually, C.Common.Activator = Self_ID implies C.Master_Of_Task |
| -- = CM. The only case where C is pending activation by this |
| -- task, but the master of C is not CM is in Ada 2005, when C is |
| -- part of a return object of a build-in-place function. |
| |
| pragma Assert (C.Common.State = Unactivated); |
| |
| Write_Lock (C); |
| C.Common.Activator := null; |
| C.Common.State := Terminated; |
| C.Callable := False; |
| Utilities.Cancel_Queued_Entry_Calls (C); |
| Unlock (C); |
| end if; |
| |
| -- Count it if directly dependent on this master |
| |
| if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then |
| Write_Lock (C); |
| |
| if C.Awake_Count /= 0 then |
| Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; |
| end if; |
| |
| Unlock (C); |
| end if; |
| |
| C := C.Common.All_Tasks_Link; |
| end loop; |
| |
| Self_ID.Common.State := Master_Completion_Sleep; |
| Unlock (Self_ID); |
| Unlock_RTS; |
| |
| -- Wait until dependent tasks are all terminated or ready to terminate. |
| -- While waiting, the task may be awakened if the task's priority needs |
| -- changing, or this master is aborted. In the latter case, we abort the |
| -- dependents, and resume waiting until Wait_Count goes to zero. |
| |
| Write_Lock (Self_ID); |
| |
| loop |
| exit when Self_ID.Common.Wait_Count = 0; |
| |
| -- Here is a difference as compared to Complete_Master |
| |
| if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level |
| and then not Self_ID.Dependents_Aborted |
| then |
| Unlock (Self_ID); |
| Lock_RTS; |
| Abort_Dependents (Self_ID); |
| Unlock_RTS; |
| Write_Lock (Self_ID); |
| else |
| pragma Debug |
| (Debug.Trace (Self_ID, "master_completion_sleep", 'C')); |
| Sleep (Self_ID, Master_Completion_Sleep); |
| end if; |
| end loop; |
| |
| Self_ID.Common.State := Runnable; |
| Unlock (Self_ID); |
| |
| -- Dependents are all terminated or on terminate alternatives. Now, |
| -- force those on terminate alternatives to terminate, by aborting them. |
| |
| pragma Assert (Check_Unactivated_Tasks); |
| |
| if Self_ID.Alive_Count > 1 then |
| -- ??? |
| -- Consider finding a way to skip the following extra steps if there |
| -- are no dependents with terminate alternatives. This could be done |
| -- by adding another count to the ATCB, similar to Awake_Count, but |
| -- keeping track of tasks that are on terminate alternatives. |
| |
| pragma Assert (Self_ID.Common.Wait_Count = 0); |
| |
| -- Force any remaining dependents to terminate by aborting them |
| |
| Lock_RTS; |
| Abort_Dependents (Self_ID); |
| |
| -- Above, when we "abort" the dependents we are simply using this |
| -- operation for convenience. We are not required to support the full |
| -- abort-statement semantics; in particular, we are not required to |
| -- immediately cancel any queued or in-service entry calls. That is |
| -- good, because if we tried to cancel a call we would need to lock |
| -- the caller, in order to wake the caller up. Our anti-deadlock |
| -- rules prevent us from doing that without releasing the locks on C |
| -- and Self_ID. Releasing and retaking those locks would be wasteful |
| -- at best, and should not be considered further without more |
| -- detailed analysis of potential concurrent accesses to the ATCBs |
| -- of C and Self_ID. |
| |
| -- Count how many "alive" dependent tasks this master currently has, |
| -- and record this in Wait_Count. This count should start at zero, |
| -- since it is initialized to zero for new tasks, and the task should |
| -- not exit the sleep-loops that use this count until the count |
| -- reaches zero. |
| |
| pragma Assert (Self_ID.Common.Wait_Count = 0); |
| |
| Write_Lock (Self_ID); |
| |
| C := All_Tasks_List; |
| while C /= null loop |
| if C.Common.Parent = Self_ID and then C.Master_Of_Task = CM then |
| Write_Lock (C); |
| |
| pragma Assert (C.Awake_Count = 0); |
| |
| if C.Alive_Count > 0 then |
| pragma Assert (C.Terminate_Alternative); |
| Self_ID.Common.Wait_Count := Self_ID.Common.Wait_Count + 1; |
| end if; |
| |
| Unlock (C); |
| end if; |
| |
| C := C.Common.All_Tasks_Link; |
| end loop; |
| |
| Self_ID.Common.State := Master_Phase_2_Sleep; |
| Unlock (Self_ID); |
| Unlock_RTS; |
| |
| -- Wait for all counted tasks to finish terminating themselves |
| |
| Write_Lock (Self_ID); |
| |
| loop |
| exit when Self_ID.Common.Wait_Count = 0; |
| Sleep (Self_ID, Master_Phase_2_Sleep); |
| end loop; |
| |
| Self_ID.Common.State := Runnable; |
| Unlock (Self_ID); |
| end if; |
| |
| -- We don't wake up for abort here. We are already terminating just as |
| -- fast as we can, so there is no point. |
| |
| -- Remove terminated tasks from the list of Self_ID's dependents, but |
| -- don't free their ATCBs yet, because of lock order restrictions, which |
| -- don't allow us to call "free" or "malloc" while holding any other |
| -- locks. Instead, we put those ATCBs to be freed onto a temporary list, |
| -- called To_Be_Freed. |
| |
| Lock_RTS; |
| C := All_Tasks_List; |
| P := null; |
| while C /= null loop |
| |
| -- If Free_On_Termination is set, do nothing here, and let the |
| -- task free itself if not already done, otherwise we risk a race |
| -- condition where Vulnerable_Free_Task is called in the loop below, |
| -- while the task calls Free_Task itself, in Terminate_Task. |
| |
| if C.Common.Parent = Self_ID |
| and then C.Master_Of_Task >= CM |
| and then not C.Free_On_Termination |
| then |
| if P /= null then |
| P.Common.All_Tasks_Link := C.Common.All_Tasks_Link; |
| else |
| All_Tasks_List := C.Common.All_Tasks_Link; |
| end if; |
| |
| T := C.Common.All_Tasks_Link; |
| C.Common.All_Tasks_Link := To_Be_Freed; |
| To_Be_Freed := C; |
| C := T; |
| |
| else |
| P := C; |
| C := C.Common.All_Tasks_Link; |
| end if; |
| end loop; |
| |
| Unlock_RTS; |
| |
| -- Free all the ATCBs on the list To_Be_Freed |
| |
| -- The ATCBs in the list are no longer in All_Tasks_List, and after |
| -- any interrupt entries are detached from them they should no longer |
| -- be referenced. |
| |
| -- Global_Task_Lock (Task_Lock/Unlock) is locked in the loop below to |
| -- avoid a race between a terminating task and its parent. The parent |
| -- might try to deallocate the ACTB out from underneath the exiting |
| -- task. Note that Free will also lock Global_Task_Lock, but that is |
| -- OK, since this is the *one* lock for which we have a mechanism to |
| -- support nested locking. See Task_Wrapper and its finalizer for more |
| -- explanation. |
| |
| -- ??? |
| -- The check "T.Common.Parent /= null ..." below is to prevent dangling |
| -- references to terminated library-level tasks, which could otherwise |
| -- occur during finalization of library-level objects. A better solution |
| -- might be to hook task objects into the finalization chain and |
| -- deallocate the ATCB when the task object is deallocated. However, |
| -- this change is not likely to gain anything significant, since all |
| -- this storage should be recovered en-masse when the process exits. |
| |
| while To_Be_Freed /= null loop |
| T := To_Be_Freed; |
| To_Be_Freed := T.Common.All_Tasks_Link; |
| |
| -- ??? On SGI there is currently no Interrupt_Manager, that's why we |
| -- need to check if the Interrupt_Manager_ID is null. |
| |
| if T.Interrupt_Entry and then Interrupt_Manager_ID /= null then |
| declare |
| Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1; |
| -- Corresponds to the entry index of System.Interrupts. |
| -- Interrupt_Manager.Detach_Interrupt_Entries. Be sure |
| -- to update this value when changing Interrupt_Manager specs. |
| |
| type Param_Type is access all Task_Id; |
| |
| Param : aliased Param_Type := T'Access; |
| |
| begin |
| System.Tasking.Rendezvous.Call_Simple |
| (Interrupt_Manager_ID, Detach_Interrupt_Entries_Index, |
| Param'Address); |
| end; |
| end if; |
| |
| if (T.Common.Parent /= null |
| and then T.Common.Parent.Common.Parent /= null) |
| or else T.Master_Of_Task > Library_Task_Level |
| then |
| Initialization.Task_Lock (Self_ID); |
| |
| -- If Sec_Stack_Ptr is not null, it means that Destroy_TSD |
| -- has not been called yet (case of an unactivated task). |
| |
| if T.Common.Compiler_Data.Sec_Stack_Ptr /= null then |
| SSL.Destroy_TSD (T.Common.Compiler_Data); |
| end if; |
| |
| Vulnerable_Free_Task (T); |
| Initialization.Task_Unlock (Self_ID); |
| end if; |
| end loop; |
| |
| -- It might seem nice to let the terminated task deallocate its own |
| -- ATCB. That would not cover the case of unactivated tasks. It also |
| -- would force us to keep the underlying thread around past termination, |
| -- since references to the ATCB are possible past termination. |
| |
| -- Currently, we get rid of the thread as soon as the task terminates, |
| -- and let the parent recover the ATCB later. |
| |
| -- Some day, if we want to recover the ATCB earlier, at task |
| -- termination, we could consider using "fat task IDs", that include the |
| -- serial number with the ATCB pointer, to catch references to tasks |
| -- that no longer have ATCBs. It is not clear how much this would gain, |
| -- since the user-level task object would still be occupying storage. |
| |
| -- Make next master level up active. We don't need to lock the ATCB, |
| -- since the value is only updated by each task for itself. |
| |
| Self_ID.Master_Within := CM - 1; |
| |
| Debug.Master_Completed_Hook (Self_ID, CM); |
| end Vulnerable_Complete_Master; |
| |
| ------------------------------ |
| -- Vulnerable_Complete_Task -- |
| ------------------------------ |
| |
| -- Complete the calling task |
| |
| -- This procedure must be called with abort deferred. It should only be |
| -- called by Complete_Task and Finalize_Global_Tasks (for the environment |
| -- task). |
| |
| -- The effect is similar to that of Complete_Master. Differences include |
| -- the closing of entries here, and computation of the number of active |
| -- dependent tasks in Complete_Master. |
| |
| -- We don't lock Self_ID before the call to Vulnerable_Complete_Activation, |
| -- because that does its own locking, and because we do not need the lock |
| -- to test Self_ID.Common.Activator. That value should only be read and |
| -- modified by Self. |
| |
| procedure Vulnerable_Complete_Task (Self_ID : Task_Id) is |
| begin |
| pragma Assert |
| (Self_ID.Deferral_Level > 0 |
| or else not System.Restrictions.Abort_Allowed); |
| pragma Assert (Self_ID = Self); |
| pragma Assert |
| (Self_ID.Master_Within in |
| Self_ID.Master_Of_Task .. Self_ID.Master_Of_Task + 3); |
| pragma Assert (Self_ID.Common.Wait_Count = 0); |
| pragma Assert (Self_ID.Open_Accepts = null); |
| pragma Assert (Self_ID.ATC_Nesting_Level = Level_No_ATC_Occurring); |
| |
| pragma Debug (Debug.Trace (Self_ID, "V_Complete_Task", 'C')); |
| |
| Write_Lock (Self_ID); |
| Self_ID.Callable := False; |
| |
| -- In theory, Self should have no pending entry calls left on its |
| -- call-stack. Each async. select statement should clean its own call, |
| -- and blocking entry calls should defer abort until the calls are |
| -- cancelled, then clean up. |
| |
| Utilities.Cancel_Queued_Entry_Calls (Self_ID); |
| Unlock (Self_ID); |
| |
| if Self_ID.Common.Activator /= null then |
| Vulnerable_Complete_Activation (Self_ID); |
| end if; |
| |
| -- If Self_ID.Master_Within = Self_ID.Master_Of_Task + 2 we may have |
| -- dependent tasks for which we need to wait. Otherwise we just exit. |
| |
| if Self_ID.Master_Within = Self_ID.Master_Of_Task + 2 then |
| Vulnerable_Complete_Master (Self_ID); |
| end if; |
| end Vulnerable_Complete_Task; |
| |
| -------------------------- |
| -- Vulnerable_Free_Task -- |
| -------------------------- |
| |
| -- Recover all runtime system storage associated with the task T. This |
| -- should only be called after T has terminated and will no longer be |
| -- referenced. |
| |
| -- For tasks created by an allocator that fails, due to an exception, it |
| -- is called from Expunge_Unactivated_Tasks. |
| |
| -- For tasks created by elaboration of task object declarations it is |
| -- called from the finalization code of the Task_Wrapper procedure. |
| |
| procedure Vulnerable_Free_Task (T : Task_Id) is |
| begin |
| pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T)); |
| |
| Write_Lock (T); |
| Initialization.Finalize_Attributes (T); |
| Unlock (T); |
| |
| System.Task_Primitives.Operations.Finalize_TCB (T); |
| end Vulnerable_Free_Task; |
| |
| -- Package elaboration code |
| |
| begin |
| -- Establish the Adafinal softlink |
| |
| -- This is not done inside the central RTS initialization routine |
| -- to avoid with'ing this package from System.Tasking.Initialization. |
| |
| SSL.Adafinal := Finalize_Global_Tasks'Access; |
| |
| -- Establish soft links for subprograms that manipulate master_id's. |
| -- This cannot be done when the RTS is initialized, because of various |
| -- elaboration constraints. |
| |
| SSL.Current_Master := Stages.Current_Master'Access; |
| SSL.Enter_Master := Stages.Enter_Master'Access; |
| SSL.Complete_Master := Stages.Complete_Master'Access; |
| end System.Tasking.Stages; |
