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

gcc/ada/ChangeLog

@@ -1,3 +1,10 @@
+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>
 
 	* gcc-interface/utils2.c: Include memmodel.h.

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;
-      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
      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                          *
  * ----------------------------------------------------------------------- */

gcc/testsuite/ChangeLog

@@ -1,3 +1,16 @@
+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>
 
 	* gfortran.dg/coarray_38.f90: Expect error message.

gcc/testsuite/gnat.dg/lto15.adb

@@ -1,6 +1,5 @@
 -- { dg-do compile }
--- { dg-options "-O -flto -g" }
+-- { dg-options "-O -flto -g" { target lto } }
--- { dg-require-effective-target lto }
 
 package body Lto15 is
 

gcc/testsuite/gnat.dg/lto16.adb

@@ -1,6 +1,5 @@
 -- { 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 Text_IO; use Text_IO;

gcc/testsuite/gnat.dg/lto17.adb

@@ -1,6 +1,5 @@
 -- { dg-do compile }
--- { dg-options "-flto" }
+-- { dg-options "-flto" { target lto } }
--- { dg-require-effective-target lto }
 
 package body Lto17 is
 

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;

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;

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;

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;

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;

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;

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;

gcc/testsuite/gnat.dg/lto19_pkg2.ads

@@ -0,0 +1,5 @@
+package Lto19_Pkg2 is
+
+  function UB return Natural;
+
+end Lto19_Pkg2;

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;

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;

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;