-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
-- 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_Global_List, Task_Termination, Handler.
+-- 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);
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;
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.
if CPU /= Unspecified_CPU
and then (CPU < Integer (System.Multiprocessors.CPU_Range'First)
- or else CPU > Integer (System.Multiprocessors.CPU_Range'Last)
- or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
+ or else
+ CPU > Integer (System.Multiprocessors.CPU_Range'Last)
+ or else
+ CPU > Integer (System.Multiprocessors.Number_Of_CPUs))
then
raise Tasking_Error with "CPU not in range";
-- Normal CPU affinity
+
else
Base_CPU :=
(if CPU = Unspecified_CPU
end if;
Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
- Base_Priority, Base_CPU, Task_Info, Size, T, Success);
+ Base_Priority, Base_CPU, Domain, Task_Info, Size, T, Success);
if not Success then
Free (T);
T.Common.Task_Image_Len := Len;
end if;
+ -- The task inherits the dispatching domain of the parent only if no
+ -- specific domain has been defined in the spec of the task (using the
+ -- dispatching domain pragma or aspect).
+
+ if T.Common.Domain /= null then
+ null;
+ elsif T.Common.Activator /= null then
+ T.Common.Domain := T.Common.Activator.Common.Domain;
+ else
+ T.Common.Domain := System.Tasking.System_Domain;
+ end if;
+
Unlock (Self_ID);
Unlock_RTS;
- -- Note: we should not call 'new' while holding locks since new
- -- may use locks (e.g. RTS_Lock under Windows) itself and cause a
- -- deadlock.
+ -- 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;
+
+ -- Note: we should not call 'new' while holding locks since new may use
+ -- locks (e.g. RTS_Lock under Windows) itself and cause a deadlock.
if Build_Entry_Names then
T.Entry_Names :=
SSL.Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence);
- -- Finalize the global list for controlled objects if needed
+ -- Finalize all library-level controlled objects
- SSL.Finalize_Global_List.all;
+ if not SSL."=" (SSL.Finalize_Library_Objects, null) then
+ SSL.Finalize_Library_Objects.all;
+ end if;
-- Reset the soft links to non-tasking
Free_Entry_Names (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
- -- If the task is not terminated, then we simply ignore the call. This
- -- happens when a user program attempts an unchecked deallocation on
- -- a non-terminated task.
-
else
- null;
+ -- If the task is not terminated, then mark the task as to be freed
+ -- upon termination.
+
+ T.Free_On_Termination := True;
end if;
end Free_Task;
Initialization.Defer_Abort (Self_ID);
- -- Loop through the From chain, changing their Master_of_Task
- -- fields, and to find the end of the chain.
+ -- 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;
Secondary_Stack_Size :
constant SSE.Storage_Offset :=
Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
- SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100;
+ SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100;
Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size);
-
- pragma Warnings (Off);
- -- Why are warnings being turned off here???
+ -- Actual area allocated for secondary stack
Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
-- Address of secondary stack. In the fixed secondary stack case, this
-- value is not modified, causing a warning, hence the bracketing with
-- Warnings (Off/On). But why is so much *more* bracketed???
- 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 := 16 * 1024;
- Small_Stack_Limit : constant := 64 * 1024;
- -- ??? These three values are experimental, and seems to work on most
- -- platforms. They still need to be analyzed further. They also need
- -- documentation, what are they???
-
- Size : Natural :=
- Natural (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size);
-
- Overflow_Guard : Natural;
- -- Size of the overflow guard, used by dynamic stack usage analysis
-
- pragma Warnings (On);
-
SEH_Table : aliased SSE.Storage_Array (1 .. 8);
-- Structured Exception Registration table (2 words)
-- 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.
+ -- 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
end if;
end Search_Fall_Back_Handler;
+ -- Start of processing for Task_Wrapper
+
begin
pragma Assert (Self_ID.Deferral_Level = 1);
Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
Secondary_Stack'Address;
SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
- Size := Size - Natural (Secondary_Stack_Size);
end if;
if Use_Alternate_Stack then
Stack_Guard (Self_ID, True);
-- Initialize low-level TCB components, that cannot be initialized by
- -- the creator. Enter_Task sets Self_ID.LL.Thread
+ -- the creator. Enter_Task sets Self_ID.LL.Thread.
Enter_Task (Self_ID);
-- Initialize dynamic stack usage
if System.Stack_Usage.Is_Enabled then
- Overflow_Guard :=
- (if Size < Small_Stack_Limit
- then Small_Overflow_Guard
- else Big_Overflow_Guard);
-
- 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),
- Size - Overflow_Guard,
- SSE.To_Integer (Bottom_Of_Stack'Address),
- SSE.To_Integer
- (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit));
- STPO.Unlock_RTS;
- Fill_Stack (Self_ID.Common.Analyzer);
+ 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;
+ Small_Stack_Limit : constant := 64 * 1024;
+ -- ??? These three 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;
+
+ -- Also reduce the size of the stack to take into account the
+ -- secondary stack array declared in this frame. This is for
+ -- sure very conservative.
+
+ if not Parameters.Sec_Stack_Dynamic then
+ Pattern_Size :=
+ Pattern_Size - Natural (Secondary_Stack_Size);
+ end if;
+
+ -- Adjustments for inner frames
+
+ Pattern_Size := Pattern_Size -
+ (if Pattern_Size < Small_Stack_Limit
+ 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
end if;
if Global_Task_Debug_Event_Set then
- Debug.Signal_Debug_Event
- (Debug.Debug_Event_Run, Self_ID);
+ Debug.Signal_Debug_Event (Debug.Debug_Event_Run, Self_ID);
end if;
begin
(Debug.Debug_Event_Abort_Terminated, Self_ID);
end if;
end if;
+
when others =>
-- ??? Using an E : others here causes CD2C11A to fail on Tru64
-- Execute the task termination handler if we found it
if TH /= null then
- TH.all (Cause, Self_ID, EO);
+ begin
+ TH.all (Cause, Self_ID, EO);
+
+ exception
+
+ -- RM-C.7.3 requires all exceptions raised here to be ignored
+
+ when others =>
+ null;
+ end;
end if;
if System.Stack_Usage.Is_Enabled then
-- 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 out from under the current task WHILE IT IS STILL
- -- EXECUTING.
+ -- 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
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. We should normally never have to call Vulnerable_Complete_Task
- -- here.
+ -- here. Normally we never have to call Vulnerable_Complete_Task here.
if Self_ID.Common.Activator /= null then
Vulnerable_Complete_Task (Self_ID);
if Single_Lock then
Utilities.Independent_Task_Count :=
Utilities.Independent_Task_Count - 1;
+
else
Write_Lock (Environment_Task);
Utilities.Independent_Task_Count :=
Stack_Guard (Self_ID, False);
Utilities.Make_Passive (Self_ID, Task_Completed => True);
+ Deallocate := Self_ID.Free_On_Termination;
if Single_Lock then
Unlock_RTS;
Initialization.Final_Task_Unlock (Self_ID);
-- WARNING: past this point, this thread must assume that the ATCB has
- -- been deallocated. It should not be accessed again.
+ -- 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;
pragma Assert (Self_ID.Common.Activator /= null);
- -- Remove dangling reference to Activator, since a task may
- -- outlive its activator.
+ -- Remove dangling reference to Activator, since a task may outlive its
+ -- activator.
Self_ID.Common.Activator := null;
if C.Common.Activator = Self_ID and then C.Master_of_Task = CM then
- pragma Assert (C.Common.State = Unactivated);
-- 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;
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.
+ -- Interrupt_Manager.Detach_Interrupt_Entries. Be sure
+ -- to update this value when changing Interrupt_Manager specs.
type Param_Type is access all Task_Id;
-- Package elaboration code
begin
- -- Establish the Adafinal oftlink
+ -- Establish the Adafinal softlink
-- This is not done inside the central RTS initialization routine
- -- to avoid with-ing this package from System.Tasking.Initialization.
+ -- to avoid with'ing this package from System.Tasking.Initialization.
SSL.Adafinal := Finalize_Global_Tasks'Access;
OSDN Git Service
