Fix PR45586 (type confusion ICEs)

[Mikael Morin]

On Sunday 13 February 2011 03:44:28 Michael Matz wrote:
> 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.

Sorry for taking so long, I've been very doubtful about this error_mark_node 
thing, but got convinced in the end (maybe weariness helps ;-) ).

> 
> 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?

A few nits or overlooks below.


> 
> 
> 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.
> 
> 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))
Is there a reason to use DECL_FIELD_CONTEXT here and DECL_CONTEXT otherwise ?
How different are them ?

> +        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
a different base type sounds a bit odd.
the target variant base type would be clearer (even if less accurate w.r.t. 
how it appears to the middle-end).

> +     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);
Shouldn't this be...
ret = build_qualified_type (ret, TYPE_QUALS (ret) & ~TYPE_QUAL_RESTRICT);
...if needed at all?
Also, not sure if it is applicable, but handling it the same way as in the 
other cases (via copy_node) wouldn't drop other infos (other qualifiers, 
type_lang_specific data, ...)


> +	}
> +	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;
I think it is TREE_TYPE (ret) here.

> +	      /* ??? Change some TYPE_LANG_SPECIFICs too?  */
You mean GFC_TYPE_ARRAY_DATAPTR_TYPE?
Yeah, it seems sensible to change it to the non-restrict type. 
For GFC_TYPE_ARRAY_BASE_DECL, looks like it can't have the restrict attribute 
currently, so no need to bother. 

> +	    }
> +	}
> +	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 M1see
Please indent the first line like the rest.

> +      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

Mikael