Commit d1ec7de5 by Ed Schonberg Committed by Pierre-Marie de Rodat

[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  <schonberg@adacore.com>

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
parent 75441c4a
2018-06-11 Ed Schonberg <schonberg@adacore.com>
* 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 <charlet@adacore.com> 2018-06-11 Arnaud Charlet <charlet@adacore.com>
* bindgen.adb (Gen_Adainit): Protect reference to System.Parameters * bindgen.adb (Gen_Adainit): Protect reference to System.Parameters
......
...@@ -2269,11 +2269,16 @@ package body Inline is ...@@ -2269,11 +2269,16 @@ package body Inline is
Subp : Entity_Id; Subp : Entity_Id;
Orig_Subp : Entity_Id) Orig_Subp : Entity_Id)
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Is_Predef : constant Boolean := Is_Predef : constant Boolean :=
Is_Predefined_Unit (Get_Source_Unit (Subp)); Is_Predefined_Unit (Get_Source_Unit (Subp));
Orig_Bod : constant Node_Id := Orig_Bod : constant Node_Id :=
Body_To_Inline (Unit_Declaration_Node (Subp)); 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; Blk : Node_Id;
Decl : Node_Id; Decl : Node_Id;
...@@ -2840,7 +2845,7 @@ package body Inline is ...@@ -2840,7 +2845,7 @@ package body Inline is
begin begin
-- Initializations for old/new semantics -- Initializations for old/new semantics
if not Back_End_Inlining then if not Uses_Back_End then
Is_Unc := Is_Array_Type (Etype (Subp)) Is_Unc := Is_Array_Type (Etype (Subp))
and then not Is_Constrained (Etype (Subp)); and then not Is_Constrained (Etype (Subp));
Is_Unc_Decl := False; Is_Unc_Decl := False;
...@@ -2914,7 +2919,7 @@ package body Inline is ...@@ -2914,7 +2919,7 @@ package body Inline is
-- Old semantics -- Old semantics
if not Back_End_Inlining then if not Uses_Back_End then
declare declare
Bod : Node_Id; Bod : Node_Id;
...@@ -2958,8 +2963,20 @@ package body Inline is ...@@ -2958,8 +2963,20 @@ package body Inline is
begin begin
First_Decl := First (Declarations (Blk)); 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 if Nkind (First_Decl) /= N_Object_Declaration then
return; return; -- No front-end inlining possible,
end if; end if;
if Nkind (Parent (N)) /= N_Assignment_Statement then if Nkind (Parent (N)) /= N_Assignment_Statement then
...@@ -3288,7 +3305,7 @@ package body Inline is ...@@ -3288,7 +3305,7 @@ package body Inline is
-- of the result of a call to an inlined function that returns -- of the result of a call to an inlined function that returns
-- an unconstrained type -- an unconstrained type
elsif Back_End_Inlining elsif Uses_Back_End
and then Nkind (Parent (N)) = N_Object_Declaration and then Nkind (Parent (N)) = N_Object_Declaration
and then Is_Unc and then Is_Unc
then then
......
2018-06-11 Ed Schonberg <schonberg@adacore.com> 2018-06-11 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/inline_always1.adb: New testcase.
2018-06-11 Ed Schonberg <schonberg@adacore.com>
* gnat.dg/nested_generic2.adb, gnat.dg/nested_generic2.ads, * gnat.dg/nested_generic2.adb, gnat.dg/nested_generic2.ads,
gnat.dg/nested_generic2_g1.adb, gnat.dg/nested_generic2_g1.ads, gnat.dg/nested_generic2_g1.adb, gnat.dg/nested_generic2_g1.ads,
gnat.dg/nested_generic2_g2.ads: New testcase. gnat.dg/nested_generic2_g2.ads: New testcase.
......
-- { 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment