OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r177386
This commit is contained in:
Arnaud Charlet 2011-08-04 15:41:55 +02:00
parent 1bf773bb9f
commit 2ba7e31e7e
15 changed files with 527 additions and 388 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
gcc/ada/ChangeLog
View File

@ -1,3 +1,60 @@
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

67
gcc/ada/bindgen.adb
View File

@ -1,4 +1,4 @@
------------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
@ -74,6 +74,10 @@ package body Bindgen is
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 --
----------------------------------
@ -275,6 +279,9 @@ package body Bindgen is
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)
@ -2126,6 +2133,36 @@ package body Bindgen is
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 --
------------------
@ -2318,22 +2355,11 @@ package body Bindgen is
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;");
@ -3232,6 +3258,13 @@ package body Bindgen is
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;

4
gcc/ada/exp_ch11.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -968,6 +968,8 @@ package body Exp_Ch11 is
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

44
gcc/ada/exp_ch5.adb
View File

@ -2279,6 +2279,8 @@ package body Exp_Ch5 is
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.
@ -2290,21 +2292,21 @@ package body Exp_Ch5 is
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;
@ -2351,12 +2353,16 @@ package body Exp_Ch5 is
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
@ -2365,7 +2371,6 @@ package body Exp_Ch5 is
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
@ -2374,7 +2379,7 @@ package body Exp_Ch5 is
-- 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
@ -2451,6 +2456,15 @@ package body Exp_Ch5 is
(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;
@ -2525,6 +2539,8 @@ package body Exp_Ch5 is
-- 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
@ -2610,6 +2626,8 @@ package body Exp_Ch5 is
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
@ -3065,6 +3083,8 @@ package body Exp_Ch5 is
return;
end if;
Process_Statements_For_Controlled_Objects (N);
-- Deal with condition for C/Fortran Boolean
if Present (Isc) then

37
gcc/ada/exp_ch7.adb
View File

@ -4366,11 +4366,38 @@ package body Exp_Ch7 is
-- 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

11
gcc/ada/exp_ch9.adb
View File

@ -5872,6 +5872,9 @@ package body Exp_Ch9 is
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);
@ -6824,6 +6827,8 @@ package body Exp_Ch9 is
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
@ -9660,6 +9665,8 @@ package body Exp_Ch9 is
-- 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
@ -9679,6 +9686,7 @@ package body Exp_Ch9 is
Alt := First (Alts);
while Present (Alt) loop
Process_Statements_For_Controlled_Objects (Alt);
if Nkind (Alt) = N_Accept_Alternative then
Add_Accept (Alt);
@ -11035,6 +11043,9 @@ package body Exp_Ch9 is
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

136
gcc/ada/exp_util.adb
View File

@ -148,15 +148,17 @@ package body Exp_Util is
-- 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 --
@ -5446,6 +5448,107 @@ package body Exp_Util is
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 --
-------------------------
@ -6148,18 +6251,20 @@ package body Exp_Util is
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;
@ -6171,8 +6276,9 @@ package body Exp_Util is
------------------------------
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;
@ -6345,7 +6451,9 @@ package body Exp_Util is
-- 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
@ -6360,7 +6468,9 @@ package body Exp_Util is
-- 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

5
gcc/ada/exp_util.ads
View File

@ -706,6 +706,11 @@ package Exp_Util is
-- 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;

5
gcc/ada/gnat_ugn.texi
View File

@ -17259,7 +17259,7 @@ output this info at program termination. Results are displayed in four
columns:
@noindent
Index | Task Name | Stack Size | Stack Usage [Value +/- Variation]
Index | Task Name | Stack Size | Stack Usage
@noindent
where:
@ -17277,8 +17277,7 @@ is the maximum size for the stack.
@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

357
gcc/ada/s-stausa.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -93,76 +93,6 @@ package body System.Stack_Usage is
-- | 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 --
-------------------
@ -175,9 +105,6 @@ package body System.Stack_Usage is
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;
@ -194,7 +121,6 @@ package body System.Stack_Usage is
----------------
procedure Initialize (Buffer_Size : Natural) is
Bottom_Of_Stack : aliased Integer;
Stack_Size_Chars : System.Address;
begin
@ -204,9 +130,8 @@ package body System.Stack_Usage is
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
@ -231,9 +156,8 @@ package body System.Stack_Usage is
(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);
@ -257,99 +181,78 @@ package body System.Stack_Usage is
-- 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));
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.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;
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.
Stack_Used_When_Filling :=
Stack_Size (Analyzer.Bottom_Of_Stack,
To_Stack_Address (Current_Stack_Level'Address));
if Stack_Used_When_Filling > Analyzer.Pattern_Size then
-- 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
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;
else
Analyzer.Pattern_Size :=
Analyzer.Pattern_Size - Stack_Used_When_Filling;
return;
end if;
declare
Stack : aliased Stack_Slots
(1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern);
Analyzer.Pattern_Limit := Analyzer.Stack_Base
- Stack_Address (Analyzer.Pattern_Size);
begin
Stack := (others => Analyzer.Pattern);
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.Stack_Overlay_Address := Stack'Address;
Analyzer.Pattern_Overlay_Address :=
To_Address (Analyzer.Pattern_Limit);
else
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;
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;
Analyzer.Pattern_Limit := Analyzer.Stack_Base
+ Stack_Address (Analyzer.Pattern_Size);
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;
Analyzer.Pattern_Overlay_Address :=
To_Address (Analyzer.Pattern_Limit
- Stack_Address (Analyzer.Pattern_Size));
end if;
-- 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
for J in Pattern'Range loop
Pattern (J) := Analyzer.Pattern;
end loop;
end if;
end;
end Fill_Stack;
-------------------------
@ -359,22 +262,20 @@ package body System.Stack_Usage is
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
@ -399,9 +300,9 @@ package body System.Stack_Usage is
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;
@ -417,10 +318,17 @@ package body System.Stack_Usage is
-- 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;
@ -430,40 +338,27 @@ package body System.Stack_Usage is
-- 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;
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;
end if;
end Compute_Result;
---------------------
-- Get_Usage_Range --
---------------------
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;
---------------------
-- Output_Result --
---------------------
@ -474,16 +369,16 @@ package body System.Stack_Usage is
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
@ -496,7 +391,7 @@ package body System.Stack_Usage is
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;
@ -508,7 +403,7 @@ package body System.Stack_Usage is
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
@ -531,21 +426,18 @@ package body System.Stack_Usage is
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.
@ -599,37 +491,22 @@ package body System.Stack_Usage is
-------------------
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
@ -641,7 +518,7 @@ package body System.Stack_Usage is
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;

78
gcc/ada/s-stausa.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -57,11 +57,8 @@ package System.Stack_Usage is
-- 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;
@ -91,8 +88,9 @@ package System.Stack_Usage is
-- 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;
@ -115,7 +113,9 @@ package System.Stack_Usage is
-- 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:
@ -212,32 +212,29 @@ package System.Stack_Usage is
-- 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
@ -253,16 +250,14 @@ package System.Stack_Usage is
-- 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
@ -288,6 +283,10 @@ private
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
@ -297,11 +296,8 @@ private
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
@ -309,11 +305,7 @@ private
-- 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.

7
gcc/ada/s-stusta.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -250,9 +250,8 @@ package body System.Stack_Usage.Tasking is
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;

96
gcc/ada/s-tassta.adb
View File

@ -1027,32 +1027,11 @@ package body System.Tasking.Stages is
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)
@ -1116,7 +1095,6 @@ package body System.Tasking.Stages is
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
@ -1136,24 +1114,64 @@ package body System.Tasking.Stages is
-- 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);
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.
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);
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

8
gcc/ada/sem.ads
View File

@ -240,14 +240,6 @@ package Sem is
-- 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

3
gcc/ada/sem_prag.adb
View File

@ -258,11 +258,8 @@ package body Sem_Prag is
-- 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.