Re: [Patch, Fortran, 66927, v2] [6 Regression] ICE in gfc_conf_procedure_call

[Andre Vehreschild <vehre at gmx dot de>]

Hi Mikael, hi all,

sorry for the late reply, but I was a bit busy lately and the patch was
not as easy as expected. 

Mikael, I addressed your question about clarifying the comment and while
doing so the question arose "what happens when the function returns a
class object?" You have one guess; correct: ICE! This extended patch
now addresses the ICE and furthermore more consequently makes use of
the temporary created for the source= expression. I.e., when the
temporary is a class-object, it's vtab is more often retrieved from the
temporary and no longer generated from the gfc_expr's typespec. 

To efficiently copy - in the class/derived cases - the data, I had to
drill open the gfc_copy_class_to_class() routine a little bit, in that
it accepts the destination object to be a BT_DERIVED, too. 

I provide two testcases now and had to fix class_array_15, which was
expecting one too many calls to __builtin_free. With this patch the
creation of an unnecessary temporary object is prevented, which in the
consequence leads to one less calls to __builtin_free to free the
allocatable component of the temporary object.

Bootstraps and regtests ok on x86_64-linux-gnu/f21.

Ok, for trunk?

Regards,
	Andre

On Sun, 9 Aug 2015 14:37:03 +0200
Mikael Morin <mikael.morin@sfr.fr> wrote:

> Le 06/08/2015 14:00, Mikael Morin a Ãcrit :
> > Let me have a look at it.
> >
> So, I've had a look at it.
> This is a pandora box that I don't want to open.
> So your change is OK.
> However, could you clarify the comment?
> Function calls returning a class object are either pointer or 
> allocatable, so they don't call gfc_conv_expr_descriptor already, they 
> aren't an exception...
> 
> Mikael


-- 
Andre Vehreschild * Email: vehre ad gmx dot de

Attachment: pr66927_2.clog
Description: Binary data

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a6b761b..504b08a 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3222,7 +3222,7 @@ build_array_ref (tree desc, tree offset, tree decl, tree vptr)
     {
       type = gfc_get_element_type (type);
       tmp = TREE_OPERAND (cdecl, 0);
-      tmp = gfc_get_class_array_ref (offset, tmp);
+      tmp = gfc_get_class_array_ref (offset, tmp, NULL_TREE);
       tmp = fold_convert (build_pointer_type (type), tmp);
       tmp = build_fold_indirect_ref_loc (input_location, tmp);
       return tmp;
@@ -7079,9 +7079,20 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 	    }
 	  else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)) || se->use_offset)
 	    {
+	      bool toonebased;
 	      tmp = gfc_conv_array_lbound (desc, n);
+	      toonebased = integer_onep (tmp);
+	      // lb(arr) - from (- start + 1)
 	      tmp = fold_build2_loc (input_location, MINUS_EXPR,
 				     TREE_TYPE (base), tmp, from);
+	      if (onebased && toonebased)
+		{
+		  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+					 TREE_TYPE (base), tmp, start);
+		  tmp = fold_build2_loc (input_location, PLUS_EXPR,
+					 TREE_TYPE (base), tmp,
+					 gfc_index_one_node);
+		}
 	      tmp = fold_build2_loc (input_location, MULT_EXPR,
 				     TREE_TYPE (base), tmp,
 				     gfc_conv_array_stride (desc, n));
@@ -7155,12 +7166,13 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
   /* For class arrays add the class tree into the saved descriptor to
      enable getting of _vptr and the like.  */
   if (expr->expr_type == EXPR_VARIABLE && VAR_P (desc)
-      && IS_CLASS_ARRAY (expr->symtree->n.sym)
-      && DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl))
+      && IS_CLASS_ARRAY (expr->symtree->n.sym))
     {
       gfc_allocate_lang_decl (desc);
       GFC_DECL_SAVED_DESCRIPTOR (desc) =
-	  GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl);
+	  DECL_LANG_SPECIFIC (expr->symtree->n.sym->backend_decl) ?
+	    GFC_DECL_SAVED_DESCRIPTOR (expr->symtree->n.sym->backend_decl)
+	  : expr->symtree->n.sym->backend_decl;
     }
   if (!se->direct_byref || se->byref_noassign)
     {
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index e086fe3..90b5140 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1039,9 +1039,10 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
    of the referenced element.  */
 
 tree
-gfc_get_class_array_ref (tree index, tree class_decl)
+gfc_get_class_array_ref (tree index, tree class_decl, tree data_comp)
 {
-  tree data = gfc_class_data_get (class_decl);
+  tree data = data_comp != NULL_TREE ? data_comp :
+				       gfc_class_data_get (class_decl);
   tree size = gfc_class_vtab_size_get (class_decl);
   tree offset = fold_build2_loc (input_location, MULT_EXPR,
 				 gfc_array_index_type,
@@ -1075,6 +1076,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
   tree stdcopy;
   tree extcopy;
   tree index;
+  bool is_from_desc = false, is_to_class = false;
 
   args = NULL;
   /* To prevent warnings on uninitialized variables.  */
@@ -1088,7 +1090,19 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
   fcn_type = TREE_TYPE (TREE_TYPE (fcn));
 
   if (from != NULL_TREE)
-    from_data = gfc_class_data_get (from);
+    {
+      is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from));
+      if (is_from_desc)
+	{
+	  from_data = from;
+	  from = GFC_DECL_SAVED_DESCRIPTOR (from);
+	}
+      else
+	{
+	  from_data = gfc_class_data_get (from);
+	  is_from_desc = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data));
+	}
+     }
   else
     from_data = gfc_class_vtab_def_init_get (to);
 
@@ -1100,9 +1114,16 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
 	from_len = integer_zero_node;
     }
 
-  to_data = gfc_class_data_get (to);
-  if (unlimited)
-    to_len = gfc_class_len_get (to);
+  if (GFC_CLASS_TYPE_P (TREE_TYPE (to)))
+    {
+      is_to_class = true;
+      to_data = gfc_class_data_get (to);
+      if (unlimited)
+	to_len = gfc_class_len_get (to);
+    }
+  else
+    /* When to is a BT_DERIVED and not a BT_CLASS, then to_data == to.  */
+    to_data = to;
 
   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
     {
@@ -1118,15 +1139,23 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
       nelems = gfc_evaluate_now (tmp, &body);
       index = gfc_create_var (gfc_array_index_type, "S");
 
-      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
+      if (is_from_desc)
 	{
-	  from_ref = gfc_get_class_array_ref (index, from);
+	  from_ref = gfc_get_class_array_ref (index, from, from_data);
 	  vec_safe_push (args, from_ref);
 	}
       else
         vec_safe_push (args, from_data);
 
-      to_ref = gfc_get_class_array_ref (index, to);
+      if (is_to_class)
+	to_ref = gfc_get_class_array_ref (index, to, to_data);
+      else
+	{
+	  tmp = gfc_conv_array_data (to);
+	  tmp = build_fold_indirect_ref_loc (input_location, tmp);
+	  to_ref = gfc_build_addr_expr (NULL_TREE,
+					gfc_build_array_ref (tmp, index, to));
+	}
       vec_safe_push (args, to_ref);
 
       tmp = build_call_vec (fcn_type, fcn, args);
@@ -1183,7 +1212,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
     }
   else
     {
-      gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
+      gcc_assert (!is_from_desc);
       vec_safe_push (args, from_data);
       vec_safe_push (args, to_data);
       stdcopy = build_call_vec (fcn_type, fcn, args);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a8536fd..1bd131e 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5186,9 +5186,16 @@ gfc_trans_allocate (gfc_code * code)
 	  /* In all other cases evaluate the expr3.  */
 	  symbol_attribute attr;
 	  /* Get the descriptor for all arrays, that are not allocatable or
-	     pointer, because the latter are descriptors already.  */
+	     pointer, because the latter are descriptors already.
+	     The exception are function calls returning a class object:
+	     The descriptor is stored in their results _data component, which
+	     is easier to access, when first a temporary variable for the
+	     result is created and the descriptor retrieved from there.  */
 	  attr = gfc_expr_attr (code->expr3);
-	  if (code->expr3->rank != 0 && !attr.allocatable && !attr.pointer)
+	  if (code->expr3->rank != 0
+	      && ((!attr.allocatable && !attr.pointer)
+		  || (code->expr3->expr_type == EXPR_FUNCTION
+		      && code->expr3->ts.type != BT_CLASS)))
 	    gfc_conv_expr_descriptor (&se, code->expr3);
 	  else
 	    gfc_conv_expr_reference (&se, code->expr3);
@@ -5205,17 +5212,40 @@ gfc_trans_allocate (gfc_code * code)
 	     variable declaration.  */
       if (se.expr != NULL_TREE && temp_var_needed)
 	{
-	  tree var;
+	  tree var, desc;
 	  tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
 		se.expr
 	      : build_fold_indirect_ref_loc (input_location, se.expr);
+
+	  /* Get the array descriptor and prepare it to be assigned to the
+	     temporary variable var.  For classes the array descriptor is
+	     in the _data component and the object goes into the
+	     GFC_DECL_SAVED_DESCRIPTOR.  */
+	  if (code->expr3->ts.type == BT_CLASS
+	      && code->expr3->rank != 0)
+	    {
+	      /* When an array_ref was in expr3, then the descriptor is the
+		 first operand.  */
+	      if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+		{
+		  desc = TREE_OPERAND (tmp, 0);
+		}
+	      else
+		{
+		  desc = tmp;
+		  tmp = gfc_class_data_get (tmp);
+		}
+	      e3_is = E3_DESC;
+	    }
+	  else
+	    desc = se.expr;
 	  /* We need a regular (non-UID) symbol here, therefore give a
 	     prefix.  */
 	  var = gfc_create_var (TREE_TYPE (tmp), "source");
-	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
+	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
 	    {
 	      gfc_allocate_lang_decl (var);
-	      GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+	      GFC_DECL_SAVED_DESCRIPTOR (var) = desc;
 	    }
 	  gfc_add_modify_loc (input_location, &block, var, tmp);
 
@@ -5241,11 +5271,12 @@ gfc_trans_allocate (gfc_code * code)
 	  expr3_len = se.string_length;
 	}
       /* Store what the expr3 is to be used for.  */
-      e3_is = expr3 != NULL_TREE ?
-	    (code->ext.alloc.arr_spec_from_expr3 ?
-	       E3_DESC
-	     : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
-	  : E3_UNSET;
+      if (e3_is == E3_UNSET)
+	e3_is = expr3 != NULL_TREE ?
+	      (code->ext.alloc.arr_spec_from_expr3 ?
+		 E3_DESC
+	       : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+	    : E3_UNSET;
 
       /* Figure how to get the _vtab entry.  This also obtains the tree
 	 expression for accessing the _len component, because only
@@ -5254,11 +5285,17 @@ gfc_trans_allocate (gfc_code * code)
       if (code->expr3->ts.type == BT_CLASS)
 	{
 	  gfc_expr *rhs;
+	  tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ?
+		build_fold_indirect_ref (expr3): expr3;
 	  /* Polymorphic SOURCE: VPTR must be determined at run time.
 	     expr3 may be a temporary array declaration, therefore check for
 	     GFC_CLASS_TYPE_P before trying to get the _vptr component.  */
-	  if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))
-	      && (VAR_P (expr3) || !code->expr3->ref))
+	  if (tmp != NULL_TREE
+	      && TREE_CODE (tmp) != POINTER_PLUS_EXPR
+	      && (e3_is == E3_DESC
+		  || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+		      && (VAR_P (tmp) || !code->expr3->ref))
+		  || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp))))
 	    tmp = gfc_class_vptr_get (expr3);
 	  else
 	    {
@@ -5709,10 +5746,7 @@ gfc_trans_allocate (gfc_code * code)
 	  /* Initialization via SOURCE block (or static default initializer).
 	     Classes need some special handling, so catch them first.  */
 	  if (expr3 != NULL_TREE
-	      && ((POINTER_TYPE_P (TREE_TYPE (expr3))
-		   && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
-		  || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
-			TREE_TYPE (expr3))))
+	      && TREE_CODE (expr3) != POINTER_PLUS_EXPR
 	      && code->expr3->ts.type == BT_CLASS
 	      && (expr->ts.type == BT_CLASS
 		  || expr->ts.type == BT_DERIVED))
@@ -5731,7 +5765,7 @@ gfc_trans_allocate (gfc_code * code)
 	      gfc_expr *ppc;
 	      gfc_code *ppc_code;
 	      gfc_ref *ref, *dataref;
-	      gfc_expr *rhs = gfc_copy_expr (code->expr3);
+	      gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
 
 	      /* Do a polymorphic deep copy.  */
 	      actual = gfc_get_actual_arglist ();
@@ -5827,7 +5861,8 @@ gfc_trans_allocate (gfc_code * code)
 					 void_type_node, tmp, extcopy, stdcopy);
 		}
 	      gfc_free_statements (ppc_code);
-	      gfc_free_expr (rhs);
+	      if (rhs != e3rhs)
+		gfc_free_expr (rhs);
 	    }
 	  else
 	    {
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 2501403..3a23a3c 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -378,7 +378,7 @@ tree gfc_vptr_final_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 void gfc_reset_len (stmtblock_t *, gfc_expr *);
 tree gfc_get_vptr_from_expr (tree);
-tree gfc_get_class_array_ref (tree, tree);
+tree gfc_get_class_array_ref (tree, tree, tree);
 tree gfc_copy_class_to_class (tree, tree, tree, bool);
 bool gfc_add_finalizer_call (stmtblock_t *, gfc_expr *);
 bool gfc_add_comp_finalizer_call (stmtblock_t *, tree, gfc_component *, bool);
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_10.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_10.f08
new file mode 100644
index 0000000..b9c68b4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_10.f08
@@ -0,0 +1,51 @@
+!{ dg-do run }
+!
+! Testcase for pr66927
+! Contributed by Juergen Reuter <juergen.reuter@desy.de>
+
+module processes
+  implicit none
+  private
+
+  type :: t1_t
+     real :: p = 0.0
+  end type t1_t
+
+  type :: t2_t
+     private
+     type(t1_t), dimension(:), allocatable :: p
+   contains
+     procedure :: func => t2_func
+  end type t2_t
+
+  type, public :: t3_t
+    type(t2_t), public :: int_born
+  end type t3_t
+
+  public :: evaluate
+
+contains
+
+  function t2_func (int) result (p)
+    class(t2_t), intent(in) :: int
+    type(t1_t), dimension(:), allocatable :: p
+    allocate(p(5))
+  end function t2_func
+
+  subroutine evaluate (t3)
+    class(t3_t), intent(inout) :: t3
+    type(t1_t), dimension(:), allocatable :: p_born
+    allocate (p_born(1:size(t3%int_born%func ())), &
+         source = t3%int_born%func ())
+    if (.not. allocated(p_born)) call abort()
+    if (size(p_born) /= 5) call abort()
+  end subroutine evaluate
+
+end module processes
+
+program pr66927
+use processes
+type(t3_t) :: o
+call evaluate(o)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_11.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_11.f08
new file mode 100644
index 0000000..5491b49
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_11.f08
@@ -0,0 +1,51 @@
+!{ dg-do run }
+!
+! Testcase for pr66927, pr67123
+! Contributed by Juergen Reuter <juergen.reuter@desy.de>
+
+module processes
+  implicit none
+  private
+
+  type :: t1_t
+     real :: p = 0.0
+  end type t1_t
+
+  type :: t2_t
+     private
+     type(t1_t), dimension(:), allocatable :: p
+   contains
+     procedure :: func => t2_func
+  end type t2_t
+
+  type, public :: t3_t
+    type(t2_t), public :: int_born
+  end type t3_t
+
+  public :: evaluate
+
+contains
+
+  function t2_func (int) result (p)
+    class(t2_t), intent(in) :: int
+    class(t1_t), dimension(:), allocatable :: p
+    allocate(p(5))
+  end function t2_func
+
+  subroutine evaluate (t3)
+    class(t3_t), intent(inout) :: t3
+    type(t1_t), dimension(:), allocatable :: p_born
+    allocate (p_born(1:size(t3%int_born%func ())), &
+         source = t3%int_born%func ())
+    if (.not. allocated(p_born)) call abort()
+    if (size(p_born) /= 5) call abort()
+  end subroutine evaluate
+
+end module processes
+
+program pr66927
+use processes
+type(t3_t) :: o
+call evaluate(o)
+end
+
diff --git a/gcc/testsuite/gfortran.dg/class_array_15.f03 b/gcc/testsuite/gfortran.dg/class_array_15.f03
index fd9e04c..85716f9 100644
--- a/gcc/testsuite/gfortran.dg/class_array_15.f03
+++ b/gcc/testsuite/gfortran.dg/class_array_15.f03
@@ -115,4 +115,4 @@ subroutine pr54992  ! This test remains as the original.
   bh => bhGet(b,instance=2)
   if (loc (b) .ne. loc(bh%hostNode)) call abort
 end
-! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 11 "original" } }