From: Eric Botcazou Date: Fri, 14 Oct 2016 10:28:27 +0000 (+0000) Subject: re PR ada/77968 (ICEs with -flto on gnat.dg) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=14cf71a0df9c3f548052b752c7c1e2fd05fc7a8c;p=gcc.git 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 91a783dbcbb..b900ad406fe 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2016-10-14 Eric Botcazou + + 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 * gcc-interface/utils2.c: Include memmodel.h. diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c index 21e12658380..c06721f03b1 100644 --- a/gcc/ada/gcc-interface/utils.c +++ b/gcc/ada/gcc-interface/utils.c @@ -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 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 orig_type) 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, tree name, tree ARG_UNUSED (args), 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 * * ----------------------------------------------------------------------- */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 9596d77e362..2d0b4a329a8 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,16 @@ +2016-10-14 Eric Botcazou + + * 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 * gfortran.dg/coarray_38.f90: Expect error message. diff --git a/gcc/testsuite/gnat.dg/lto15.adb b/gcc/testsuite/gnat.dg/lto15.adb index be5b008e8c6..3a6599241d1 100644 --- a/gcc/testsuite/gnat.dg/lto15.adb +++ b/gcc/testsuite/gnat.dg/lto15.adb @@ -1,6 +1,5 @@ -- { dg-do compile } --- { dg-options "-O -flto -g" } --- { dg-require-effective-target lto } +-- { dg-options "-O -flto -g" { target lto } } package body Lto15 is diff --git a/gcc/testsuite/gnat.dg/lto16.adb b/gcc/testsuite/gnat.dg/lto16.adb index 82d02b4116f..271a6c591f2 100644 --- a/gcc/testsuite/gnat.dg/lto16.adb +++ b/gcc/testsuite/gnat.dg/lto16.adb @@ -1,6 +1,5 @@ -- { dg-do link } --- { dg-options "-O -flto" } --- { dg-require-effective-target lto } +-- { dg-options "-O -flto" { target lto } } with Lto16_Pkg; use Lto16_Pkg; with Text_IO; use Text_IO; diff --git a/gcc/testsuite/gnat.dg/lto17.adb b/gcc/testsuite/gnat.dg/lto17.adb index af42e8d85d8..504fb877a64 100644 --- a/gcc/testsuite/gnat.dg/lto17.adb +++ b/gcc/testsuite/gnat.dg/lto17.adb @@ -1,6 +1,5 @@ -- { dg-do compile } --- { dg-options "-flto" } --- { dg-require-effective-target lto } +-- { dg-options "-flto" { target lto } } package body Lto17 is diff --git a/gcc/testsuite/gnat.dg/lto18.adb b/gcc/testsuite/gnat.dg/lto18.adb new file mode 100644 index 00000000000..ab4085e1ad6 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto18.adb @@ -0,0 +1,16 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/lto18.ads b/gcc/testsuite/gnat.dg/lto18.ads new file mode 100644 index 00000000000..486bc889e7d --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto18.ads @@ -0,0 +1,7 @@ +with Lto18_Pkg; use Lto18_Pkg; + +package Lto18 is + + procedure Proc (Driver : Rec); + +end Lto18; diff --git a/gcc/testsuite/gnat.dg/lto18_pkg.ads b/gcc/testsuite/gnat.dg/lto18_pkg.ads new file mode 100644 index 00000000000..004a1fa97bd --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto18_pkg.ads @@ -0,0 +1,23 @@ +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; diff --git a/gcc/testsuite/gnat.dg/lto19.adb b/gcc/testsuite/gnat.dg/lto19.adb new file mode 100644 index 00000000000..7f083d3576f --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19.adb @@ -0,0 +1,11 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/lto19_pkg1.adb b/gcc/testsuite/gnat.dg/lto19_pkg1.adb new file mode 100644 index 00000000000..84b020ba6cc --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19_pkg1.adb @@ -0,0 +1,5 @@ +package body Lto19_Pkg1 is + + procedure Proc (R : Rec) is begin null; end; + +end Lto19_Pkg1; diff --git a/gcc/testsuite/gnat.dg/lto19_pkg1.ads b/gcc/testsuite/gnat.dg/lto19_pkg1.ads new file mode 100644 index 00000000000..523f538d44a --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19_pkg1.ads @@ -0,0 +1,14 @@ +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; diff --git a/gcc/testsuite/gnat.dg/lto19_pkg2.adb b/gcc/testsuite/gnat.dg/lto19_pkg2.adb new file mode 100644 index 00000000000..70e731a521e --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19_pkg2.adb @@ -0,0 +1,5 @@ +package body Lto19_Pkg2 is + + function UB return Natural is begin return 8; end; + +end Lto19_Pkg2; diff --git a/gcc/testsuite/gnat.dg/lto19_pkg2.ads b/gcc/testsuite/gnat.dg/lto19_pkg2.ads new file mode 100644 index 00000000000..7ca6136cc9e --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto19_pkg2.ads @@ -0,0 +1,5 @@ +package Lto19_Pkg2 is + + function UB return Natural; + +end Lto19_Pkg2; diff --git a/gcc/testsuite/gnat.dg/lto20.adb b/gcc/testsuite/gnat.dg/lto20.adb new file mode 100644 index 00000000000..e4095a97605 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto20.adb @@ -0,0 +1,10 @@ +-- { 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; diff --git a/gcc/testsuite/gnat.dg/lto20_pkg.adb b/gcc/testsuite/gnat.dg/lto20_pkg.adb new file mode 100644 index 00000000000..a5e5aa0ad9a --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto20_pkg.adb @@ -0,0 +1,9 @@ +package body Lto20_Pkg is + + type Obj is record + I : Integer; + end record; + + procedure Proc (A : Arr) is begin null; end; + +end Lto20_Pkg; diff --git a/gcc/testsuite/gnat.dg/lto20_pkg.ads b/gcc/testsuite/gnat.dg/lto20_pkg.ads new file mode 100644 index 00000000000..6ece15f5967 --- /dev/null +++ b/gcc/testsuite/gnat.dg/lto20_pkg.ads @@ -0,0 +1,21 @@ +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;