-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- 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. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
+-- 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. --
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;
+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.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 presense of tasking, they must be replaced with pointers to
+-- 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.
procedure Free is new
Ada.Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id);
+ procedure Free_Entry_Names (T : Task_Id);
+ -- Deallocate all string names associated with task entries
+
procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id);
-- This procedure outputs the task specific message for exception
-- tracing purposes.
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
- -- Finalizate_Global_Tasks (for the environment task).
+ -- 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
-- For tasks created by an allocator that fails, due to an exception, it is
-- called from Expunge_Unactivated_Tasks.
--
- -- It is also called from Ada.Unchecked_Deallocation, for objects that are
- -- or contain tasks.
- --
-- Different code is used at master completion, in Terminate_Dependents,
-- due to a need for tighter synchronization with the master.
Write_Lock (P);
Write_Lock (C);
- if C.Common.Base_Priority < Get_Priority (Self_ID) then
- Activate_Prio := Get_Priority (Self_ID);
- else
- Activate_Prio := C.Common.Base_Priority;
- end if;
+ 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,
-- racing ahead.
if Success then
- C.Common.State := Runnable;
+ C.Common.State := Activating;
C.Awake_Count := 1;
C.Alive_Count := 1;
P.Awake_Count := P.Awake_Count + 1;
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);
Initialization.Undefer_Abort_Nestable (Self_ID);
- -- ???
- -- Why do we need to allow for nested deferral here?
+ -- ??? Why do we need to allow for nested deferral here?
if Runtime_Traces then
Send_Trace_Info (T_Activate);
-- called to create a new task.
procedure Create_Task
- (Priority : Integer;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- 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)
+ (Priority : Integer;
+ Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ Relative_Deadline : Ada.Real_Time.Time_Span;
+ 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;
+ Build_Entry_Names : Boolean)
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;
+
+ 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
raise Program_Error with "potentially blocking operation";
end if;
- pragma Debug
- (Debug.Trace (Self_ID, "Create_Task", 'C'));
+ 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));
+
+ 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))
+ then
+ raise Tasking_Error with "CPU not in range";
- if Priority = Unspecified_Priority then
- Base_Priority := Self_ID.Common.Base_Priority;
+ -- Normal CPU affinity
else
- Base_Priority := System.Any_Priority (Priority);
+ 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
end if;
Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
- Base_Priority, Task_Info, Size, T, Success);
+ Base_Priority, Base_CPU, Task_Info, Size, T, Success);
if not Success then
Free (T);
-- confused when waiting for these tasks to terminate.
T.Master_of_Task := Library_Task_Level;
+
else
T.Master_of_Task := Master;
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.
+
+ if Build_Entry_Names then
+ T.Entry_Names :=
+ new Entry_Names_Array (1 .. Entry_Index (Num_Entries));
+ end if;
+
-- Create TSD as early as possible in the creation of a task, since it
-- may be used by the operation of Ada code within the task.
Ignore : Boolean;
pragma Unreferenced (Ignore);
+ 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
-- ???
Unlock_RTS;
end if;
- -- We need to explicitely wait for the task to be terminated here
+ -- 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);
- loop
- exit when Utilities.Independent_Task_Count = 0;
+ -- 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.
+
+ if State
+ (System.Interrupt_Management.Abort_Task_Interrupt) /= Default
+ then
+ 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).
+ -- 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, Ignore);
- end loop;
+ Timed_Sleep
+ (Self_ID, 0.01, System.OS_Primitives.Relative,
+ Self_ID.Common.State, Ignore, Ignore);
+ 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.
end Finalize_Global_Tasks;
+ ----------------------
+ -- Free_Entry_Names --
+ ----------------------
+
+ procedure Free_Entry_Names (T : Task_Id) is
+ Names : Entry_Names_Array_Access := T.Entry_Names;
+
+ procedure Free_Entry_Names_Array_Access is new
+ Ada.Unchecked_Deallocation
+ (Entry_Names_Array, Entry_Names_Array_Access);
+
+ begin
+ if Names = null then
+ return;
+ end if;
+
+ Free_Entry_Names_Array (Names.all);
+ Free_Entry_Names_Array_Access (Names);
+ end Free_Entry_Names;
+
---------------
-- Free_Task --
---------------
Initialization.Task_Lock (Self_Id);
Lock_RTS;
+ Initialization.Finalize_Attributes_Link.all (T);
Initialization.Remove_From_All_Tasks_List (T);
Unlock_RTS;
Initialization.Task_Unlock (Self_Id);
+ Free_Entry_Names (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
-- If the task is not terminated, then we simply ignore the call. This
Initialization.Undefer_Abort (Self_ID);
end Move_Activation_Chain;
+ -- Compiler interface only. Do not call from within the RTS
+
+ --------------------
+ -- Set_Entry_Name --
+ --------------------
+
+ procedure Set_Entry_Name
+ (T : Task_Id;
+ Pos : Task_Entry_Index;
+ Val : String_Access)
+ is
+ begin
+ pragma Assert (T.Entry_Names /= null);
+
+ T.Entry_Names (Entry_Index (Pos)) := Val;
+ end Set_Entry_Name;
+
------------------
-- Task_Wrapper --
------------------
- -- The task wrapper is a procedure that is called first for each task
- -- 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 server as per-task local
- -- data. Task finalization is done by Complete_Task, which is called from
- -- an at-end handler that the compiler generates.
+ -- 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 type SSE.Storage_Offset;
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
+
Secondary_Stack_Size :
constant SSE.Storage_Offset :=
Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
-- Why are warnings being turned off here???
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
-- Size of the overflow guard, used by dynamic stack usage analysis
pragma Warnings (On);
- -- 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 ???
SEH_Table : aliased SSE.Storage_Array (1 .. 8);
-- Structured Exception Registration table (2 words)
-- Assume a size of the stack taken at this stage
- if Size < Small_Stack_Limit then
- Overflow_Guard := Small_Overflow_Guard;
- else
- Overflow_Guard := Big_Overflow_Guard;
- end if;
-
- Size := Size - Overflow_Guard;
-
if not Parameters.Sec_Stack_Dynamic then
Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
Secondary_Stack'Address;
Size := Size - Natural (Secondary_Stack_Size);
end if;
- if System.Stack_Usage.Is_Enabled then
- STPO.Lock_RTS;
- Initialize_Analyzer (Self_ID.Common.Analyzer,
- Self_ID.Common.Task_Image
- (1 .. Self_ID.Common.Task_Image_Len),
- Size,
- Overflow_Guard,
- SSE.To_Integer (Bottom_Of_Stack'Address));
- STPO.Unlock_RTS;
- Fill_Stack (Self_ID.Common.Analyzer);
+ 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
Stack_Guard (Self_ID, True);
-- Initialize low-level TCB components, that cannot be initialized by
- -- the creator. Enter_Task sets Self_ID.Known_Tasks_Index and also
- -- 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);
+ end if;
+
-- We setup the SEH (Structured Exception Handling) handler if supported
-- on the target.
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;
+
begin
-- We are separating the following portion of the code in order to
-- place the exception handlers in a different block. In this way,
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
-- 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
-- Terminate_Task --
--------------------
- -- Before we allow the thread to exit, we must clean up. This is a a
+ -- 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.
use System.Standard_Library;
function To_Address is new
- Ada.Unchecked_Conversion (Task_Id, System.Address);
+ Ada.Unchecked_Conversion
+ (Task_Id, System.Task_Primitives.Task_Address);
function Tailored_Exception_Information
(E : Exception_Occurrence) return String;
-- 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 (" terminated by unhandled exception");
To_Stderr ((1 => ASCII.LF));
To_Stderr (Tailored_Exception_Information (Excep.all));
+ Initialization.Task_Unlock (Self_Id);
end Trace_Unhandled_Exception_In_Task;
------------------------------------
--------------------------------
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;
+ 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.
+ -- 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;
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
+ -- ??? 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 Interrupt_Manager_ID /= null then
+ 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.
Unlock_RTS;
end if;
+ Free_Entry_Names (T);
System.Task_Primitives.Operations.Finalize_TCB (T);
end Vulnerable_Free_Task;
-- Package elaboration code
begin
- -- Establish the Adafinal softlink
+ -- Establish the Adafinal oftlink
-- This is not done inside the central RTS initialization routine
-- to avoid with-ing this package from System.Tasking.Initialization.
OSDN Git Service
