+2011-08-04 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb, sem.ads: Code cleanup.
+
+2011-08-04 Tristan Gingold <gingold@adacore.com>
+
+ * s-tassta.adb (Task_Wrapper): Rewrite the dynamic stack usage part.
+ * s-stausa.adb, s-stausa.ads: Major rewrite. Now provides accurate
+ results if possible.
+ * s-stusta.adb (Print): Adjust after changes in s-stausa.
+ * gnat_ugn.texi: Update dynamic stack usage section.
+
+2011-08-04 Steve Baird <baird@adacore.com>
+
+ * bindgen.adb (Gen_CodePeer_Wrapper): new procedure.
+ Generate (if CodePeer_Mode is set) a "wrapper" subprogram which
+ contains only a call to the user-defined main subprogram.
+ (Gen_Main_Ada) - If CodePeer_Mode is set, then
+ call the "wrapper" subprogram instead of directly
+ calling the user-defined main subprogram.
+
+2011-08-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch5.adb (Expand_N_Case_Statement): Check the statements of all
+ alternatives of a case statement for controlled objects. Rename local
+ variable A to Dead_Alt.
+ (Expand_N_If_Statement): Check the then and else statements of an if
+ statement for controlled objects. Check the then statements of all
+ elsif parts of an if statement for controlled objects.
+ (Expand_N_Loop_Statement): Check the statements of a loop for controlled
+ objects.
+ * exp_ch7.adb (Process_Transient_Objects): Rewrite the condition which
+ detects a loop associated with the expansion of an array object.
+ Augment the processing of the loop statements to account for a possible
+ wrap done by Process_Statements_For_Controlled_Objects.
+ * exp_ch9.adb (Expand_N_Asynchronous_Select): Check the triggering
+ statements and abortable part of an asynchronous select for controlled
+ objects.
+ (Expand_N_Conditional_Entry_Call): Check the else statements of a
+ conditional entry call for controlled objects.
+ (Expand_N_Selective_Accept): Check the alternatives of a selective
+ accept for controlled objects.
+ (Expand_N_Timed_Entry_Call): Check the entry call and delay
+ alternatives of a timed entry call for controlled objects.
+ * exp_ch11.adb (Expand_Exception_Handlers): Check the statements of an
+ exception handler for controlled objects.
+ * exp_util.adb (Requires_Cleanup_Actions (List_Id, Boolean, Boolean)):
+ Add formal parameter Nested_Constructs along with its associated
+ comment.
+ (Requires_Cleanup_Actions (Node_Id)): Update all calls to
+ Requires_Cleanup_Actions.
+ (Process_Statements_For_Controlled_Objects): New routine.
+ * exp_util.ads (Process_Statements_For_Controlled_Objects): New
+ routine. Inspect a node which contains a non-handled sequence of
+ statements for controlled objects. If such an object is found, the
+ statements are wrapped in a block.
+
2011-08-04 Bob Duff <duff@adacore.com>
* sem_type.adb (Covers): If T2 is a subtype of a class-wide type, we
-------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
Lib_Final_Built : Boolean := False;
-- Flag indicating whether the finalize_library rountine has been built
+ CodePeer_Wrapper_Name : constant String := "call_main_subprogram";
+ -- For CodePeer, introduce a wrapper subprogram which calls the
+ -- user-defined main subprogram.
+
----------------------------------
-- Interface_State Pragma Table --
----------------------------------
procedure Gen_Finalize_Library_Defs_C;
-- Generate a sequence of defininitions for package finalizers (C case)
+ procedure Gen_CodePeer_Wrapper;
+ -- For CodePeer, generate wrapper which calls user-defined main subprogram
+
procedure Gen_Main_Ada;
-- Generate procedure main (Ada code case)
WBI ("");
end Gen_Finalize_Library_Defs_C;
+ --------------------------
+ -- Gen_CodePeer_Wrapper --
+ --------------------------
+
+ procedure Gen_CodePeer_Wrapper is
+ begin
+ Get_Name_String (Units.Table (First_Unit_Entry).Uname);
+
+ declare
+ -- Bypass Ada_Main_Program; its Import pragma confuses CodePeer
+
+ Callee_Name : String renames Name_Buffer (1 .. Name_Len - 2);
+ -- Strip trailing "%b"
+ begin
+ if ALIs.Table (ALIs.First).Main_Program = Proc then
+ WBI (" procedure " & CodePeer_Wrapper_Name & " is ");
+ WBI (" begin");
+ WBI (" " & Callee_Name & ";");
+ else
+ WBI
+ (" function " & CodePeer_Wrapper_Name & " return Integer is");
+ WBI (" begin");
+ WBI (" return " & Callee_Name & ";");
+ end if;
+ end;
+
+ WBI (" end " & CodePeer_Wrapper_Name & ";");
+ WBI ("");
+ end Gen_CodePeer_Wrapper;
+
------------------
-- Gen_Main_Ada --
------------------
if not No_Main_Subprogram then
if CodePeer_Mode then
-
- -- Bypass Ada_Main_Program, its Import pragma confuses CodePeer
-
- Get_Name_String (Units.Table (First_Unit_Entry).Uname);
-
- declare
- Callee_Name : String renames Name_Buffer (1 .. Name_Len - 2);
- -- Strip trailing "%b"
-
- begin
- if ALIs.Table (ALIs.First).Main_Program = Proc then
- WBI (" " & Callee_Name & ";");
- else
- WBI (" Result := " & Callee_Name & ";");
- end if;
- end;
+ if ALIs.Table (ALIs.First).Main_Program = Proc then
+ WBI (" " & CodePeer_Wrapper_Name & ";");
+ else
+ WBI (" Result := " & CodePeer_Wrapper_Name & ";");
+ end if;
elsif ALIs.Table (ALIs.First).Main_Program = Proc then
WBI (" Ada_Main_Program;");
Gen_Adainit_Ada;
if Bind_Main_Program and then VM_Target = No_VM then
+ -- For CodePeer, declare a wrapper for the
+ -- user-defined main program.
+
+ if CodePeer_Mode then
+ Gen_CodePeer_Wrapper;
+ end if;
+
Gen_Main_Ada;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT 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- --
Handler := First_Non_Pragma (Handlrs);
Handler_Loop : while Present (Handler) loop
+ Process_Statements_For_Controlled_Objects (Handler);
+
Next_Handler := Next_Non_Pragma (Handler);
-- Remove source handler if gnat debug flag .x is set
if Compile_Time_Known_Value (Expr) then
Alt := Find_Static_Alternative (N);
+ Process_Statements_For_Controlled_Objects (Alt);
+
-- Move statements from this alternative after the case statement.
-- They are already analyzed, so will be skipped by the analyzer.
Kill_Dead_Code (Expression (N));
declare
- A : Node_Id;
+ Dead_Alt : Node_Id;
begin
-- Loop through case alternatives, skipping pragmas, and skipping
-- the one alternative that we select (and therefore retain).
- A := First (Alternatives (N));
- while Present (A) loop
- if A /= Alt
- and then Nkind (A) = N_Case_Statement_Alternative
+ Dead_Alt := First (Alternatives (N));
+ while Present (Dead_Alt) loop
+ if Dead_Alt /= Alt
+ and then Nkind (Dead_Alt) = N_Case_Statement_Alternative
then
- Kill_Dead_Code (Statements (A), Warn_On_Deleted_Code);
+ Kill_Dead_Code (Statements (Dead_Alt), Warn_On_Deleted_Code);
end if;
- Next (A);
+ Next (Dead_Alt);
end loop;
end;
Len := List_Length (Alternatives (N));
if Len = 1 then
- -- We still need to evaluate the expression if it has any
- -- side effects.
+
+ -- We still need to evaluate the expression if it has any side
+ -- effects.
Remove_Side_Effects (Expression (N));
- Insert_List_After (N, Statements (First (Alternatives (N))));
+ Alt := First (Alternatives (N));
+
+ Process_Statements_For_Controlled_Objects (Alt);
+ Insert_List_After (N, Statements (Alt));
-- That leaves the case statement as a shell. The alternative that
-- will be executed is reset to a null list. So now we can kill
Kill_Dead_Code (Expression (N));
Rewrite (N, Make_Null_Statement (Loc));
return;
- end if;
-- An optimization. If there are only two alternatives, and only
-- a single choice, then rewrite the whole case statement as an
-- simple form, but also with generated code (discriminant check
-- functions in particular)
- if Len = 2 then
+ elsif Len = 2 then
Chlist := Discrete_Choices (First (Alternatives (N)));
if List_Length (Chlist) = 1 then
(Others_Node, Discrete_Choices (Last_Alt));
Set_Discrete_Choices (Last_Alt, New_List (Others_Node));
end if;
+
+ Alt := First (Alternatives (N));
+ while Present (Alt)
+ and then Nkind (Alt) = N_Case_Statement_Alternative
+ loop
+ Process_Statements_For_Controlled_Objects (Alt);
+
+ Next (Alt);
+ end loop;
end;
end Expand_N_Case_Statement;
-- these warnings for expander generated code.
begin
+ Process_Statements_For_Controlled_Objects (N);
+
Adjust_Condition (Condition (N));
-- The following loop deals with constant conditions for the IF. We
if Present (Elsif_Parts (N)) then
E := First (Elsif_Parts (N));
while Present (E) loop
+ Process_Statements_For_Controlled_Objects (E);
+
Adjust_Condition (Condition (E));
-- If there are condition actions, then rewrite the if statement
return;
end if;
+ Process_Statements_For_Controlled_Objects (N);
+
-- Deal with condition for C/Fortran Boolean
if Present (Isc) then
-- sometimes generate a loop and create transient objects inside
-- the loop.
- elsif Nkind (Stmt) = N_Loop_Statement then
- Process_Transient_Objects
- (First_Object => First (Statements (Stmt)),
- Last_Object => Last (Statements (Stmt)),
- Related_Node => Related_Node);
+ elsif Nkind (Related_Node) = N_Object_Declaration
+ and then Is_Array_Type (Base_Type
+ (Etype (Defining_Identifier (Related_Node))))
+ and then Nkind (Stmt) = N_Loop_Statement
+ then
+ declare
+ Block_HSS : Node_Id := First (Statements (Stmt));
+
+ begin
+ -- The loop statements may have been wrapped in a block by
+ -- Process_Statements_For_Controlled_Objects, inspect the
+ -- handled sequence of statements.
+
+ if Nkind (Block_HSS) = N_Block_Statement
+ and then No (Next (Block_HSS))
+ then
+ Block_HSS := Handled_Statement_Sequence (Block_HSS);
+
+ Process_Transient_Objects
+ (First_Object => First (Statements (Block_HSS)),
+ Last_Object => Last (Statements (Block_HSS)),
+ Related_Node => Related_Node);
+
+ -- Inspect the statements of the loop
+
+ else
+ Process_Transient_Objects
+ (First_Object => First (Statements (Stmt)),
+ Last_Object => Last (Statements (Stmt)),
+ Related_Node => Related_Node);
+ end if;
+ end;
-- Terminate the scan after the last object has been processed
T : Entity_Id; -- Additional status flag
begin
+ Process_Statements_For_Controlled_Objects (Trig);
+ Process_Statements_For_Controlled_Objects (Abrt);
+
Blk_Ent := Make_Temporary (Loc, 'A');
Ecall := Triggering_Statement (Trig);
S : Entity_Id; -- Primitive operation slot
begin
+ Process_Statements_For_Controlled_Objects (N);
+
if Ada_Version >= Ada_2005
and then Nkind (Blk) = N_Procedure_Call_Statement
then
-- Start of processing for Expand_N_Selective_Accept
begin
+ Process_Statements_For_Controlled_Objects (N);
+
-- First insert some declarations before the select. The first is:
-- Ann : Address
Alt := First (Alts);
while Present (Alt) loop
+ Process_Statements_For_Controlled_Objects (Alt);
if Nkind (Alt) = N_Accept_Alternative then
Add_Accept (Alt);
return;
end if;
+ Process_Statements_For_Controlled_Objects (Entry_Call_Alternative (N));
+ Process_Statements_For_Controlled_Objects (Delay_Alternative (N));
+
-- The arguments in the call may require dynamic allocation, and the
-- call statement may have been transformed into a block. The block
-- may contain additional declarations for internal entities, and the
-- Create an implicit subtype of CW_Typ attached to node N
function Requires_Cleanup_Actions
- (L : List_Id;
- For_Package : Boolean) return Boolean;
+ (L : List_Id;
+ For_Package : Boolean;
+ Nested_Constructs : Boolean) return Boolean;
-- Given a list L, determine whether it contains one of the following:
--
-- 1) controlled objects
-- 2) library-level tagged types
--
-- Flag For_Package should be set when the list comes from a package spec
- -- or body.
+ -- or body. Flag Nested_Constructs should be set when any nested packages
+ -- declared in L must be processed.
----------------------
-- Adjust_Condition --
end case;
end Possible_Bit_Aligned_Component;
+ -----------------------------------------------
+ -- Process_Statements_For_Controlled_Objects --
+ -----------------------------------------------
+
+ procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ function Are_Wrapped (L : List_Id) return Boolean;
+ -- Determine whether list L contains only one statement which is a block
+
+ function Wrap_Statements_In_Block (L : List_Id) return Node_Id;
+ -- Given a list of statements L, wrap it in a block statement and return
+ -- the generated node.
+
+ -----------------
+ -- Are_Wrapped --
+ -----------------
+
+ function Are_Wrapped (L : List_Id) return Boolean is
+ Stmt : constant Node_Id := First (L);
+
+ begin
+ return
+ Present (Stmt)
+ and then No (Next (Stmt))
+ and then Nkind (Stmt) = N_Block_Statement;
+ end Are_Wrapped;
+
+ ------------------------------
+ -- Wrap_Statements_In_Block --
+ ------------------------------
+
+ function Wrap_Statements_In_Block (L : List_Id) return Node_Id is
+ begin
+ return
+ Make_Block_Statement (Loc,
+ Declarations => No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => L));
+ end Wrap_Statements_In_Block;
+
+ -- Start of processing for Process_Statements_For_Controlled_Objects
+
+ begin
+ case Nkind (N) is
+ when N_Elsif_Part |
+ N_If_Statement |
+ N_Conditional_Entry_Call |
+ N_Selective_Accept =>
+
+ -- Check the "then statements" for elsif parts and if statements
+
+ if Nkind_In (N, N_Elsif_Part,
+ N_If_Statement)
+ and then not Is_Empty_List (Then_Statements (N))
+ and then not Are_Wrapped (Then_Statements (N))
+ and then Requires_Cleanup_Actions
+ (Then_Statements (N), False, False)
+ then
+ Set_Then_Statements (N, New_List (
+ Wrap_Statements_In_Block (Then_Statements (N))));
+ end if;
+
+ -- Check the "else statements" for conditional entry calls, if
+ -- statements and selective accepts.
+
+ if Nkind_In (N, N_Conditional_Entry_Call,
+ N_If_Statement,
+ N_Selective_Accept)
+ and then not Is_Empty_List (Else_Statements (N))
+ and then not Are_Wrapped (Else_Statements (N))
+ and then Requires_Cleanup_Actions
+ (Else_Statements (N), False, False)
+ then
+ Set_Else_Statements (N, New_List (
+ Wrap_Statements_In_Block (Else_Statements (N))));
+ end if;
+
+ when N_Abortable_Part |
+ N_Accept_Alternative |
+ N_Case_Statement_Alternative |
+ N_Delay_Alternative |
+ N_Entry_Call_Alternative |
+ N_Exception_Handler |
+ N_Loop_Statement |
+ N_Triggering_Alternative =>
+
+ if not Is_Empty_List (Statements (N))
+ and then not Are_Wrapped (Statements (N))
+ and then Requires_Cleanup_Actions (Statements (N), False, False)
+ then
+ Set_Statements (N, New_List (
+ Wrap_Statements_In_Block (Statements (N))));
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end Process_Statements_For_Controlled_Objects;
+
-------------------------
-- Remove_Side_Effects --
-------------------------
N_Subprogram_Body |
N_Task_Body =>
return
- Requires_Cleanup_Actions (Declarations (N), For_Pkg)
+ Requires_Cleanup_Actions (Declarations (N), For_Pkg, True)
or else
(Present (Handled_Statement_Sequence (N))
and then
- Requires_Cleanup_Actions
- (Statements (Handled_Statement_Sequence (N)), For_Pkg));
+ Requires_Cleanup_Actions (Statements
+ (Handled_Statement_Sequence (N)), For_Pkg, True));
when N_Package_Specification =>
return
- Requires_Cleanup_Actions (Visible_Declarations (N), For_Pkg)
- or else
- Requires_Cleanup_Actions (Private_Declarations (N), For_Pkg);
+ Requires_Cleanup_Actions
+ (Visible_Declarations (N), For_Pkg, True)
+ or else
+ Requires_Cleanup_Actions
+ (Private_Declarations (N), For_Pkg, True);
when others =>
return False;
------------------------------
function Requires_Cleanup_Actions
- (L : List_Id;
- For_Package : Boolean) return Boolean
+ (L : List_Id;
+ For_Package : Boolean;
+ Nested_Constructs : Boolean) return Boolean
is
Decl : Node_Id;
Expr : Node_Id;
-- Nested package declarations
- elsif Nkind (Decl) = N_Package_Declaration then
+ elsif Nested_Constructs
+ and then Nkind (Decl) = N_Package_Declaration
+ then
Pack_Id := Defining_Unit_Name (Specification (Decl));
if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
-- Nested package bodies
- elsif Nkind (Decl) = N_Package_Body then
+ elsif Nested_Constructs
+ and then Nkind (Decl) = N_Package_Body
+ then
Pack_Id := Corresponding_Spec (Decl);
if Ekind (Pack_Id) /= E_Generic_Package
-- causes trouble for the back end (see Component_May_Be_Bit_Aligned for
-- further details).
+ procedure Process_Statements_For_Controlled_Objects (N : Node_Id);
+ -- N is a node which contains a non-handled statement list. Inspect the
+ -- statements looking for declarations of controlled objects. If at least
+ -- one such object is found, wrap the statement list in a block.
+
procedure Remove_Side_Effects
(Exp : Node_Id;
Name_Req : Boolean := False;
columns:
@noindent
-Index | Task Name | Stack Size | Stack Usage [Value +/- Variation]
+Index | Task Name | Stack Size | Stack Usage
@noindent
where:
@item Stack Usage
is the measure done by the stack analyzer. In order to prevent overflow, the stack
is not entirely analyzed, and it's not possible to know exactly how
-much has actually been used. The report thus contains the theoretical stack usage
-(Value) and the possible variation (Variation) around this value.
+much has actually been used.
@end table
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-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- --
-- | entry frame | ... | leaf frame | |####|
-- +------------------------------------------------------------------+
- function Top_Slot_Index_In (Stack : Stack_Slots) return Integer;
- -- Index of the stack Top slot in the Slots array, denoting the latest
- -- possible slot available to call chain leaves.
-
- function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer;
- -- Index of the stack Bottom slot in the Slots array, denoting the first
- -- possible slot available to call chain entry points.
-
- function Push_Index_Step_For (Stack : Stack_Slots) return Integer;
- -- By how much do we need to update a Slots index to Push a single slot on
- -- the stack.
-
- function Pop_Index_Step_For (Stack : Stack_Slots) return Integer;
- -- By how much do we need to update a Slots index to Pop a single slot off
- -- the stack.
-
- pragma Inline_Always (Top_Slot_Index_In);
- pragma Inline_Always (Bottom_Slot_Index_In);
- pragma Inline_Always (Push_Index_Step_For);
- pragma Inline_Always (Pop_Index_Step_For);
-
- -----------------------
- -- Top_Slot_Index_In --
- -----------------------
-
- function Top_Slot_Index_In (Stack : Stack_Slots) return Integer is
- begin
- if System.Parameters.Stack_Grows_Down then
- return Stack'First;
- else
- return Stack'Last;
- end if;
- end Top_Slot_Index_In;
-
- ----------------------------
- -- Bottom_Slot_Index_In --
- ----------------------------
-
- function Bottom_Slot_Index_In (Stack : Stack_Slots) return Integer is
- begin
- if System.Parameters.Stack_Grows_Down then
- return Stack'Last;
- else
- return Stack'First;
- end if;
- end Bottom_Slot_Index_In;
-
- -------------------------
- -- Push_Index_Step_For --
- -------------------------
-
- function Push_Index_Step_For (Stack : Stack_Slots) return Integer is
- pragma Unreferenced (Stack);
- begin
- if System.Parameters.Stack_Grows_Down then
- return -1;
- else
- return +1;
- end if;
- end Push_Index_Step_For;
-
- ------------------------
- -- Pop_Index_Step_For --
- ------------------------
-
- function Pop_Index_Step_For (Stack : Stack_Slots) return Integer is
- begin
- return -Push_Index_Step_For (Stack);
- end Pop_Index_Step_For;
-
-------------------
-- Unit Services --
-------------------
Stack_Size_Str : constant String := "Stack Size";
Actual_Size_Str : constant String := "Stack usage";
- function Get_Usage_Range (Result : Task_Result) return String;
- -- Return string representing the range of possible result of stack usage
-
procedure Output_Result
(Result_Id : Natural;
Result : Task_Result;
----------------
procedure Initialize (Buffer_Size : Natural) is
- Bottom_Of_Stack : aliased Integer;
Stack_Size_Chars : System.Address;
begin
Result_Array.all :=
(others =>
(Task_Name => (others => ASCII.NUL),
- Variation => 0,
Value => 0,
- Max_Size => 0));
+ Stack_Size => 0));
-- Set the Is_Enabled flag to true, so that the task wrapper knows that
-- it has to handle dynamic stack analysis
(Environment_Task_Analyzer,
"ENVIRONMENT TASK",
My_Stack_Size,
- My_Stack_Size,
- System.Storage_Elements.To_Integer (Bottom_Of_Stack'Address),
- 0);
+ 0,
+ My_Stack_Size);
Fill_Stack (Environment_Task_Analyzer);
-- big, the more an "instrumentation threshold at writing" error is
-- likely to happen.
- Stack_Used_When_Filling : Integer;
- Current_Stack_Level : aliased Integer;
+ Current_Stack_Level : aliased Integer;
- Guard : constant Integer := 256;
+ Guard : constant := 256;
-- Guard space between the Current_Stack_Level'Address and the last
-- allocated byte on the stack.
-
begin
- -- Easiest and most accurate method: the top of the stack is known.
-
- if Analyzer.Top_Pattern_Mark /= 0 then
- Analyzer.Pattern_Size :=
- Stack_Size (Analyzer.Top_Pattern_Mark,
- To_Stack_Address (Current_Stack_Level'Address))
- - Guard;
-
- if System.Parameters.Stack_Grows_Down then
- Analyzer.Stack_Overlay_Address :=
- To_Address (Analyzer.Top_Pattern_Mark);
- else
- Analyzer.Stack_Overlay_Address :=
- To_Address (Analyzer.Top_Pattern_Mark
- - Stack_Address (Analyzer.Pattern_Size));
+ if Parameters.Stack_Grows_Down then
+ if Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size)
+ > To_Stack_Address (Current_Stack_Level'Address) - Guard
+ then
+ -- No room for a pattern
+ Analyzer.Pattern_Size := 0;
+ return;
end if;
- declare
- Pattern : aliased Stack_Slots
- (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
- for Pattern'Address use Analyzer.Stack_Overlay_Address;
-
- begin
- if System.Parameters.Stack_Grows_Down then
- for J in reverse Pattern'Range loop
- Pattern (J) := Analyzer.Pattern;
- end loop;
+ Analyzer.Pattern_Limit := Analyzer.Stack_Base
+ - Stack_Address (Analyzer.Pattern_Size);
- Analyzer.Bottom_Pattern_Mark :=
- To_Stack_Address (Pattern (Pattern'Last)'Address);
-
- else
- for J in Pattern'Range loop
- Pattern (J) := Analyzer.Pattern;
- end loop;
-
- Analyzer.Bottom_Pattern_Mark :=
- To_Stack_Address (Pattern (Pattern'First)'Address);
- end if;
- end;
+ if Analyzer.Stack_Base >
+ To_Stack_Address (Current_Stack_Level'Address) - Guard
+ then
+ -- Reduce pattern size to prevent local frame overwrite
+ Analyzer.Pattern_Size :=
+ Integer (To_Stack_Address (Current_Stack_Level'Address) - Guard
+ - Analyzer.Pattern_Limit);
+ end if;
+ Analyzer.Pattern_Overlay_Address :=
+ To_Address (Analyzer.Pattern_Limit);
else
- -- Readjust the pattern size. When we arrive in this function, there
- -- is already a given amount of stack used, that we won't analyze.
+ if Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size)
+ < To_Stack_Address (Current_Stack_Level'Address) + Guard
+ then
+ -- No room for a pattern
+ Analyzer.Pattern_Size := 0;
+ return;
+ end if;
- Stack_Used_When_Filling :=
- Stack_Size (Analyzer.Bottom_Of_Stack,
- To_Stack_Address (Current_Stack_Level'Address));
+ Analyzer.Pattern_Limit := Analyzer.Stack_Base
+ + Stack_Address (Analyzer.Pattern_Size);
- if Stack_Used_When_Filling > Analyzer.Pattern_Size then
+ if Analyzer.Stack_Base <
+ To_Stack_Address (Current_Stack_Level'Address) + Guard
+ then
+ -- Reduce pattern size to prevent local frame overwrite
+ Analyzer.Pattern_Size := Integer
+ (Analyzer.Pattern_Limit
+ - (To_Stack_Address (Current_Stack_Level'Address) + Guard));
+ end if;
- -- In this case, the known size of the stack is too small, we've
- -- already taken more than expected, so there's no possible
- -- computation
+ Analyzer.Pattern_Overlay_Address :=
+ To_Address (Analyzer.Pattern_Limit
+ - Stack_Address (Analyzer.Pattern_Size));
+ end if;
- Analyzer.Pattern_Size := 0;
+ -- Declare and fill the pattern buffer
+ declare
+ Pattern : aliased Stack_Slots
+ (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
+ for Pattern'Address use Analyzer.Pattern_Overlay_Address;
+
+ begin
+ if System.Parameters.Stack_Grows_Down then
+ for J in reverse Pattern'Range loop
+ Pattern (J) := Analyzer.Pattern;
+ end loop;
else
- Analyzer.Pattern_Size :=
- Analyzer.Pattern_Size - Stack_Used_When_Filling;
+ for J in Pattern'Range loop
+ Pattern (J) := Analyzer.Pattern;
+ end loop;
end if;
-
- declare
- Stack : aliased Stack_Slots
- (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
-
- begin
- Stack := (others => Analyzer.Pattern);
-
- Analyzer.Stack_Overlay_Address := Stack'Address;
-
- if Analyzer.Pattern_Size /= 0 then
- Analyzer.Bottom_Pattern_Mark :=
- To_Stack_Address
- (Stack (Bottom_Slot_Index_In (Stack))'Address);
- Analyzer.Top_Pattern_Mark :=
- To_Stack_Address
- (Stack (Top_Slot_Index_In (Stack))'Address);
- else
- Analyzer.Bottom_Pattern_Mark :=
- To_Stack_Address (Stack'Address);
- Analyzer.Top_Pattern_Mark :=
- To_Stack_Address (Stack'Address);
- end if;
- end;
- end if;
+ end;
end Fill_Stack;
-------------------------
procedure Initialize_Analyzer
(Analyzer : in out Stack_Analyzer;
Task_Name : String;
- My_Stack_Size : Natural;
- Max_Pattern_Size : Natural;
- Bottom : Stack_Address;
- Top : Stack_Address;
- Pattern : Unsigned_32 := 16#DEAD_BEEF#)
+ Stack_Size : Natural;
+ Stack_Base : Stack_Address;
+ Pattern_Size : Natural;
+ Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#)
is
begin
-- Initialize the analyzer fields
- Analyzer.Bottom_Of_Stack := Bottom;
- Analyzer.Stack_Size := My_Stack_Size;
- Analyzer.Pattern_Size := Max_Pattern_Size;
- Analyzer.Pattern := Pattern;
- Analyzer.Result_Id := Next_Id;
- Analyzer.Task_Name := (others => ' ');
- Analyzer.Top_Pattern_Mark := Top;
+ Analyzer.Stack_Base := Stack_Base;
+ Analyzer.Stack_Size := Stack_Size;
+ Analyzer.Pattern_Size := Pattern_Size;
+ Analyzer.Pattern := Pattern;
+ Analyzer.Result_Id := Next_Id;
+ Analyzer.Task_Name := (others => ' ');
-- Compute the task name, and truncate if bigger than Task_Name_Length
is
begin
if SP_Low > SP_High then
- return Natural (SP_Low - SP_High + 4);
+ return Natural (SP_Low - SP_High);
else
- return Natural (SP_High - SP_Low + 4);
+ return Natural (SP_High - SP_Low);
end if;
end Stack_Size;
-- likely to happen.
Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
- for Stack'Address use Analyzer.Stack_Overlay_Address;
+ for Stack'Address use Analyzer.Pattern_Overlay_Address;
begin
- Analyzer.Topmost_Touched_Mark := Analyzer.Bottom_Pattern_Mark;
+ -- Value if the pattern was not modified
+ if Parameters.Stack_Grows_Down then
+ Analyzer.Topmost_Touched_Mark :=
+ Analyzer.Pattern_Limit + Stack_Address (Analyzer.Pattern_Size);
+ else
+ Analyzer.Topmost_Touched_Mark :=
+ Analyzer.Pattern_Limit - Stack_Address (Analyzer.Pattern_Size);
+ end if;
if Analyzer.Pattern_Size = 0 then
return;
-- the bottom of it. The first index not equals to the patterns marks
-- the beginning of the used stack.
- declare
- Top_Index : constant Integer := Top_Slot_Index_In (Stack);
- Bottom_Index : constant Integer := Bottom_Slot_Index_In (Stack);
- Step : constant Integer := Pop_Index_Step_For (Stack);
- J : Integer;
-
- begin
- J := Top_Index;
- loop
+ if System.Parameters.Stack_Grows_Down then
+ for J in Stack'Range loop
if Stack (J) /= Analyzer.Pattern then
Analyzer.Topmost_Touched_Mark
:= To_Stack_Address (Stack (J)'Address);
exit;
end if;
-
- exit when J = Bottom_Index;
- J := J + Step;
end loop;
- end;
- end Compute_Result;
- ---------------------
- -- Get_Usage_Range --
- ---------------------
+ else
+ for J in reverse Stack'Range loop
+ if Stack (J) /= Analyzer.Pattern then
+ Analyzer.Topmost_Touched_Mark
+ := To_Stack_Address (Stack (J)'Address);
+ exit;
+ end if;
+ end loop;
- function Get_Usage_Range (Result : Task_Result) return String is
- Variation_Used_Str : constant String :=
- Natural'Image (Result.Variation);
- Value_Used_Str : constant String :=
- Natural'Image (Result.Value);
- begin
- return Value_Used_Str & " +/- " & Variation_Used_Str;
- end Get_Usage_Range;
+ end if;
+ end Compute_Result;
---------------------
-- Output_Result --
Max_Stack_Size_Len : Natural;
Max_Actual_Use_Len : Natural)
is
- Result_Id_Str : constant String := Natural'Image (Result_Id);
- My_Stack_Size_Str : constant String := Natural'Image (Result.Max_Size);
- Actual_Use_Str : constant String := Get_Usage_Range (Result);
+ Result_Id_Str : constant String := Natural'Image (Result_Id);
+ Stack_Size_Str : constant String := Natural'Image (Result.Stack_Size);
+ Actual_Use_Str : constant String := Natural'Image (Result.Value);
Result_Id_Blanks : constant
String (1 .. Index_Str'Length - Result_Id_Str'Length) :=
(others => ' ');
Stack_Size_Blanks : constant
- String (1 .. Max_Stack_Size_Len - My_Stack_Size_Str'Length) :=
+ String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) :=
(others => ' ');
Actual_Use_Blanks : constant
Put (" | ");
Put (Result.Task_Name);
Put (" | ");
- Put (Stack_Size_Blanks & My_Stack_Size_Str);
+ Put (Stack_Size_Blanks & Stack_Size_Str);
Put (" | ");
Put (Actual_Use_Blanks & Actual_Use_Str);
New_Line;
procedure Output_Results is
Max_Stack_Size : Natural := 0;
- Max_Actual_Use_Result_Id : Natural := Result_Array'First;
+ Max_Stack_Usage : Natural := 0;
Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0;
Task_Name_Blanks : constant
for J in Result_Array'Range loop
exit when J >= Next_Id;
- if Result_Array (J).Value >
- Result_Array (Max_Actual_Use_Result_Id).Value
- then
- Max_Actual_Use_Result_Id := J;
+ if Result_Array (J).Value > Max_Stack_Usage then
+ Max_Stack_Usage := Result_Array (J).Value;
end if;
- if Result_Array (J).Max_Size > Max_Stack_Size then
- Max_Stack_Size := Result_Array (J).Max_Size;
+ if Result_Array (J).Stack_Size > Max_Stack_Size then
+ Max_Stack_Size := Result_Array (J).Stack_Size;
end if;
end loop;
Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length;
- Max_Actual_Use_Len :=
- Get_Usage_Range (Result_Array (Max_Actual_Use_Result_Id))'Length;
+ Max_Actual_Use_Len := Natural'Image (Max_Stack_Usage)'Length;
-- Display the output header. Blanks will be added in front of the
-- labels if needed.
-------------------
procedure Report_Result (Analyzer : Stack_Analyzer) is
- Result : Task_Result :=
- (Task_Name => Analyzer.Task_Name,
- Max_Size => Analyzer.Stack_Size,
- Variation => 0,
- Value => 0);
-
- Overflow_Guard : constant Integer :=
- Analyzer.Stack_Size
- - Stack_Size (Analyzer.Top_Pattern_Mark, Analyzer.Bottom_Of_Stack);
- Max, Min : Positive;
-
+ Result : Task_Result := (Task_Name => Analyzer.Task_Name,
+ Stack_Size => Analyzer.Stack_Size,
+ Value => 0);
begin
if Analyzer.Pattern_Size = 0 then
-
-- If we have that result, it means that we didn't do any computation
-- at all. In other words, we used at least everything (and possibly
-- more).
- Min := Analyzer.Stack_Size - Overflow_Guard;
- Max := Analyzer.Stack_Size;
+ Result.Value := Analyzer.Stack_Size;
else
- Min :=
- Stack_Size
- (Analyzer.Topmost_Touched_Mark, Analyzer.Bottom_Of_Stack);
- Max := Min + Overflow_Guard;
+ Result.Value := Stack_Size (Analyzer.Topmost_Touched_Mark,
+ Analyzer.Stack_Base);
end if;
- Result.Value := (Max + Min) / 2;
- Result.Variation := (Max - Min) / 2;
-
if Analyzer.Result_Id in Result_Array'Range then
-- If the result can be stored, then store it in Result_Array
declare
Result_Str_Len : constant Natural :=
- Get_Usage_Range (Result)'Length;
+ Natural'Image (Result.Value)'Length;
Size_Str_Len : constant Natural :=
Natural'Image (Analyzer.Stack_Size)'Length;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-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- --
-- Amount of stack used. The value is calculated on the basis of the
-- mechanism used by GNAT to allocate it, and it is NOT a precise value.
- Variation : Natural;
- -- Possible variation in the amount of used stack. The real stack usage
- -- may vary in the range Value +/- Variation
-
- Max_Size : Natural;
+ Stack_Size : Natural;
+ -- Size of the stack
end record;
type Result_Array_Type is array (Positive range <>) of Task_Result;
-- begin
-- Initialize_Analyzer (A,
-- "Task t",
+ -- A_Storage_Size,
+ -- 0,
-- A_Storage_Size - A_Guard,
- -- A_Guard
-- To_Stack_Address (Bottom_Of_Stack'Address));
-- Fill_Stack (A);
-- Some_User_Code;
-- before the call to the instrumentation procedure.
-- Strategy: The user of this package should measure the bottom of stack
- -- before the call to Fill_Stack and pass it in parameter.
+ -- before the call to Fill_Stack and pass it in parameter. The impact
+ -- is very minor unless the stack used is very small, but in this case
+ -- you aren't very interested by the figure.
-- Instrumentation threshold at writing:
-- the memory will look like that:
--
-- Stack growing
- -- ----------------------------------------------------------------------->
- -- |<---------------------->|<----------------------------------->|
- -- | Stack frame | Memory filled with Analyzer.Pattern |
- -- | of Fill_Stack | |
- -- | (deallocated at | |
- -- | the end of the call) | |
- -- ^ | ^
- -- Analyzer.Bottom_Of_Stack | Analyzer.Top_Pattern_Mark
- -- ^
- -- Analyzer.Bottom_Pattern_Mark
+ -- ---------------------------------------------------------------------->
+ -- |<--------------------->|<----------------------------------->|
+ -- | Stack frames to | Memory filled with Analyzer.Pattern |
+ -- | Fill_Stack | |
+ -- ^ | ^
+ -- Analyzer.Stack_Base | Analyzer.Pattern_Limit
+ -- ^
+ -- Analyzer.Pattern_Limit +/- Analyzer.Pattern_Size
--
procedure Initialize_Analyzer
(Analyzer : in out Stack_Analyzer;
Task_Name : String;
- My_Stack_Size : Natural;
- Max_Pattern_Size : Natural;
- Bottom : Stack_Address;
- Top : Stack_Address;
+ Stack_Size : Natural;
+ Stack_Base : Stack_Address;
+ Pattern_Size : Natural;
Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#);
-- Should be called before any use of a Stack_Analyzer, to initialize it.
-- Max_Pattern_Size is the size of the pattern zone, might be smaller than
- -- the full stack size in order to take into account e.g. the secondary
- -- stack and a guard against overflow. The actual size taken will be
- -- readjusted with data already used at the time the stack is actually
- -- filled.
+ -- the full stack size Stack_Size in order to take into account e.g. the
+ -- secondary stack and a guard against overflow. The actual size taken
+ -- will be readjusted with data already used at the time the stack is
+ -- actually filled.
Is_Enabled : Boolean := False;
-- When this flag is true, then stack analysis is enabled
-- Stack growing
-- ----------------------------------------------------------------------->
-- |<---------------------->|<-------------->|<--------->|<--------->|
- -- | Stack frame | Array of | used | Memory |
- -- | of Compute_Result | Analyzer.Probe | during | filled |
- -- | (deallocated at | elements | the | with |
- -- | the end of the call) | | execution | pattern |
- -- | ^ | | |
- -- | Bottom_Pattern_Mark | | |
+ -- | Stack frames | Array of | used | Memory |
+ -- | to Compute_Result | Analyzer.Probe | during | filled |
+ -- | | elements | the | with |
+ -- | | | execution | pattern |
-- | | |
-- |<----------------------------------------------------> |
-- Stack used ^
- -- Top_Pattern_Mark
+ -- Pattern_Limit
procedure Report_Result (Analyzer : Stack_Analyzer);
-- Store the results of the computation in memory, at the address
Task_Name : String (1 .. Task_Name_Length);
-- Name of the task
+ Stack_Base : Stack_Address;
+ -- Address of the base of the stack, as given by the caller of
+ -- Initialize_Analyzer.
+
Stack_Size : Natural;
-- Entire size of the analyzed stack
Pattern : Pattern_Type;
-- Pattern used to recognize untouched memory
- Bottom_Pattern_Mark : Stack_Address;
- -- Bound of the pattern area on the stack closest to the bottom
-
- Top_Pattern_Mark : Stack_Address;
- -- Topmost bound of the pattern area on the stack
+ Pattern_Limit : Stack_Address;
+ -- Bound of the pattern area farthest to the base
Topmost_Touched_Mark : Stack_Address;
-- Topmost address of the pattern area whose value it is pointing
-- compensated, it is the topmost value of the stack pointer during
-- the execution.
- Bottom_Of_Stack : Stack_Address;
- -- Address of the bottom of the stack, as given by the caller of
- -- Initialize_Analyzer.
-
- Stack_Overlay_Address : System.Address;
+ Pattern_Overlay_Address : System.Address;
-- Address of the stack abstraction object we overlay over a
-- task's real stack, typically a pattern-initialized array.
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2011, Free Software Foundation, Inc. --
-- --
-- GNAT 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- --
Obj.Task_Name (Obj.Task_Name'First .. Pos);
begin
Put_Line
- ("| " & T_Name & " | " & Natural'Image (Obj.Max_Size) &
- Natural'Image (Obj.Value) & " +/- " &
- Natural'Image (Obj.Variation));
+ ("| " & T_Name & " | " & Natural'Image (Obj.Stack_Size) &
+ Natural'Image (Obj.Value));
end;
end Print;
Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size);
- pragma Warnings (Off);
- -- 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
- -- 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)
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
-- 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 := 12 * 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 := 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???
+
+ 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
-- then Full_Analysis above must be False. You should really regard this as
-- a read only flag.
- In_Pre_Post_Expression : Boolean := False;
- -- Switch to indicate that we are in a precondition or postcondition. The
- -- analysis is not expected to process a precondition or a postcondition as
- -- a sub-analysis for another precondition or postcondition, so this switch
- -- needs not be saved for recursive calls. When this switch is True then
- -- In_Spec_Expression above must be True also. You should really regard
- -- this as a read only flag.
-
In_Deleted_Code : Boolean := False;
-- If the condition in an if-statement is statically known, the branch
-- that is not taken is analyzed with expansion disabled, and the tree
-- Preanalyze the boolean expression, we treat this as a spec expression
-- (i.e. similar to a default expression).
- pragma Assert (In_Pre_Post_Expression = False);
- In_Pre_Post_Expression := True;
Preanalyze_Spec_Expression
(Get_Pragma_Arg (Arg1), Standard_Boolean);
- In_Pre_Post_Expression := False;
-- Remove the subprogram from the scope stack now that the pre-analysis
-- of the precondition/postcondition is done.
OSDN Git Service
