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.mo...@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
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.reu...@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.reu...@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" } }
