diff mbox

Fix PR45586 (type confusion ICEs)

Message ID Pine.LNX.4.64.1102130312530.20892@wotan.suse.de
State New
Headers show

Commit Message

Michael Matz Feb. 13, 2011, 2:44 a.m. UTC 
Hi,

so, after Tobias committed the fix for component_refs I've reworked my 
patch for this problem somewhat.  For gory details see the PR trail, but 
in short it's like this: FE generates a backend type per type definition 
it sees.  Variables can have attributes that modify their type (for 
instance make some subobjects/fields be TARGETable), unfortunately 
recursively.  So, in some circumstances we need to generate a new type 
hierarchy using an existing one by stripping off some flags.  For now we 
only need to strip restrictedness, recursively, for a type of variables 
marked in certain ways.

For that we invent gfc_nonrestricted_type, and use it in the right places.

One inconvenience is that the FE captures the notion of fields of an 
aggregate type (components in FE parlance) only per frontend-type, meaning 
the component reflecting 'a%member' is independend of attributes that the 
'a' decl is given.  That's what we fix up in gfc_conv_component_ref, with 
a small cache to not have to repeatedly look this up.

I've included most suggestions from the prereview except the last, adding
  TYPE_LANG_SPECIFIC (ret)->nonrestricted_type = ret;
at the end of gfc_nonrestricted_type.  I haven't done that because it 
would require allocating the lang-specific type structure also for the 
newly generated 'ret' type, which I'd like to defer until it's really 
required.

For one suggestion I had to care for recursion in types (struct contains 
member of pointer to same struct, or variants thereof), making the 
function mildly more complicated, but I've put some extended comments in 
there.

The testsuite went through already (no regressions), it fixes the testcase 
in question.  Full regstrap on x86_64-linux in progress.  Okay if that 
passes?


Ciao,
Michael.

fortran/
	PR fortran/45586
	* gfortran.h (struct gfc_component): Add norestrict_decl member.
	* trans.h (struct lang_type): Add nonrestricted_type member.
	* trans-expr.c (gfc_conv_component_ref): Search fields with correct
	parent type.
	* trans-types.c (gfc_nonrestricted_type): New.
	(gfc_sym_type): Use it.

testsuite/
	PR fortran/45586
	* gfortran.dg/lto/pr45586_0.f90: New test.
diff mbox

Patch

Index: trans-expr.c
===================================================================
--- trans-expr.c	(Revision 170097)
+++ trans-expr.c	(Arbeitskopie)
@@ -504,6 +504,26 @@  gfc_conv_component_ref (gfc_se * se, gfc
   field = c->backend_decl;
   gcc_assert (TREE_CODE (field) == FIELD_DECL);
   decl = se->expr;
+
+  /* Components can correspond to fields of different containing
+     types, as components are created without context, whereas
+     a concrete use of a component has the type of decl as context.
+     So, if the type doesn't match, we search the corresponding
+     FIELD_DECL in the parent type.  To not waste too much time
+     we cache this result in norestrict_decl.  */
+
+  if (DECL_CONTEXT (field) != TREE_TYPE (decl))
+    {
+      tree f2 = c->norestrict_decl;
+      if (!f2 || DECL_FIELD_CONTEXT (f2) != TREE_TYPE (decl))
+        for (f2 = TYPE_FIELDS (TREE_TYPE (decl)); f2; f2 = DECL_CHAIN (f2))
+	  if (TREE_CODE (f2) == FIELD_DECL
+	      && DECL_NAME (f2) == DECL_NAME (field))
+	    break;
+      gcc_assert (f2);
+      c->norestrict_decl = f2;
+      field = f2;
+    }
   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 			 decl, field, NULL_TREE);
 
Index: gfortran.h
===================================================================
--- gfortran.h	(Revision 170097)
+++ gfortran.h	(Arbeitskopie)
@@ -934,6 +934,10 @@  typedef struct gfc_component
   gfc_array_spec *as;
 
   tree backend_decl;
+  /* Used to cache a FIELD_DECL matching this same component
+     but applied to a different base type that was generated by
+     gfc_nonrestricted_type.  */
+  tree norestrict_decl;
   locus loc;
   struct gfc_expr *initializer;
   struct gfc_component *next;
Index: trans-types.c
===================================================================
--- trans-types.c	(Revision 170097)
+++ trans-types.c	(Arbeitskopie)
@@ -1746,6 +1746,124 @@  gfc_build_pointer_type (gfc_symbol * sym
   else
     return build_pointer_type (type);
 }
+
+/* Given a type T, returns a different type of the same structure,
+   except that all types it refers to (recursively) are always
+   non-restrict qualified types.  */
+static tree
+gfc_nonrestricted_type (tree t)
+{
+  tree ret = t;
+  if (!TYPE_LANG_SPECIFIC (t))
+    TYPE_LANG_SPECIFIC (t)
+      = ggc_alloc_cleared_lang_type (sizeof (struct lang_type));
+  /* If we're dealing with this very node already further up
+     the call chain (recursion via pointers and struct members)
+     we haven't yet determined if we really need a new type node.
+     Assume we don't, return T itself.  */
+  if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type == error_mark_node)
+    return t;
+
+  /* If we have calculated this all already, just return it.  */
+  if (TYPE_LANG_SPECIFIC (t)->nonrestricted_type)
+    return TYPE_LANG_SPECIFIC (t)->nonrestricted_type;
+
+  /* Mark this type.  */
+  TYPE_LANG_SPECIFIC (t)->nonrestricted_type = error_mark_node;
+
+  switch (TREE_CODE (t))
+    {
+      default:
+	break;
+
+      case POINTER_TYPE:
+      case REFERENCE_TYPE:
+	{
+	  tree totype = gfc_nonrestricted_type (TREE_TYPE (t));
+	  if (totype == TREE_TYPE (t))
+	    ret = t;
+	  else if (TREE_CODE (t) == POINTER_TYPE)
+	    ret = build_pointer_type (totype);
+	  else
+	    ret = build_reference_type (totype);
+	  ret = build_qualified_type (t, TYPE_QUALS (t) &~TYPE_QUAL_RESTRICT);
+	}
+	break;
+
+      case ARRAY_TYPE:
+	{
+	  tree elemtype = gfc_nonrestricted_type (TREE_TYPE (t));
+	  if (elemtype == TREE_TYPE (t))
+	    ret = t;
+	  else
+	    {
+	      ret = copy_node (t);
+	      TREE_TYPE (t) = elemtype;
+	      /* ??? Change some TYPE_LANG_SPECIFICs too?  */
+	    }
+	}
+	break;
+
+      case RECORD_TYPE:
+      case UNION_TYPE:
+      case QUAL_UNION_TYPE:
+	{
+	  tree field, *chain;
+	  /* First determine if we need a new type at all.
+	     Careful, the two calls to gfc_nonrestricted_type per field
+	     might return different values.  That happens exactly when
+	     one of the fields reaches back to this very record type
+	     (via pointers).  The first calls will assume that we don't
+	     need to copy T (see the error_mark_node marking).  If there
+	     are any reasons for copying T apart from having to copy T,
+	     we'll indeed copy it, and the second calls to
+	     gfc_nonrestricted_type will use that new node if they
+	     reach back to T.  */
+	  for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
+	    if (TREE_CODE (field) == FIELD_DECL)
+	      {
+		tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
+		if (elemtype != TREE_TYPE (field))
+		  break;
+	      }
+	  if (!field)
+	    break;
+	  ret = copy_node (t);
+	  TYPE_FIELDS (ret) = NULL_TREE;
+
+	  /* Here we make sure that as soon as we know we have to copy
+	     T, that also fields reaching back to us will use the new
+	     copy.  It's okay if that copy still contains the old fields,
+	     we won't look at them.  */
+	  TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
+	  chain = &TYPE_FIELDS (ret);
+	  for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
+	    {
+	      tree newfield = copy_node (field);
+	      DECL_CONTEXT (newfield) = ret;
+	      /* The store to DECL_CHAIN might seem redundant with the
+	         stores to *chain, but not clearing it here would mean
+		 leaving a chain into the old fields.  If every
+		 our called functions would look at them confusion
+		 will arise.  */
+	      DECL_CHAIN (newfield) = NULL_TREE;
+	      *chain = newfield;
+	      chain = &DECL_CHAIN (newfield);
+
+	      if (TREE_CODE (field) == FIELD_DECL)
+		{
+		  tree elemtype = gfc_nonrestricted_type (TREE_TYPE (field));
+		  TREE_TYPE (newfield) = elemtype;
+		}
+	    }
+	  *chain = NULL_TREE;
+	}
+        break;
+    }
+  TYPE_LANG_SPECIFIC (t)->nonrestricted_type = ret;
+  return ret;
+}
+
 
 /* Return the type for a symbol.  Special handling is required for character
    types to get the correct level of indirection.
@@ -1796,6 +1914,9 @@  gfc_sym_type (gfc_symbol * sym)
 
   restricted = !sym->attr.target && !sym->attr.pointer
                && !sym->attr.proc_pointer && !sym->attr.cray_pointee;
+  if (!restricted)
+    type = gfc_nonrestricted_type (type);
+
   if (sym->attr.dimension)
     {
       if (gfc_is_nodesc_array (sym))
Index: trans.h
===================================================================
--- trans.h	(Revision 170097)
+++ trans.h	(Arbeitskopie)
@@ -700,6 +700,7 @@  struct GTY((variable_size))	lang_type	 {
   tree dataptr_type;
   tree span;
   tree base_decl[2];
+  tree nonrestricted_type;
 };
 
 struct GTY((variable_size)) lang_decl {
Index: testsuite/gfortran.dg/lto/pr45586_0.f90
===================================================================
--- testsuite/gfortran.dg/lto/pr45586_0.f90	(Revision 0)
+++ testsuite/gfortran.dg/lto/pr45586_0.f90	(Revision 0)
@@ -0,0 +1,29 @@ 
+! { dg-lto-do link }
+MODULE M1
+      INTEGER, PARAMETER :: dp=8
+      TYPE realspace_grid_type
+
+          REAL(KIND=dp), DIMENSION ( :, :, : ), ALLOCATABLE :: r
+
+      END TYPE realspace_grid_type
+      END MODULE
+
+      MODULE M2
+      USE m1
+      CONTAINS
+      SUBROUTINE S1(x)
+      TYPE(realspace_grid_type), POINTER :: x
+      REAL(dp), DIMENSION(:, :, :), POINTER    :: y
+      y=>x%r
+      y=0
+
+      END SUBROUTINE
+      END MODULE
+
+      USE M2
+      TYPE(realspace_grid_type), POINTER :: x
+      ALLOCATE(x)
+      ALLOCATE(x%r(10,10,10))
+      CALL S1(x)
+      write(6,*) x%r
+      END