This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran] PR 41714: [OOP] ALLOCATE SOURCE= does not properly copy the value from SOURCE
2009/10/25 Richard Guenther <richard.guenther@gmail.com>:
> On Sun, Oct 25, 2009 at 6:56 PM, Janus Weil <janus@gcc.gnu.org> wrote:
>>>>> It looks OK to me except:
>>>>>
>>>>>> ? ? ? ?PR fortran/41714
>>>>>> ? ? ? ?* trans-expr.c (gfc_build_memcpy_call): Take care of the case that the
>>>>>> ? ? ? ?call to '__builtin_memcpy' is optimized away (replaced by a direct
>>>>>> ? ? ? ?assignment).
>>>>>
>>>>> How the heck does that work? ?It comes out as a NOP_EXPR and yet it's
>>>>> really an assignment..... Is that documented somewhere?
>>>>
>>>> That patch looks indeed dubious. ?It tests for an implementation detail
>>>> (the memcpy folder returns (void *) ({ *dst = *src; dst; })). ?You should
>>>> be able to unconditionally fold-convert to void_type_node as in the
>>>> original code. ?Instead tree_annotate_all_with_location should be fixed.
>>>
>>> Or rather the FE should not call this function - it assumes that the code
>>> is already gimplified.
>>
>> Ok, so you mean one should instead just do the stuff which this
>> function does, but without the extra checks? Like here:
>>
>> Index: gcc/fortran/trans.c
>> ===================================================================
>> --- gcc/fortran/trans.c (Revision 153538)
>> +++ gcc/fortran/trans.c (Arbeitskopie)
>> @@ -1282,7 +1282,11 @@ gfc_trans_code (gfc_code * code)
>> ? ? ? if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
>> ? ? ? ?{
>> ? ? ? ? ?if (TREE_CODE (res) == STATEMENT_LIST)
>> - ? ? ? ? ? tree_annotate_all_with_location (&res, input_location);
>> + ? ? ? ? ? {
>> + ? ? ? ? ? ? tree_stmt_iterator i;
>> + ? ? ? ? ? ? for (i = tsi_start (res); !tsi_end_p (i); tsi_next (&i))
>> + ? ? ? ? ? ? ? SET_EXPR_LOCATION (tsi_stmt (i), input_location);
>> + ? ? ? ? ? }
>> ? ? ? ? ?else
>> ? ? ? ? ? ?SET_EXPR_LOCATION (res, input_location);
>
> No. ?I think the above should just be dropped (as well as the other
> call in the Fortran frontend). ?The location should have been set
> by the various stmt builders (like build_call_expr_loc in the
> memcpy case). ?For the folding of memcpy case
> the folder will have distributed the locations appropriately.
>
> The middle-end function can then be removed completely (the Fortran
> FE is the only caller). ?A patch to do so is pre-approved.
Alright. Regtesting the attached patch now. Thanks for your help, Richard!
Cheers,
Janus
Index: gcc/testsuite/gfortran.dg/class_allocate_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/class_allocate_4.f03 (Revision 0)
+++ gcc/testsuite/gfortran.dg/class_allocate_4.f03 (Revision 0)
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! PR 41714: [OOP] ALLOCATE SOURCE= does not properly copy the value from SOURCE
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+type t
+ integer :: i
+end type t
+type, extends(t) :: t2
+ integer :: j
+end type t2
+
+class(t), allocatable :: a
+allocate(a, source=t2(1,2))
+print *,a%i
+if(a%i /= 1) call abort()
+select type (a)
+ type is (t2)
+ print *,a%j
+ if(a%j /= 2) call abort()
+end select
+end
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (Revision 153541)
+++ gcc/fortran/trans-openmp.c (Arbeitskopie)
@@ -1641,11 +1641,6 @@ gfc_trans_omp_workshare (gfc_code *code, gfc_omp_c
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
{
- if (TREE_CODE (res) == STATEMENT_LIST)
- tree_annotate_all_with_location (&res, input_location);
- else
- SET_EXPR_LOCATION (res, input_location);
-
if (prev_singleunit)
{
if (ompws_flags & OMPWS_CURR_SINGLEUNIT)
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 153541)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -3983,12 +3983,13 @@ gfc_trans_allocate (gfc_code * code)
tree stat;
tree pstat;
tree error_label;
+ tree memsz;
stmtblock_t block;
if (!code->ext.alloc.list)
return NULL_TREE;
- pstat = stat = error_label = tmp = NULL_TREE;
+ pstat = stat = error_label = tmp = memsz = NULL_TREE;
gfc_start_block (&block);
@@ -4032,19 +4033,19 @@ gfc_trans_allocate (gfc_code * code)
gfc_init_se (&se_sz, NULL);
gfc_conv_expr (&se_sz, sz);
gfc_free_expr (sz);
- tmp = se_sz.expr;
+ memsz = se_sz.expr;
}
else if (code->expr3 && code->expr3->ts.type != BT_CLASS)
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts));
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
+ memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
else
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
+ memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
- if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
- tmp = se.string_length;
+ if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE)
+ memsz = se.string_length;
- tmp = gfc_allocate_with_status (&se.pre, tmp, pstat);
+ tmp = gfc_allocate_with_status (&se.pre, memsz, pstat);
tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr,
fold_convert (TREE_TYPE (se.expr), tmp));
gfc_add_expr_to_block (&se.pre, tmp);
@@ -4075,21 +4076,17 @@ gfc_trans_allocate (gfc_code * code)
if (code->expr3)
{
gfc_expr *rhs = gfc_copy_expr (code->expr3);
- if (rhs->ts.type == BT_CLASS)
+ if (al->expr->ts.type == BT_CLASS)
{
- gfc_se dst,src,len;
- gfc_expr *sz;
- gfc_add_component_ref (rhs, "$data");
- sz = gfc_copy_expr (code->expr3);
- gfc_add_component_ref (sz, "$size");
+ gfc_se dst,src;
+ if (rhs->ts.type == BT_CLASS)
+ gfc_add_component_ref (rhs, "$data");
gfc_init_se (&dst, NULL);
gfc_init_se (&src, NULL);
- gfc_init_se (&len, NULL);
gfc_conv_expr (&dst, expr);
gfc_conv_expr (&src, rhs);
- gfc_conv_expr (&len, sz);
- gfc_free_expr (sz);
- tmp = gfc_build_memcpy_call (dst.expr, src.expr, len.expr);
+ gfc_add_block_to_block (&block, &src.pre);
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
}
else
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
@@ -4108,8 +4105,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_conv_expr (&dst, expr);
gfc_conv_expr (&src, init_e);
gfc_add_block_to_block (&block, &src.pre);
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts));
- tmp = gfc_build_memcpy_call (dst.expr, src.expr, tmp);
+ tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
gfc_add_expr_to_block (&block, tmp);
}
/* Add default initializer for those derived types that need them. */
@@ -4127,6 +4123,7 @@ gfc_trans_allocate (gfc_code * code)
if (expr->ts.type == BT_CLASS)
{
gfc_expr *lhs,*rhs;
+ gfc_se lse;
/* Initialize VINDEX for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
gfc_add_component_ref (lhs, "$vindex");
@@ -4158,36 +4155,11 @@ gfc_trans_allocate (gfc_code * code)
/* Initialize SIZE for CLASS objects. */
lhs = gfc_expr_to_initialize (expr);
gfc_add_component_ref (lhs, "$size");
- rhs = NULL;
- if (code->expr3 && code->expr3->ts.type == BT_CLASS)
- {
- /* Size must be determined at run time. */
- rhs = gfc_copy_expr (code->expr3);
- gfc_add_component_ref (rhs, "$size");
- tmp = gfc_trans_assignment (lhs, rhs, false);
- gfc_add_expr_to_block (&block, tmp);
- }
- else
- {
- /* Size is fixed at compile time. */
- gfc_typespec *ts;
- gfc_se lse;
- gfc_init_se (&lse, NULL);
- gfc_conv_expr (&lse, lhs);
- if (code->expr3)
- ts = &code->expr3->ts;
- else if (code->ext.alloc.ts.type == BT_DERIVED)
- ts = &code->ext.alloc.ts;
- else if (expr->ts.type == BT_CLASS)
- ts = &expr->ts.u.derived->components->ts;
- else
- ts = &expr->ts;
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
- gfc_add_modify (&block, lse.expr,
- fold_convert (TREE_TYPE (lse.expr), tmp));
- }
+ gfc_init_se (&lse, NULL);
+ gfc_conv_expr (&lse, lhs);
+ gfc_add_modify (&block, lse.expr,
+ fold_convert (TREE_TYPE (lse.expr), memsz));
gfc_free_expr (lhs);
- gfc_free_expr (rhs);
}
}
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (Revision 153541)
+++ gcc/fortran/trans.c (Arbeitskopie)
@@ -1279,16 +1279,9 @@ gfc_trans_code (gfc_code * code)
gfc_set_backend_locus (&code->loc);
+ /* Add the new statement to the block. */
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
- {
- if (TREE_CODE (res) == STATEMENT_LIST)
- tree_annotate_all_with_location (&res, input_location);
- else
- SET_EXPR_LOCATION (res, input_location);
-
- /* Add the new statement to the block. */
- gfc_add_expr_to_block (&block, res);
- }
+ gfc_add_expr_to_block (&block, res);
}
/* Return the finished block. */
Index: gcc/gimplify.c
===================================================================
--- gcc/gimplify.c (Revision 153541)
+++ gcc/gimplify.c (Arbeitskopie)
@@ -872,30 +872,7 @@ annotate_all_with_location (gimple_seq stmt_p, loc
}
}
-/* Same, but for statement or statement list in *STMT_P. */
-void
-tree_annotate_all_with_location (tree *stmt_p, location_t location)
-{
- tree_stmt_iterator i;
-
- if (!*stmt_p)
- return;
-
- for (i = tsi_start (*stmt_p); !tsi_end_p (i); tsi_next (&i))
- {
- tree t = tsi_stmt (i);
-
- /* Assuming we've already been gimplified, we shouldn't
- see nested chaining constructs anymore. */
- gcc_assert (TREE_CODE (t) != STATEMENT_LIST
- && TREE_CODE (t) != COMPOUND_EXPR);
-
- tree_annotate_one_with_location (t, location);
- }
-}
-
-
/* Similar to copy_tree_r() but do not copy SAVE_EXPR or TARGET_EXPR nodes.
These nodes model computations that should only be done once. If we
were to unshare something like SAVE_EXPR(i++), the gimplification
Index: gcc/gimple.h
===================================================================
--- gcc/gimple.h (Revision 153541)
+++ gcc/gimple.h (Arbeitskopie)
@@ -939,7 +939,6 @@ extern tree create_tmp_var (tree, const char *);
extern tree get_initialized_tmp_var (tree, gimple_seq *, gimple_seq *);
extern tree get_formal_tmp_var (tree, gimple_seq *);
extern void declare_vars (tree, gimple, bool);
-extern void tree_annotate_all_with_location (tree *, location_t);
extern void annotate_all_with_location (gimple_seq, location_t);
/* Validation of GIMPLE expressions. Note that these predicates only check