From 2ba7e31e7e1c77b639c88aff631900ab7db5958b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 4 Aug 2011 15:41:55 +0200 Subject: [PATCH] [multiple changes] 2011-08-04 Yannick Moy * sem_prag.adb, sem.ads: Code cleanup. 2011-08-04 Tristan Gingold * 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 * 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 * 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 --- gcc/ada/ChangeLog | 57 +++++++ gcc/ada/bindgen.adb | 67 +++++--- gcc/ada/exp_ch11.adb | 4 +- gcc/ada/exp_ch5.adb | 44 ++++-- gcc/ada/exp_ch7.adb | 37 ++++- gcc/ada/exp_ch9.adb | 11 ++ gcc/ada/exp_util.adb | 136 +++++++++++++++-- gcc/ada/exp_util.ads | 5 + gcc/ada/gnat_ugn.texi | 5 +- gcc/ada/s-stausa.adb | 347 ++++++++++++++---------------------------- gcc/ada/s-stausa.ads | 78 +++++----- gcc/ada/s-stusta.adb | 7 +- gcc/ada/s-tassta.adb | 98 +++++++----- gcc/ada/sem.ads | 8 - gcc/ada/sem_prag.adb | 3 - 15 files changed, 523 insertions(+), 384 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d2e9f0d85b3..ec696b94f1b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,60 @@ +2011-08-04 Yannick Moy + + * sem_prag.adb, sem.ads: Code cleanup. + +2011-08-04 Tristan Gingold + + * 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 + + * 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 + + * 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 * sem_type.adb (Covers): If T2 is a subtype of a class-wide type, we diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 7ee75116879..f2714cdd895 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -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; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index d2eed096380..fc55d1567cb 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -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 diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 6cbd62898ab..3c08b512d3b 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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 diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index bb5a9efdce3..452b9e5b2e4 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -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 diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index eba59842af1..a55a7f51698 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b993785f29d..c8d41cb0e7c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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 diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index a60f40ffd32..c7b5b8f8e6c 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -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; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 6f7843a0761..ee2c381314e 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -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 diff --git a/gcc/ada/s-stausa.adb b/gcc/ada/s-stausa.adb index e85bc46bf97..76cac90454f 100644 --- a/gcc/ada/s-stausa.adb +++ b/gcc/ada/s-stausa.adb @@ -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)); + 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; ------------------------- @@ -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,39 +338,26 @@ 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; - 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 -- @@ -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; diff --git a/gcc/ada/s-stausa.ads b/gcc/ada/s-stausa.ads index 1cd78ea0465..c0449e8fbc8 100644 --- a/gcc/ada/s-stausa.ads +++ b/gcc/ada/s-stausa.ads @@ -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. diff --git a/gcc/ada/s-stusta.adb b/gcc/ada/s-stusta.adb index da925a788d3..8961759ce10 100644 --- a/gcc/ada/s-stusta.adb +++ b/gcc/ada/s-stusta.adb @@ -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; diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index d1a5815a835..9a5b67d5284 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -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); - - 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 diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index 79c5a71d2c3..9528841e1c8 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 3eb0bdb70f0..d04a7efc413 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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. -- 2.30.2