diff mbox

[fortran,0/5] PR 45586: restrict vs. non-restrict type compatibility hell

Message ID 50392F32.3080907@sfr.fr
State New
Headers show

Commit Message

Mikael Morin Aug. 25, 2012, 8:01 p.m. UTC 
On 25/08/2012 20:00, Dominique Dhumieres wrote:
> Dear Mikael,
> 
> Your set of patches works as defined, i.e., it fixes pr45586 without 
> regression on the test suite. However, If the test suite is run with 
> -flto, there are still some failures depending on the way gcc is 
> configured.
Thanks for testing. All right, I'll have to master the LTO beast too. In
the meantime is it by any chance better if the first patch in the serie
is replaced by the attached one?

Mikael

Comments

Dominique d'Humières Aug. 25, 2012, 8:36 p.m. UTC | #1 
> ... In the meantime is it by any chance better if the first patch in the serie
> is replaced by the attached one?

With the new patch for trans-expr.c (keeping those for
trans-types.c and trans.h), typebound_proc_27.f03 -flto -O
now works, but not class_array_7.f03 nor the other tests
I have tried so far.

Dominique
Dominique d'Humières Aug. 26, 2012, 11:23 a.m. UTC | #2 
With the modified patch, gfortran.dg/restrict_type_compat_1.f90 fails
for a regular test:

FAIL: gfortran.dg/restrict_type_compat_1.f90  -O   scan-tree-dump-times original "VIEW_CONVERT_EXPR" 13

A manual check shows only 6 instances of VIEW_CONVERT_EXPR.

Cheers,

Dominique
Mikael Morin Aug. 26, 2012, 12:15 p.m. UTC | #3 
On 26/08/2012 13:23, Dominique Dhumieres wrote:
> With the modified patch, gfortran.dg/restrict_type_compat_1.f90 fails
> for a regular test:
> 
> FAIL: gfortran.dg/restrict_type_compat_1.f90  -O   scan-tree-dump-times original "VIEW_CONVERT_EXPR" 13
> 
> A manual check shows only 6 instances of VIEW_CONVERT_EXPR.
> 
Yes, this is expected.
It doesn't fix all the failures anyway, so something else is needed.

Mikael
diff mbox

Patch

diff --git a/trans-expr.c b/trans-expr.c
index ebaa238..37dfb5a 100644
--- a/trans-expr.c
+++ b/trans-expr.c
@@ -6306,6 +6332,127 @@  gfc_conv_string_parameter (gfc_se * se)
 }
 
 
+static void
+whole_struct_copy (gfc_se *lse, gfc_se *rse, gfc_typespec ts,
+		   stmtblock_t *block)
+{
+  gfc_ref ref;
+  gfc_component *comp;
+  tree old_lhs, old_rhs, tmp;
+  gfc_symbol *derived;
+
+#if 0
+  if ((ts.type != BT_CLASS && ts.type != BT_DERIVED)
+      || !ts.u.derived->attr.alloc_comp)
+    {
+      gfc_add_modify (block, lse->expr,
+		      fold_convert (TREE_TYPE (lse->expr), rse->expr));
+      return;
+    }
+#endif
+
+  derived = ts.u.derived;
+  old_lhs = lse->expr;
+  old_rhs = gfc_evaluate_now (rse->expr, block);
+
+  ref.type = REF_COMPONENT;
+  ref.next = NULL;
+  ref.u.c.sym = derived;
+  for (comp = derived->components; comp; comp = comp->next)
+    {
+      ref.u.c.component = comp;
+      gfc_conv_component_ref (lse, &ref);
+      gfc_conv_component_ref (rse, &ref);
+      if ((comp->attr.pointer
+           && !comp->attr.dimension
+	   && !comp->attr.codimension)
+          || comp->attr.proc_pointer)
+	{
+	  /* Undereference pointers.  */
+	  if (TREE_CODE (lse->expr) == INDIRECT_REF)
+	    lse->expr = TREE_OPERAND (lse->expr, 0);
+	  if (TREE_CODE (rse->expr) == INDIRECT_REF)
+	    rse->expr = TREE_OPERAND (rse->expr, 0);
+	  gfc_add_modify (block, lse->expr, rse->expr);
+	}
+
+      else if (!comp->attr.allocatable || !comp->attr.dimension)
+	{
+	  bool deep_copy;
+
+	  if (comp->attr.dimension)
+	    {
+	      lse->expr = build4_loc (input_location, ARRAY_RANGE_REF,
+				      TREE_TYPE (lse->expr), lse->expr,
+				      gfc_index_zero_node, NULL_TREE,
+				      NULL_TREE);
+	      rse->expr = build4_loc (input_location, ARRAY_RANGE_REF,
+				      TREE_TYPE (rse->expr), rse->expr,
+				      gfc_index_zero_node, NULL_TREE,
+				      NULL_TREE);
+	      /* Disable subreferences after the array range.  */
+	      deep_copy = false;
+	    }
+	  else
+	    deep_copy = true;
+
+	  tmp = gfc_trans_scalar_assign (lse, rse, comp->ts, true, deep_copy,					    false);
+	  gfc_add_expr_to_block (block, tmp);
+	}
+      else
+	{
+	  tree l_base_expr, r_base_expr;
+	  tree l_field, r_field;
+	
+	  l_base_expr = lse->expr;
+	  r_base_expr = rse->expr;
+	  gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (l_base_expr))
+		      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (r_base_expr)));
+	  /* copy all but the data pointer in the descriptor.  */
+	  for (l_field = TYPE_FIELDS (TREE_TYPE (l_base_expr)),
+	       r_field = TYPE_FIELDS (TREE_TYPE (r_base_expr));
+	       l_field != NULL_TREE && r_field != NULL_TREE;
+	       l_field = DECL_CHAIN (l_field),
+	       r_field = DECL_CHAIN (r_field))
+	    {
+	      gcc_assert (TREE_CODE (l_field) == FIELD_DECL
+			  && TREE_CODE (r_field) == FIELD_DECL
+			  && DECL_NAME (l_field) == DECL_NAME (r_field));
+	      if (strcmp (IDENTIFIER_POINTER (DECL_NAME (l_field)),
+			  "data") == 0)
+		continue;
+	
+	      lse->expr = fold_build3_loc (input_location, COMPONENT_REF,
+					   TREE_TYPE (l_field),
+					   l_base_expr,
+					   l_field, NULL_TREE);
+	      rse->expr = fold_build3_loc (input_location, COMPONENT_REF,
+					   TREE_TYPE (r_field), r_base_expr,
+					   r_field, NULL_TREE);
+	      if (TREE_CODE (TREE_TYPE (lse->expr)) == ARRAY_TYPE)
+		{
+		  gcc_assert (TREE_CODE (TREE_TYPE (rse->expr)) == ARRAY_TYPE);
+		  lse->expr = build4_loc (input_location, ARRAY_RANGE_REF,
+					  TREE_TYPE (lse->expr),
+					  lse->expr, gfc_index_zero_node,
+					  NULL_TREE, NULL_TREE);
+		  rse->expr = build4_loc (input_location, ARRAY_RANGE_REF,
+					  TREE_TYPE (rse->expr),
+					  rse->expr, gfc_index_zero_node,
+					  NULL_TREE, NULL_TREE);
+	
+	
+		}
+	      gfc_add_modify (block, lse->expr, rse->expr);
+	    }
+	}
+  
+      lse->expr = old_lhs;
+      rse->expr = old_rhs;
+    }
+}
+
+
 /* Generate code for assignment of scalar variables.  Includes character
    strings and derived types with allocatable components.
    If you know that the LHS has no allocations, set dealloc to false.
@@ -6396,8 +6543,30 @@  gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_add_block_to_block (&block, &rse->pre);
       gfc_add_block_to_block (&block, &lse->pre);
 
-      gfc_add_modify (&block, lse->expr,
-			   fold_convert (TREE_TYPE (lse->expr), rse->expr));
+      if (deep_copy)
+	whole_struct_copy (lse, rse, ts, &block);
+      else
+	{
+	  tree converted;
+
+	  if (TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr))
+	       != TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr))
+	      && !POINTER_TYPE_P (TREE_TYPE (lse->expr))
+	      && !POINTER_TYPE_P (TREE_TYPE (rse->expr)))
+	    {
+	      gcc_assert (TYPE_CANONICAL (TREE_TYPE (lse->expr))
+			  == TYPE_CANONICAL (TREE_TYPE (rse->expr))
+			  && gfc_nonrestricted_type (TREE_TYPE (lse->expr))
+			     == gfc_nonrestricted_type (TREE_TYPE (rse->expr)));
+	      /* fold_convert won't like this.  Let's bypass it.  */
+	      converted = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+					   TREE_TYPE (lse->expr), rse->expr);
+	    }
+	  else
+	    converted = fold_convert (TREE_TYPE (lse->expr), rse->expr);
+
+	  gfc_add_modify (&block, lse->expr, converted);
+	}
 
       /* Do a deep copy if the rhs is a variable, if it is not the
 	 same as the lhs.  */