From: Ed Schonberg Date: Mon, 11 Jun 2018 09:17:04 +0000 (+0000) Subject: [Ada] Crash with Inline_Always on a function with an extended return X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=d1ec7de559b75ece7e49da5415426f755916d34f;p=gcc.git [Ada] Crash with Inline_Always on a function with an extended return This patch fixes a crash on a unit with a function with the GNAT-specific Inline_Always pragma whose body is an extended return statement, when compiling with no optimization level specified. 2018-06-11 Ed Schonberg gcc/ada/ * inline.adb (Expand_Inlined_Call): If no optimization level is specified, the expansion of a call to an Inline_Always function is fully performed in the front-end even on a target that support back-end inlining. gcc/testsuite/ * gnat.dg/inline_always1.adb: New testcase. From-SVN: r261402 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a2624b89534..25e133e0d71 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-06-11 Ed Schonberg + + * inline.adb (Expand_Inlined_Call): If no optimization level is + specified, the expansion of a call to an Inline_Always function is + fully performed in the front-end even on a target that support back-end + inlining. + 2018-06-11 Arnaud Charlet * bindgen.adb (Gen_Adainit): Protect reference to System.Parameters diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 336b336365a..f7e6b28ed07 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -2269,11 +2269,16 @@ package body Inline is Subp : Entity_Id; Orig_Subp : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Is_Predef : constant Boolean := - Is_Predefined_Unit (Get_Source_Unit (Subp)); - Orig_Bod : constant Node_Id := + Loc : constant Source_Ptr := Sloc (N); + Is_Predef : constant Boolean := + Is_Predefined_Unit (Get_Source_Unit (Subp)); + Orig_Bod : constant Node_Id := Body_To_Inline (Unit_Declaration_Node (Subp)); + Uses_Back_End : constant Boolean := + Back_End_Inlining and then Optimization_Level > 0; + -- The back-end expansion is used if the target supports back-end + -- inlining and some level of optimixation is required; otherwise + -- the inlining takes place fully as a tree expansion. Blk : Node_Id; Decl : Node_Id; @@ -2840,7 +2845,7 @@ package body Inline is begin -- Initializations for old/new semantics - if not Back_End_Inlining then + if not Uses_Back_End then Is_Unc := Is_Array_Type (Etype (Subp)) and then not Is_Constrained (Etype (Subp)); Is_Unc_Decl := False; @@ -2914,7 +2919,7 @@ package body Inline is -- Old semantics - if not Back_End_Inlining then + if not Uses_Back_End then declare Bod : Node_Id; @@ -2958,8 +2963,20 @@ package body Inline is begin First_Decl := First (Declarations (Blk)); + -- If the body is a single extended return statement, + -- the resulting block is a nested block. + + if No (First_Decl) then + First_Decl := First + (Statements (Handled_Statement_Sequence (Blk))); + + if Nkind (First_Decl) = N_Block_Statement then + First_Decl := First (Declarations (First_Decl)); + end if; + end if; + if Nkind (First_Decl) /= N_Object_Declaration then - return; + return; -- No front-end inlining possible, end if; if Nkind (Parent (N)) /= N_Assignment_Statement then @@ -3288,7 +3305,7 @@ package body Inline is -- of the result of a call to an inlined function that returns -- an unconstrained type - elsif Back_End_Inlining + elsif Uses_Back_End and then Nkind (Parent (N)) = N_Object_Declaration and then Is_Unc then diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 579cc617c4d..6d5e9644f99 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-06-11 Ed Schonberg + + * gnat.dg/inline_always1.adb: New testcase. + 2018-06-11 Ed Schonberg * gnat.dg/nested_generic2.adb, gnat.dg/nested_generic2.ads, diff --git a/gcc/testsuite/gnat.dg/inline_always1.adb b/gcc/testsuite/gnat.dg/inline_always1.adb new file mode 100644 index 00000000000..59f161c4429 --- /dev/null +++ b/gcc/testsuite/gnat.dg/inline_always1.adb @@ -0,0 +1,57 @@ +-- { dg-do compile } + +with Ada.Text_IO; + +procedure Inline_Always1 is + + function S(N : Integer ) return String is + begin + return "hello world"; + end S; + + type String_Access is access all String; + type R is record + SA : String_Access; + end record; + + Data : aliased String := "hello world"; + My_SA : constant String_Access := Data'Access; + function Make_R( S : String ) return R is + My_R : R; + begin + My_R.SA := My_SA; + return My_R; + end Make_R; + + function Get_String( My_R : R ) return String + is + begin + return S : String(My_R.SA.all'Range) do + S := My_R.SA.all; + end return; + end Get_String; + pragma Inline_Always( Get_String); + + My_R : constant R := Make_R( "hello world"); +begin + for I in 1..10000 loop + declare + Res : constant String := S( 4 ); + begin + Ada.Text_IO.Put_Line(Res); + end; + declare + Res : constant String := S( 4 ); + begin + Ada.Text_IO.Put_Line(Res); + end; + + declare + S : constant String := Get_String( My_R ); + begin + Ada.Text_IO.Put_Line(S); + Ada.Text_IO.Put_Line(My_R.SA.all); + end; + end loop; + +end Inline_Always1;