As reported by Richard, the LTO-specific change I made on 07/11 can yield ICEs
on simple testcases with -flto, so the attached patch simply backs it out and
adds an appropriate LTO testcase, as well as a couple of other LTO testcases
which currently fail with a bogus warning.
Tested on x86_64-suse-linux, applied on the mainline.
2016-10-14 Eric Botcazou <ebotca...@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-14 Eric Botcazou <ebotca...@adacore.com>
* 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.
--
Eric Botcazou-- { 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;
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 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;
package body Lto19_Pkg2 is
function UB return Natural is begin return 8; end;
end Lto19_Pkg2;
-- { 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;
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;
Index: ada/gcc-interface/utils.c
===================================================================
--- ada/gcc-interface/utils.c (revision 241147)
+++ ada/gcc-interface/utils.c (working copy)
@@ -2473,20 +2473,9 @@ create_var_decl (tree name, tree asm_nam
constant initialization and save any variable elaborations for the
elaboration routine. If we are just annotating types, throw away the
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)))
- {
- 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;
- }
- }
+ init = NULL_TREE;
/* At the global level, a non-constant initializer generates elaboration
statements. Check that such statements are allowed, that is to say,
@@ -5341,6 +5330,58 @@ smaller_form_type_p (tree type, tree ori
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. */
static GTY (()) tree dummy_global;
@@ -6185,58 +6226,6 @@ handle_vector_type_attribute (tree *node
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 *
* ----------------------------------------------------------------------- */
