Commit 14cf71a0 by Eric Botcazou Committed by Eric Botcazou

re PR ada/77968 (ICEs with -flto on gnat.dg)

	PR ada/77968
	* gcc-interface/utils.c (create_var_decl): Do not clear TREE_READONLY
	in LTO mode for an external variable.
	(can_materialize_object_renaming_p): Move up.

From-SVN: r241154
parent 45b510b3
2016-10-14 Eric Botcazou <ebotcazou@adacore.com>
PR ada/77968
* gcc-interface/utils.c (create_var_decl): Do not clear TREE_READONLY
in LTO mode for an external variable.
(can_materialize_object_renaming_p): Move up.
2016-10-13 Thomas Preud'homme <thomas.preudhomme@arm.com> 2016-10-13 Thomas Preud'homme <thomas.preudhomme@arm.com>
* gcc-interface/utils2.c: Include memmodel.h. * gcc-interface/utils2.c: Include memmodel.h.
......
...@@ -2473,20 +2473,9 @@ create_var_decl (tree name, tree asm_name, tree type, tree init, ...@@ -2473,20 +2473,9 @@ create_var_decl (tree name, tree asm_name, tree type, tree init,
constant initialization and save any variable elaborations for the constant initialization and save any variable elaborations for the
elaboration routine. If we are just annotating types, throw away the elaboration routine. If we are just annotating types, throw away the
initialization if it isn't a constant. */ initialization if it isn't a constant. */
if ((extern_flag && init && !constant_p) if ((extern_flag && !constant_p)
|| (type_annotate_only && init && !TREE_CONSTANT (init))) || (type_annotate_only && init && !TREE_CONSTANT (init)))
{ init = NULL_TREE;
init = NULL_TREE;
/* In LTO mode, also clear TREE_READONLY the same way add_decl_expr
would do it if the initializer was not thrown away here, as the
WPA phase requires a consistent view across compilation units. */
if (const_flag && flag_generate_lto)
{
const_flag = false;
DECL_READONLY_ONCE_ELAB (var_decl) = 1;
}
}
/* At the global level, a non-constant initializer generates elaboration /* At the global level, a non-constant initializer generates elaboration
statements. Check that such statements are allowed, that is to say, statements. Check that such statements are allowed, that is to say,
...@@ -5341,6 +5330,58 @@ smaller_form_type_p (tree type, tree orig_type) ...@@ -5341,6 +5330,58 @@ smaller_form_type_p (tree type, tree orig_type)
return tree_int_cst_lt (size, osize) != 0; return tree_int_cst_lt (size, osize) != 0;
} }
/* Return whether EXPR, which is the renamed object in an object renaming
declaration, can be materialized as a reference (with a REFERENCE_TYPE).
This should be synchronized with Exp_Dbug.Debug_Renaming_Declaration. */
bool
can_materialize_object_renaming_p (Node_Id expr)
{
while (true)
{
switch Nkind (expr)
{
case N_Identifier:
case N_Expanded_Name:
return true;
case N_Selected_Component:
{
if (Is_Packed (Underlying_Type (Etype (Prefix (expr)))))
return false;
const Uint bitpos
= Normalized_First_Bit (Entity (Selector_Name (expr)));
if (!UI_Is_In_Int_Range (bitpos)
|| (bitpos != UI_No_Uint && bitpos != UI_From_Int (0)))
return false;
expr = Prefix (expr);
break;
}
case N_Indexed_Component:
case N_Slice:
{
const Entity_Id t = Underlying_Type (Etype (Prefix (expr)));
if (Is_Array_Type (t) && Present (Packed_Array_Impl_Type (t)))
return false;
expr = Prefix (expr);
break;
}
case N_Explicit_Dereference:
expr = Prefix (expr);
break;
default:
return true;
};
}
}
/* Perform final processing on global declarations. */ /* Perform final processing on global declarations. */
static GTY (()) tree dummy_global; static GTY (()) tree dummy_global;
...@@ -6185,58 +6226,6 @@ handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args), ...@@ -6185,58 +6226,6 @@ handle_vector_type_attribute (tree *node, tree name, tree ARG_UNUSED (args),
return NULL_TREE; return NULL_TREE;
} }
/* Return whether EXPR, which is the renamed object in an object renaming
declaration, can be materialized as a reference (REFERENCE_TYPE). This
should be synchronized with Exp_Dbug.Debug_Renaming_Declaration. */
bool
can_materialize_object_renaming_p (Node_Id expr)
{
while (true)
{
switch Nkind (expr)
{
case N_Identifier:
case N_Expanded_Name:
return true;
case N_Selected_Component:
{
if (Is_Packed (Underlying_Type (Etype (Prefix (expr)))))
return false;
const Uint bitpos
= Normalized_First_Bit (Entity (Selector_Name (expr)));
if (!UI_Is_In_Int_Range (bitpos)
|| (bitpos != UI_No_Uint && bitpos != UI_From_Int (0)))
return false;
expr = Prefix (expr);
break;
}
case N_Indexed_Component:
case N_Slice:
{
const Entity_Id t = Underlying_Type (Etype (Prefix (expr)));
if (Is_Array_Type (t) && Present (Packed_Array_Impl_Type (t)))
return false;
expr = Prefix (expr);
break;
}
case N_Explicit_Dereference:
expr = Prefix (expr);
break;
default:
return true;
};
}
}
/* ----------------------------------------------------------------------- * /* ----------------------------------------------------------------------- *
* BUILTIN FUNCTIONS * * BUILTIN FUNCTIONS *
* ----------------------------------------------------------------------- */ * ----------------------------------------------------------------------- */
......
2016-10-14 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/lto15.adb: Adjust.
* gnat.dg/lto16.adb: Likewise.
* gnat.dg/lto17.adb: Likewise
* gnat.dg/lto18.ad[sb]: New test.
* gnat.dg/lto18_pkg.ads: New helper.
* gnat.dg/lto19.adb: New test.
* gnat.dg/lto19_pkg1.ad[sb]: New helper.
* gnat.dg/lto19_pkg2.ad[sb]: Likewise.
* gnat.dg/lto20.adb: New test.
* gnat.dg/lto20_pkg.ad[sb]: New helper.
2016-10-14 Andre Vehreschild <vehre@gcc.gnu.org> 2016-10-14 Andre Vehreschild <vehre@gcc.gnu.org>
* gfortran.dg/coarray_38.f90: Expect error message. * gfortran.dg/coarray_38.f90: Expect error message.
......
-- { dg-do compile } -- { dg-do compile }
-- { dg-options "-O -flto -g" } -- { dg-options "-O -flto -g" { target lto } }
-- { dg-require-effective-target lto }
package body Lto15 is package body Lto15 is
......
-- { dg-do link } -- { dg-do link }
-- { dg-options "-O -flto" } -- { dg-options "-O -flto" { target lto } }
-- { dg-require-effective-target lto }
with Lto16_Pkg; use Lto16_Pkg; with Lto16_Pkg; use Lto16_Pkg;
with Text_IO; use Text_IO; with Text_IO; use Text_IO;
......
-- { dg-do compile } -- { dg-do compile }
-- { dg-options "-flto" } -- { dg-options "-flto" { target lto } }
-- { dg-require-effective-target lto }
package body Lto17 is package body Lto17 is
......
-- { dg-do compile }
-- { dg-options "-flto" { target lto } }
package body Lto18 is
procedure Proc (Driver : Rec) is
R : Path;
begin
for I in Driver.Step'Range loop
R := Get (Driver, 1, Driver.Step (I));
R := Get (Driver, 2, Driver.Step (I));
R := Get (Driver, 3, Driver.Step (I));
end loop;
end;
end Lto18;
with Lto18_Pkg; use Lto18_Pkg;
package Lto18 is
procedure Proc (Driver : Rec);
end Lto18;
package Lto18_Pkg is
function N return Positive;
pragma Import (Ada, N);
type Path is array(1 .. N) of Long_Float;
type Path_Vector is array (Positive range <>) of Path;
type Path_Vector_P is access all Path_Vector;
type Path_Vector_PV is array(Positive range <>) of Path_Vector_P;
type Path_Vector_P2 is access all Path_Vector_PV;
type Vector is array (Positive range <>) of Natural;
type Vector_Access is access Vector;
type Rec is record
Val : Path_Vector_P2;
Step : Vector_Access;
end record;
function Get (R : Rec; I : Positive; M : Natural) return Path;
-- pragma Inline (Get);
end Lto18_Pkg;
-- { dg-do run }
-- { dg-options "-flto" { target lto } }
-- { dg-excess-errors "does not match original declaration" }
with Lto19_Pkg1;
procedure Lto19 is
R : Lto19_Pkg1.Rec := (I => 1, A => (others => 0));
begin
Lto19_Pkg1.Proc (R);
end;
package body Lto19_Pkg1 is
procedure Proc (R : Rec) is begin null; end;
end Lto19_Pkg1;
with Lto19_Pkg2;
package Lto19_Pkg1 is
type Arr is array (1 .. Lto19_Pkg2.UB) of Integer;
type Rec is record
A : Arr;
I : Integer;
end record;
procedure Proc (R : Rec);
end Lto19_Pkg1;
package body Lto19_Pkg2 is
function UB return Natural is begin return 8; end;
end Lto19_Pkg2;
package Lto19_Pkg2 is
function UB return Natural;
end Lto19_Pkg2;
-- { dg-do run }
-- { dg-options "-flto" { target lto } }
-- { dg-excess-errors "does not match original declaration" }
with Lto20_Pkg;
procedure Lto20 is
begin
Lto20_Pkg.Proc (Lto20_Pkg.Null_Arr);
end;
package body Lto20_Pkg is
type Obj is record
I : Integer;
end record;
procedure Proc (A : Arr) is begin null; end;
end Lto20_Pkg;
package Lto20_Pkg is
type Arr is private;
Null_Arr : constant Arr;
procedure Proc (A : Arr);
private
type Obj;
type Handle is access Obj;
Null_Handle : constant Handle := null;
type Arr is array (1 .. 2) of Handle;
Null_Arr : constant Arr := (others => Null_Handle);
end Lto20_Pkg;
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