* [Patch, fortran] PR64290 - [F03] No finalization at deallocation of LHS
@ 2021-01-14 16:20 Paul Richard Thomas
0 siblings, 0 replies; 2+ messages in thread
From: Paul Richard Thomas @ 2021-01-14 16:20 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 2531 bytes --]
Hi All,
This patch was triggered by a thread on clf. Some years ago Tobias and I
discussed the remaining conditions where finalization should be triggered
and is not. Intrinsic assignment was one of the glaring omissions for which
implementation looked like a heavy lift job. As it happens, it wasn't too
bad :-)
Most of the work was suppressing partial finalization, as a prelude to
reallocation on assignment, and ensuring that finalization happened in the
right circumstances. gfc_assignment_finalizer_call does the work for
intrinsic assignment and is straightforward. Care has to be taken to place
the result between evaluation of the rhs and any reallocation of the lhs
that might occur.
I thought it to be a good idea to squeeze this in before Stage 4 and so the
testcase is not yet finished.I will post it separately once complete and
before pushing the patch. The process is a bit tedious since it involves
checking that the finalization is occurring at the correct point in the
assignment, that the results are consistent with my understanding of
7.5.6.3 and that another brand gives the same results.
Regtests on FC33/x86_64 - OK for master? It occurs to me that this should
also be backported to the 10-branch at very least.
Paul
Fortran:Implement finalization on intrinsic assignment [PR64290]
2021-01-14 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/64290
* resolve.c (resolve_where, gfc_resolve_where_code_in_forall,
gfc_resolve_forall_body, gfc_resolve_code): Check that the op
code is still EXEC_ASSIGN. If it is set lhs to must finalize.
* trans-array.c (structure_alloc_comps): Add boolean argument
to suppress finalization and use it for calls from
gfc_deallocate_alloc_comp_no_caf. Otherwise it defaults to
false.
(gfc_alloc_allocatable_for_assignment): Suppress finalization
by setting new arg in call to gfc_deallocate_alloc_comp_no_caf.
* trans-array.h : Add the new boolean argument to the prototype
of gfc_deallocate_alloc_comp_no_caf with a default of false.
* trans-expr.c (gfc_trans_scalar_assign): Suppress finalization
by setting new arg in call to gfc_deallocate_alloc_comp_no_caf.
(gfc_assignment_finalizer_call): New function to provide
finalization on intrinsic assignment.
(gfc_trans_assignment_1): Call it and add the block between the
rhs evaluation and any reallocation on assignment that there
might be.
gcc/testsuite/
PR fortran/64290
* gfortran.dg/finalize_38.f90 : New test.
* gfortran.dg/allocate_with_source_16.f90 : The number of final
calls goes down from 6 to 4.
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 16595 bytes --]
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f243bd185b0..05f52185b8b 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10415,6 +10415,10 @@ resolve_where (gfc_code *code, gfc_expr *mask)
if (e && !resolve_where_shape (cnext->expr1, e))
gfc_error ("WHERE assignment target at %L has "
"inconsistent shape", &cnext->expr1->where);
+
+ if (cnext->op == EXEC_ASSIGN)
+ cnext->expr1->must_finalize = 1;
+
break;
@@ -10502,6 +10506,10 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
/* WHERE assignment statement */
case EXEC_ASSIGN:
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+
+ if (cnext->op == EXEC_ASSIGN)
+ cnext->expr1->must_finalize = 1;
+
break;
/* WHERE operator assignment statement */
@@ -10548,6 +10556,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
case EXEC_ASSIGN:
case EXEC_POINTER_ASSIGN:
gfc_resolve_assign_in_forall (c, nvar, var_expr);
+
+ if (c->op == EXEC_ASSIGN)
+ c->expr1->must_finalize = 1;
+
break;
case EXEC_ASSIGN_CALL:
@@ -11947,6 +11959,9 @@ start:
&& code->expr1->ts.u.derived->attr.defined_assign_comp)
generate_component_assignments (&code, ns);
+ if (code->op == EXEC_ASSIGN)
+ code->expr1->must_finalize = 1;
+
break;
case EXEC_LABEL_ASSIGN:
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 4bd4db877bd..8ac6b9e88fb 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -8661,7 +8661,7 @@ static gfc_actual_arglist *pdt_param_list;
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
tree dest, int rank, int purpose, int caf_mode,
- gfc_co_subroutines_args *args)
+ gfc_co_subroutines_args *args, bool no_finalization)
{
gfc_component *c;
gfc_loopinfo loop;
@@ -8749,11 +8749,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_conv_array_data (dest));
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank,
- COPY_ALLOC_COMP, caf_mode, args);
+ COPY_ALLOC_COMP, caf_mode, args,
+ no_finalization);
}
else
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
gfc_add_expr_to_block (&loopbody, tmp);
@@ -8787,13 +8788,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_PDT_COMP, 0, args);
+ DEALLOCATE_PDT_COMP, 0, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- NULLIFY_ALLOC_COMP, 0, args);
+ NULLIFY_ALLOC_COMP, 0, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
@@ -8851,7 +8854,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
}
else
{
@@ -8859,7 +8862,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
@@ -8955,8 +8959,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
continue;
}
- if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
- || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+ if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+ || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
/* Call the finalizer, which will free the memory and nullify the
pointer of an array. */
deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
@@ -8984,7 +8988,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
}
else
{
@@ -8992,7 +8996,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
@@ -9290,7 +9295,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- rank, purpose, caf_mode, args);
+ rank, purpose, caf_mode, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
@@ -9326,7 +9332,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
rank, purpose, caf_mode
| GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
- args);
+ args, no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
}
@@ -9434,7 +9440,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, dcmp,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
else
add_when_allocated = NULL_TREE;
@@ -9807,7 +9814,8 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
NULLIFY_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+ NULL, false);
}
@@ -9820,7 +9828,8 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
DEALLOCATE_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+ NULL, false);
}
tree
@@ -9858,7 +9867,8 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
BCAST_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+ &args, false);
return tmp;
}
@@ -9868,10 +9878,12 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
status of coarrays. */
tree
-gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
+ bool no_finalization)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_ALLOC_COMP, 0, NULL);
+ DEALLOCATE_ALLOC_COMP, 0, NULL,
+ no_finalization);
}
@@ -9879,7 +9891,8 @@ tree
gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
{
return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+ NULL, false);
}
@@ -9891,7 +9904,7 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
int caf_mode)
{
return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
- caf_mode, NULL);
+ caf_mode, NULL, false);
}
@@ -9902,7 +9915,7 @@ tree
gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
{
return structure_alloc_comps (der_type, decl, dest, rank,
- COPY_ONLY_ALLOC_COMP, 0, NULL);
+ COPY_ONLY_ALLOC_COMP, 0, NULL, false);
}
@@ -9917,7 +9930,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
gfc_actual_arglist *old_param_list = pdt_param_list;
pdt_param_list = param_list;
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- ALLOCATE_PDT_COMP, 0, NULL);
+ ALLOCATE_PDT_COMP, 0, NULL, false);
pdt_param_list = old_param_list;
return res;
}
@@ -9929,7 +9942,7 @@ tree
gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_PDT_COMP, 0, NULL);
+ DEALLOCATE_PDT_COMP, 0, NULL, false);
}
@@ -9944,7 +9957,7 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
gfc_actual_arglist *old_param_list = pdt_param_list;
pdt_param_list = param_list;
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- CHECK_PDT_DUMMY, 0, NULL);
+ CHECK_PDT_DUMMY, 0, NULL, false);
pdt_param_list = old_param_list;
return res;
}
@@ -10678,7 +10691,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
&& expr1->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
- expr1->rank);
+ expr1->rank, true);
gfc_add_expr_to_block (&realloc_block, tmp);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index e4d443d7118..6e2ad0bc938 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -54,7 +54,8 @@ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
tree, tree, tree);
-tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int,
+ bool no_finalization = false);
tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7150e48bc93..fa9661f41bc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -9908,7 +9908,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (dealloc)
{
tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
- tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
+ tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
+ 0, true);
if (deep_copy)
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
@@ -10999,6 +11000,68 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
}
}
+
+ /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
+ (10.2.1.3), if the variable is not an unallocated allocatable variable,
+ it is finalized after evaluation of expr and before the definition of
+ the variable. If the variable is an allocated allocatable variable, or
+ has an allocated allocatable subobject, that would be deallocated by
+ intrinsic assignment, the finalization occurs before the deallocation */
+
+static tree
+gfc_assignment_finalizer_call (gfc_expr *expr1, gfc_ss *lss,
+ tree lse_expr, bool init_flag)
+{
+ stmtblock_t final_block;
+ gfc_init_block (&final_block);
+ symbol_attribute lhs_attr;
+ tree final_expr;
+ tree ptr;
+ tree cond;
+
+ /* We have to exclude vtable procedures (_copy and _final especially), uses
+ of gfc_trans_assignment_1 in initialization and allocation before trying
+ to build a final call. */
+ if (!expr1->must_finalize
+ || expr1->symtree->n.sym->attr.artificial
+ || expr1->symtree->n.sym->ns->proc_name->attr.artificial
+ || init_flag)
+ return NULL_TREE;
+
+ if (!(expr1->ts.type == BT_CLASS
+ || (expr1->ts.type == BT_DERIVED
+ && gfc_is_finalizable (expr1->ts.u.derived, NULL)))
+ || !gfc_add_finalizer_call (&final_block, expr1))
+ return NULL_TREE;
+
+ lhs_attr = gfc_expr_attr (expr1);
+ if (lhs_attr.allocatable || lhs_attr.pointer)
+ {
+ if (lss == gfc_ss_terminator)
+ ptr = gfc_build_addr_expr (NULL_TREE, lse_expr);
+ else
+ ptr = lss->info->data.array.data;
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ ptr, build_zero_cst (TREE_TYPE (ptr)));
+ final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, gfc_finish_block (&final_block),
+ build_empty_stmt (input_location));
+ }
+ else
+ final_expr = gfc_finish_block (&final_block);
+
+ if (expr1->symtree->n.sym->attr.optional)
+ {
+ cond = gfc_conv_expr_present (expr1->symtree->n.sym);
+ final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, final_expr,
+ build_empty_stmt (input_location));
+ }
+
+ return final_expr;
+}
+
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
@@ -11022,6 +11085,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree tmp;
stmtblock_t block;
stmtblock_t body;
+ tree final_expr;
bool l_is_temp;
bool scalar_to_array;
tree string_length;
@@ -11062,6 +11126,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
needed at two locations, so do it once only before the information is
needed. */
lhs_attr = gfc_expr_attr (expr1);
+
is_poly_assign = (use_vptr_copy || lhs_attr.pointer
|| (lhs_attr.allocatable && !lhs_attr.dimension))
&& (expr1->ts.type == BT_CLASS
@@ -11387,8 +11452,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
!(l_is_temp || init_flag) && dealloc,
expr1->symtree->n.sym->attr.codimension);
- /* Add the pre blocks to the body. */
- gfc_add_block_to_block (&body, &rse.pre);
+ /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
+ after evaluation of the rhs and before reallocation. */
+ final_expr = gfc_assignment_finalizer_call (expr1, lss, lse.expr, init_flag);
+ if (final_expr)
+ {
+ if (lss == gfc_ss_terminator)
+ {
+ gfc_add_block_to_block (&block, &rse.pre);
+ gfc_add_expr_to_block (&block, final_expr);
+ }
+ else
+ {
+ gfc_add_block_to_block (&body, &rse.pre);
+ gfc_add_expr_to_block (&loop.code[expr1->rank - 1], final_expr);
+ }
+ }
+ else
+ gfc_add_block_to_block (&body, &rse.pre);
+
+ /* Add the lse pre block to the body */
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
/* Add the post blocks to the body. */
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
index 0f1e9b67287..60f35836cdb 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
@@ -5,7 +5,7 @@
! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
! Andre Vehreschild <vehre@gcc.gnu.org>
!
-
+
module m1
implicit none
private
@@ -35,7 +35,7 @@ type, extends(basetype) :: exttype
endtype exttype
type :: factory
- integer(I_P) :: steps=-1
+ integer(I_P) :: steps=-1
contains
procedure, pass(self), public :: construct
endtype factory
@@ -68,7 +68,7 @@ endmodule m2
if (d%i2 /= 5) STOP 2
class default
STOP 3
- end select
+ end select
if (d%i /= 2) STOP 4
deallocate(c1)
deallocate(prev)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
index 92dc50756d4..de20a147842 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
@@ -68,4 +68,4 @@ contains
end function func_foo_a
end program simple_leak
-! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
+! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } }
[-- Attachment #3: finalize_38.f90 --]
[-- Type: text/x-fortran, Size: 2299 bytes --]
! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
!
module testmode
implicit none
type :: simple
integer :: ind
contains
final :: destruct1, destruct2
end type simple
integer :: check_scalar
integer :: check_array(2)
integer :: final_count = 0
contains
subroutine destruct1(self)
type(simple), intent(inout) :: self
! print *, "DESTRUCTING SCALAR", self%ind
check_scalar = self%ind
check_array = 0
final_count = final_count + 1
end subroutine destruct1
subroutine destruct2(self)
type(simple), intent(inout) :: self(:)
! print *, "DESTRUCTING ARRAY", self%ind
check_scalar = 0
check_array = self%ind
final_count = final_count + 1
end subroutine destruct2
subroutine test (cnt, scalar, array, off)
integer :: cnt
integer :: scalar
integer :: array(:)
integer :: off
if (final_count .ne. cnt) stop 1 + off
if (check_scalar .ne. scalar) stop 2 + off
if (any (check_array .ne. array)) stop 3 + off
end subroutine test
end module testmode
program test_final
use testmode
implicit none
type(simple), allocatable :: myres, myres2
type(simple), allocatable :: myarray(:)
type(simple) :: thyres = simple(21), thyres2 = simple(22)
class(*), allocatable :: mystar
class(*), allocatable :: mystararray(:)
! Since myres is not allocated there should be no final call.
myres = thyres
if (final_count .ne. 0) stop 1
if (.not. allocated(myres)) allocate(myres)
allocate(myres2)
myres%ind = 1
myres2%ind = 2
myres = myres2
call test(1, 1, [0,0], 10)
allocate(myarray(2))
myarray%ind = [42, 43]
myarray = [thyres, thyres2]
call test(2, 0, [42,43], 20)
thyres2 = simple(99)
call test(3, 22, [0,0], 30)
thyres = thyres2
call test(4, 21, [0,0], 40)
deallocate (myres, myres2)
call test(6, 2, [0,0], 100)
deallocate (myarray)
call test(7, 0, [21,22], 200)
allocate (mystar, source = simple (3))
mystar = simple (4)
call test(8, 3, [0,0], 50)
deallocate (mystar)
call test(9, 4, [0,0], 60)
allocate (mystararray, source = [simple (5), simple (6)])
mystararray = [simple (7), simple (8)]
call test(10, 0, [5,6], 70)
deallocate (mystararray)
call test(11, 0, [7,8], 80)
end program test_final
^ permalink raw reply [flat|nested] 2+ messages in thread
* [Patch, fortran] PR64290 - [F03] No finalization at deallocation of LHS
@ 2022-01-17 11:57 Paul Richard Thomas
0 siblings, 0 replies; 2+ messages in thread
From: Paul Richard Thomas @ 2022-01-17 11:57 UTC (permalink / raw)
To: fortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3432 bytes --]
Hi All,
Strictly speaking, the attached patch is branching out into a more
generalised attack on PR37336(Finalization) - [F03] Finish derived-type
finalization but most of it fixes PR64290.
I started work on this patch almost a year ago but had to drop it due
daytime work pressure and only picked it up again a couple of weeks back.
It is not, as yet, complete but I thought to post it in its present form
because stage 3 ended yesterday.
The main thrusts of the patch are:
(i) To correct the order taken by finalization and deallocation of
components for the lhs of assignments. This is done instead by a call to
Tobias' finalization wrapper, rather than performing finalization component
by component in structure_alloc_comps;
(ii) To add finalization of scalar derived type function results, again by
use of the finalization wrapper. This points to a problem that I haven't
yet managed to fix, F2018(7.5.6.3 para 5) "If an executable construct
references a nonpointer function, the result is finalized after execution
of the innermost executable construct containing the reference." I have
been struggling to avoid implementing this by introducing a finalization
block into gfc_se but have run out of ideas as to how to do it otherwise.
(eg. Try using a finalizable function as the actual argument of another
procedure.); and
(iii) Once (ii) is added, a segfault occurs if the derived type has
allocatable, finalizable components. (PR96122) This occurred because the
call to the component finalization wrapper was missing two arguments in the
call; most particularly 'byte_stride'.
There is still quite a lot to do to bring together common code chunks, fix
the ordering requirement of F2018 (7.5.6.3 para 5), add more testcases.
It's certainly not ready to be committed yet :-(
Regards
Paul
Fortran:Implement missing finalization features [PR64290]
2022-01-17 Paul Thomas <pault@gcc.gnu.org>
gcc/fortran
PR fortran/103854
* class.c (has_finalizer_component): Do not return true for
procedure pointer components.
PR fortran/96087
* class.c (finalize_component): Include the missing arguments
in the call to the component's finalizer wrapper.
PR fortran/64290
* resolve.c (resolve_where, gfc_resolve_where_code_in_forall,
gfc_resolve_forall_body, gfc_resolve_code): Check that the op
code is still EXEC_ASSIGN. If it is set lhs to must finalize.
* trans-array.c (structure_alloc_comps): Add boolean argument
to suppress finalization and use it for calls from
gfc_deallocate_alloc_comp_no_caf. Otherwise it defaults to
false.
(gfc_alloc_allocatable_for_assignment): Suppress finalization
by setting new arg in call to gfc_deallocate_alloc_comp_no_caf.
* trans-array.h : Add the new boolean argument to the prototype
of gfc_deallocate_alloc_comp_no_caf with a default of false.
* trans-expr.c (gfc_conv_procedure_call): Call finalizer for
finalizable scalar function results.
(gfc_trans_scalar_assign): Suppress finalization by setting new
argument in call to gfc_deallocate_alloc_comp_no_caf.
(gfc_assignment_finalizer_call): New function to provide
finalization on intrinsic assignment.
(trans_class_assignment, gfc_trans_assignment_1): Call it and
add the block between the rhs evaluation and any reallocation
on assignment that there might be.
gcc/testsuite/
PR fortran/64290
* gfortran.dg/finalize_38.f90 : New test.
* gfortran.dg/allocate_with_source_25.f90 : The number of final
calls goes down from 6 to 4.
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 24141 bytes --]
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 2cb0c6572bd..18289eaffe8 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -896,7 +896,8 @@ has_finalizer_component (gfc_symbol *derived)
gfc_component *c;
for (c = derived->components; c; c = c->next)
- if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable)
+ if (c->ts.type == BT_DERIVED && !c->attr.pointer && !c->attr.allocatable
+ && c->attr.flavor != FL_PROCEDURE)
{
if (c->ts.u.derived->f2k_derived
&& c->ts.u.derived->f2k_derived->finalizers)
@@ -1059,7 +1060,8 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
{
/* Call FINAL_WRAPPER (comp); */
gfc_code *final_wrap;
- gfc_symbol *vtab;
+ gfc_symbol *vtab, *byte_stride;
+ gfc_expr *scalar, *size_expr, *fini_coarray_expr;
gfc_component *c;
vtab = gfc_find_derived_vtab (comp->ts.u.derived);
@@ -1068,12 +1070,54 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
break;
gcc_assert (c);
+
+ /* Set scalar argument for storage_size. */
+ gfc_get_symbol ("comp_byte_stride", sub_ns, &byte_stride);
+ byte_stride->ts = e->ts;
+ byte_stride->attr.flavor = FL_VARIABLE;
+ byte_stride->attr.value = 1;
+ byte_stride->attr.artificial = 1;
+ gfc_set_sym_referenced (byte_stride);
+ gfc_commit_symbol (byte_stride);
+ scalar = gfc_lval_expr_from_sym (byte_stride);
+
final_wrap = gfc_get_code (EXEC_CALL);
final_wrap->symtree = c->initializer->symtree;
final_wrap->resolved_sym = c->initializer->symtree->n.sym;
final_wrap->ext.actual = gfc_get_actual_arglist ();
final_wrap->ext.actual->expr = e;
+ /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */
+ size_expr = gfc_get_expr ();
+ size_expr->where = gfc_current_locus;
+ size_expr->expr_type = EXPR_OP;
+ size_expr->value.op.op = INTRINSIC_DIVIDE;
+
+ /* STORAGE_SIZE (array,kind=c_intptr_t). */
+ size_expr->value.op.op1
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+ "storage_size", gfc_current_locus, 2,
+ scalar,
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0));
+
+ /* NUMERIC_STORAGE_SIZE. */
+ size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+ gfc_character_storage_size);
+ size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+ size_expr->ts = size_expr->value.op.op1->ts;
+
+ /* Which provides the argument 'byte_stride'..... */
+ final_wrap->ext.actual->next = gfc_get_actual_arglist ();
+ final_wrap->ext.actual->next->expr = size_expr;
+
+ /* ...and last of all the 'fini_coarray' argument. */
+ fini_coarray_expr = gfc_lval_expr_from_sym (fini_coarray);
+ final_wrap->ext.actual->next->next = gfc_get_actual_arglist ();
+ final_wrap->ext.actual->next->next->expr = fini_coarray_expr;
+
+
+
if (*code)
{
(*code)->next = final_wrap;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 43eeefee07f..e4b60a44a59 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -10512,6 +10512,10 @@ resolve_where (gfc_code *code, gfc_expr *mask)
if (e && !resolve_where_shape (cnext->expr1, e))
gfc_error ("WHERE assignment target at %L has "
"inconsistent shape", &cnext->expr1->where);
+
+ if (cnext->op == EXEC_ASSIGN)
+ cnext->expr1->must_finalize = 1;
+
break;
@@ -10599,6 +10603,10 @@ gfc_resolve_where_code_in_forall (gfc_code *code, int nvar,
/* WHERE assignment statement */
case EXEC_ASSIGN:
gfc_resolve_assign_in_forall (cnext, nvar, var_expr);
+
+ if (cnext->op == EXEC_ASSIGN)
+ cnext->expr1->must_finalize = 1;
+
break;
/* WHERE operator assignment statement */
@@ -10645,6 +10653,10 @@ gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr)
case EXEC_ASSIGN:
case EXEC_POINTER_ASSIGN:
gfc_resolve_assign_in_forall (c, nvar, var_expr);
+
+ if (c->op == EXEC_ASSIGN)
+ c->expr1->must_finalize = 1;
+
break;
case EXEC_ASSIGN_CALL:
@@ -12069,6 +12081,9 @@ start:
&& code->expr1->ts.u.derived->attr.defined_assign_comp)
generate_component_assignments (&code, ns);
+ if (code->op == EXEC_ASSIGN)
+ code->expr1->must_finalize = 1;
+
break;
case EXEC_LABEL_ASSIGN:
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a77f3318846..e06b8ba4eb2 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -994,9 +994,9 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp))
{
gcc_assert (expr->ts.type == BT_CHARACTER);
-
+
tmp = gfc_get_character_len_in_bytes (tmp);
-
+
if (tmp == NULL_TREE || integer_zerop (tmp))
{
tree bs;
@@ -1007,7 +1007,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
tmp = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, tmp, bs);
}
-
+
tmp = (tmp && !integer_zerop (tmp))
? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE);
}
@@ -5657,7 +5657,12 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_se se;
int n;
- type = TREE_TYPE (descriptor);
+ if (expr->ts.type == BT_CLASS
+ && expr3_desc != NULL_TREE
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (expr3_desc)))
+ type = TREE_TYPE (expr3_desc);
+ else
+ type = TREE_TYPE (descriptor);
stride = gfc_index_one_node;
offset = gfc_index_zero_node;
@@ -7478,7 +7483,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (!se->direct_byref)
se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-
+
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
@@ -8922,7 +8927,7 @@ static gfc_actual_arglist *pdt_param_list;
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
tree dest, int rank, int purpose, int caf_mode,
- gfc_co_subroutines_args *args)
+ gfc_co_subroutines_args *args, bool no_finalization)
{
gfc_component *c;
gfc_loopinfo loop;
@@ -9010,11 +9015,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_conv_array_data (dest));
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank,
- COPY_ALLOC_COMP, caf_mode, args);
+ COPY_ALLOC_COMP, caf_mode, args,
+ no_finalization);
}
else
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
gfc_add_expr_to_block (&loopbody, tmp);
@@ -9048,13 +9054,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_PDT_COMP, 0, args);
+ DEALLOCATE_PDT_COMP, 0, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp)
{
tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- NULLIFY_ALLOC_COMP, 0, args);
+ NULLIFY_ALLOC_COMP, 0, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
@@ -9112,7 +9120,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
}
else
{
@@ -9120,7 +9128,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
@@ -9216,8 +9225,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
continue;
}
- if ((c->ts.type == BT_DERIVED && !c->attr.pointer)
- || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))
+ if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer)
+ || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)))
/* Call the finalizer, which will free the memory and nullify the
pointer of an array. */
deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c,
@@ -9245,7 +9254,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated
= structure_alloc_comps (CLASS_DATA (c)->ts.u.derived,
comp, NULL_TREE, rank, purpose,
- caf_mode, args);
+ caf_mode, args, no_finalization);
}
else
{
@@ -9253,7 +9262,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, NULL_TREE,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
}
@@ -9551,7 +9561,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
decl, cdecl, NULL_TREE);
rank = c->as ? c->as->rank : 0;
tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE,
- rank, purpose, caf_mode, args);
+ rank, purpose, caf_mode, args,
+ no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
break;
@@ -9587,7 +9598,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
rank, purpose, caf_mode
| GFC_STRUCTURE_CAF_MODE_IN_COARRAY,
- args);
+ args, no_finalization);
gfc_add_expr_to_block (&fnblock, tmp);
}
}
@@ -9695,7 +9706,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, dcmp,
rank, purpose,
- caf_mode, args);
+ caf_mode, args,
+ no_finalization);
}
else
add_when_allocated = NULL_TREE;
@@ -10068,7 +10080,8 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
NULLIFY_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+ NULL, false);
}
@@ -10081,7 +10094,8 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank,
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
DEALLOCATE_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode,
+ NULL, false);
}
tree
@@ -10119,7 +10133,8 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
tmp = structure_alloc_comps (derived, array, NULL_TREE, rank,
BCAST_ALLOC_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+ &args, false);
return tmp;
}
@@ -10129,10 +10144,12 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank,
status of coarrays. */
tree
-gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank)
+gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank,
+ bool no_finalization)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_ALLOC_COMP, 0, NULL);
+ DEALLOCATE_ALLOC_COMP, 0, NULL,
+ no_finalization);
}
@@ -10140,7 +10157,8 @@ tree
gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest)
{
return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP,
- GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL);
+ GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY,
+ NULL, false);
}
@@ -10152,7 +10170,7 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank,
int caf_mode)
{
return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP,
- caf_mode, NULL);
+ caf_mode, NULL, false);
}
@@ -10163,7 +10181,7 @@ tree
gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
{
return structure_alloc_comps (der_type, decl, dest, rank,
- COPY_ONLY_ALLOC_COMP, 0, NULL);
+ COPY_ONLY_ALLOC_COMP, 0, NULL, false);
}
@@ -10178,7 +10196,7 @@ gfc_allocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank,
gfc_actual_arglist *old_param_list = pdt_param_list;
pdt_param_list = param_list;
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- ALLOCATE_PDT_COMP, 0, NULL);
+ ALLOCATE_PDT_COMP, 0, NULL, false);
pdt_param_list = old_param_list;
return res;
}
@@ -10190,7 +10208,7 @@ tree
gfc_deallocate_pdt_comp (gfc_symbol * der_type, tree decl, int rank)
{
return structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- DEALLOCATE_PDT_COMP, 0, NULL);
+ DEALLOCATE_PDT_COMP, 0, NULL, false);
}
@@ -10205,7 +10223,7 @@ gfc_check_pdt_dummy (gfc_symbol * der_type, tree decl, int rank,
gfc_actual_arglist *old_param_list = pdt_param_list;
pdt_param_list = param_list;
res = structure_alloc_comps (der_type, decl, NULL_TREE, rank,
- CHECK_PDT_DUMMY, 0, NULL);
+ CHECK_PDT_DUMMY, 0, NULL, false);
pdt_param_list = old_param_list;
return res;
}
@@ -10926,7 +10944,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
&& expr1->ts.u.derived->attr.alloc_comp)
{
tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc,
- expr1->rank);
+ expr1->rank, true);
gfc_add_expr_to_block (&realloc_block, tmp);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 04fee617590..3aae4d2c4eb 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -56,7 +56,8 @@ tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int, int cm = 0);
tree gfc_bcast_alloc_comp (gfc_symbol *, gfc_expr *, int, tree,
tree, tree, tree);
-tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int);
+tree gfc_deallocate_alloc_comp_no_caf (gfc_symbol *, tree, int,
+ bool no_finalization = false);
tree gfc_reassign_alloc_comp_caf (gfc_symbol *, tree, tree);
tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int, int);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2e15a7e874c..e666c41517b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -7675,9 +7675,58 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Allocatable scalar function results must be freed and nullified
after use. This necessitates the creation of a temporary to
hold the result to prevent duplicate calls. */
+ bool allocatable = comp ? comp->attr.allocatable
+ && !comp->attr.dimension
+ : sym->attr.allocatable
+ && !sym->attr.dimension;
+ bool finalizable = comp ? comp->ts.type == BT_DERIVED
+ && gfc_is_finalizable (comp->ts.u.derived, NULL)
+ : sym->ts.type == BT_DERIVED
+ && gfc_is_finalizable (sym->ts.u.derived, NULL);
+ if (!byref && finalizable)
+ {
+ tree vptr, final_fndecl, desc;
+ gfc_symbol *vtab;
+ gfc_se post_se;
+ tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
+ gfc_add_modify (&se->pre, tmp, se->expr);
+ se->expr = tmp;
+ tmp = gfc_evaluate_now (se->expr, &se->pre);
+ gfc_add_expr_to_block (&se->pre,
+ gfc_copy_alloc_comp (comp ? comp->ts.u.derived
+ : sym->ts.u.derived,
+ se->expr, tmp, 0, 0));
+ vtab = comp ? gfc_find_derived_vtab (comp->ts.u.derived)
+ : gfc_find_derived_vtab (sym->ts.u.derived);
+ if (vtab->backend_decl == NULL_TREE)
+ vptr = gfc_get_symbol_decl (vtab);
+ else
+ vptr = vtab->backend_decl;
+ vptr = gfc_build_addr_expr (NULL, vptr);
+
+ final_fndecl = gfc_vptr_final_get (vptr);
+ final_fndecl = build_fold_indirect_ref_loc (input_location,
+ final_fndecl);
+ gfc_init_se (&post_se, NULL);
+ desc = gfc_conv_scalar_to_descriptor (&post_se, tmp,
+ comp ? comp->attr
+ : sym->attr);
+ gfc_add_expr_to_block (&post, gfc_finish_block (&post_se.pre));
+ desc = build_call_expr_loc (input_location,
+ final_fndecl, 3,
+ gfc_build_addr_expr (NULL, desc),
+ gfc_vptr_size_get (vptr),
+ boolean_false_node);
+ gfc_add_expr_to_block (&post, desc);
+ if (allocatable)
+ {
+ tmp = gfc_call_free (tmp);
+ gfc_add_expr_to_block (&post, tmp);
+ }
+ }
+
if (!byref && sym->ts.type != BT_CHARACTER
- && ((sym->attr.allocatable && !sym->attr.dimension && !comp)
- || (comp && comp->attr.allocatable && !comp->attr.dimension)))
+ && allocatable && !finalizable)
{
tmp = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, tmp, se->expr);
@@ -10430,7 +10479,8 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
if (dealloc)
{
tmp_var = gfc_evaluate_now (lse->expr, &lse->pre);
- tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var, 0);
+ tmp = gfc_deallocate_alloc_comp_no_caf (ts.u.derived, tmp_var,
+ 0, true);
if (deep_copy)
tmp = build3_v (COND_EXPR, cond, build_empty_stmt (input_location),
tmp);
@@ -11387,6 +11437,89 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
}
+ /* F2018 (7.5.6.3): "When an intrinsic assignment statement is executed
+ (10.2.1.3), if the variable is not an unallocated allocatable variable,
+ it is finalized after evaluation of expr and before the definition of
+ the variable. If the variable is an allocated allocatable variable, or
+ has an allocated allocatable subobject, that would be deallocated by
+ intrinsic assignment, the finalization occurs before the deallocation */
+
+static tree
+gfc_assignment_finalizer_call (gfc_expr *expr1, bool init_flag)
+{
+ stmtblock_t final_block;
+ gfc_init_block (&final_block);
+ symbol_attribute lhs_attr;
+ tree final_expr;
+ tree ptr;
+ tree cond;
+ gfc_se se;
+
+ /* We have to exclude vtable procedures (_copy and _final especially), uses
+ of gfc_trans_assignment_1 in initialization and allocation before trying
+ to build a final call. */
+ if (!expr1->must_finalize
+ || expr1->symtree->n.sym->attr.artificial
+ || expr1->symtree->n.sym->ns->proc_name->attr.artificial
+ || init_flag)
+ return NULL_TREE;
+
+ if (!(expr1->ts.type == BT_CLASS
+ || (expr1->ts.type == BT_DERIVED
+ && gfc_is_finalizable (expr1->ts.u.derived, NULL)))
+ || !gfc_add_finalizer_call (&final_block, expr1))
+ return NULL_TREE;
+
+ lhs_attr = gfc_expr_attr (expr1);
+
+ /* Check allocatable/pointer is allocated/associated. */
+ if (lhs_attr.allocatable || lhs_attr.pointer)
+ {
+ if (expr1->ts.type == BT_CLASS)
+ {
+ ptr = gfc_get_class_from_gfc_expr (expr1);
+ gcc_assert (ptr != NULL_TREE);
+ ptr = gfc_class_data_get (ptr);
+ if (lhs_attr.dimension)
+ ptr = gfc_conv_descriptor_data_get (ptr);
+ }
+ else
+ {
+ gfc_init_se (&se, NULL);
+ if (expr1->rank)
+ {
+ gfc_conv_expr_descriptor (&se, expr1);
+ ptr = gfc_conv_descriptor_data_get (se.expr);
+ }
+ else
+ {
+ gfc_conv_expr (&se, expr1);
+ ptr = gfc_build_addr_expr (NULL_TREE, se.expr);
+ }
+ }
+
+ cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ ptr, build_zero_cst (TREE_TYPE (ptr)));
+ final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, gfc_finish_block (&final_block),
+ build_empty_stmt (input_location));
+ }
+ else
+ final_expr = gfc_finish_block (&final_block);
+
+ /* Check optional present. */
+ if (expr1->symtree->n.sym->attr.optional)
+ {
+ cond = gfc_conv_expr_present (expr1->symtree->n.sym);
+ final_expr = build3_loc (input_location, COND_EXPR, void_type_node,
+ cond, final_expr,
+ build_empty_stmt (input_location));
+ }
+
+ return final_expr;
+}
+
+
static tree
trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
@@ -11394,6 +11527,16 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
{
tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
vec<tree, va_gc> *args = NULL;
+ tree final_expr;
+
+ final_expr = gfc_assignment_finalizer_call (lhs, false);
+ if (final_expr != NULL_TREE)
+ {
+ if (rse->loop)
+ gfc_prepend_expr_to_block (&rse->loop->pre, final_expr);
+ else
+ gfc_add_expr_to_block (block, final_expr);
+ }
/* Store the old vptr so that dynamic types can be compared for
reallocation to occur or not. */
@@ -11519,6 +11662,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
}
}
+
/* Subroutine of gfc_trans_assignment that actually scalarizes the
assignment. EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
init_flag indicates initialization expressions and dealloc that no
@@ -11542,6 +11686,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
tree tmp;
stmtblock_t block;
stmtblock_t body;
+ tree final_expr;
bool l_is_temp;
bool scalar_to_array;
tree string_length;
@@ -11582,6 +11727,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
needed at two locations, so do it once only before the information is
needed. */
lhs_attr = gfc_expr_attr (expr1);
+
is_poly_assign = (use_vptr_copy || lhs_attr.pointer
|| (lhs_attr.allocatable && !lhs_attr.dimension))
&& (expr1->ts.type == BT_CLASS
@@ -11855,6 +12001,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
else
gfc_add_expr_to_block (&loop.post, tmp2);
}
+
+ expr1->must_finalize = 0;
}
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
@@ -11909,8 +12057,26 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
!(l_is_temp || init_flag) && dealloc,
expr1->symtree->n.sym->attr.codimension);
- /* Add the pre blocks to the body. */
- gfc_add_block_to_block (&body, &rse.pre);
+ /* Comply with F2018 (7.5.6.3). Make sure that any finalization code is added
+ after evaluation of the rhs and before reallocation. */
+ final_expr = gfc_assignment_finalizer_call (expr1, init_flag);
+ if (final_expr)
+ {
+ if (lss == gfc_ss_terminator)
+ {
+ gfc_add_block_to_block (&block, &rse.pre);
+ gfc_add_expr_to_block (&block, final_expr);
+ }
+ else
+ {
+ gfc_add_block_to_block (&body, &rse.pre);
+ gfc_add_expr_to_block (&loop.code[expr1->rank - 1], final_expr);
+ }
+ }
+ else
+ gfc_add_block_to_block (&body, &rse.pre);
+
+ /* Add the lse pre block to the body */
gfc_add_block_to_block (&body, &lse.pre);
gfc_add_expr_to_block (&body, tmp);
/* Add the post blocks to the body. */
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
index 92dc50756d4..de20a147842 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_25.f90
@@ -68,4 +68,4 @@ contains
end function func_foo_a
end program simple_leak
-! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } }
+! { dg-final { scan-tree-dump-times "\>_final" 4 "original" } }
[-- Attachment #3: finalize_38.f90 --]
[-- Type: text/x-fortran, Size: 5940 bytes --]
! { dg-do run }
!
! Test finalization on intrinsic assignment (F2018 (7.5.6.3))
!
module testmode
implicit none
type :: simple
integer :: ind
contains
final :: destructor1, destructor2
end type simple
type, extends(simple) :: complicated
real :: rind
contains
final :: destructor3, destructor4
end type complicated
integer :: check_scalar
integer :: check_array(4)
real :: check_real
real :: check_rarray(4)
integer :: final_count = 0
contains
subroutine destructor1(self)
type(simple), intent(inout) :: self
check_scalar = self%ind
check_array = 0
final_count = final_count + 1
end subroutine destructor1
subroutine destructor2(self)
type(simple), intent(inout) :: self(:)
check_scalar = 0
check_array(1:size(self, 1)) = self%ind
final_count = final_count + 1
end subroutine destructor2
subroutine destructor3(self)
type(complicated), intent(inout) :: self
check_real = self%rind
check_array = 0.0
final_count = final_count + 1
end subroutine destructor3
subroutine destructor4(self)
type(complicated), intent(inout) :: self(:)
check_real = 0.0
check_rarray(1:size(self, 1)) = self%rind
final_count = final_count + 1
end subroutine destructor4
function constructor1(ind) result(res)
type(simple), allocatable :: res
integer, intent(in) :: ind
allocate (res, source = simple (ind))
end function constructor1
function constructor2(ind, rind) result(res)
class(simple), allocatable :: res(:)
integer, intent(in) :: ind(:)
real, intent(in), optional :: rind(:)
type(complicated), allocatable :: src(:)
integer :: sz
integer :: i
if (present (rind)) then
sz = min (size (ind, 1), size (rind, 1))
src = [(complicated (ind(i), rind(i)), i = 1, sz)]
allocate (res, source = src)
else
sz = size (ind, 1)
allocate (res, source = [(simple (ind(i)), i = 1, sz)])
end if
end function constructor2
subroutine test (cnt, scalar, array, off, rind, rarray)
integer :: cnt
integer :: scalar
integer :: array(:)
integer :: off
real, optional :: rind
real, optional :: rarray(:)
if (final_count .ne. cnt) stop 1 + off
if (check_scalar .ne. scalar) stop 2 + off
if (any (check_array(1:size (array, 1)) .ne. array)) stop 3 + off
if (present (rind)) then
if (check_real .ne. rind) stop 4 + off
end if
if (present (rarray)) then
if (any (check_rarray(1:size (rarray, 1)) .ne. rarray)) stop 5 + off
end if
end subroutine test
end module testmode
program test_final
use testmode
implicit none
type(simple), allocatable :: MyType, MyType2
type(simple), allocatable :: MyTypeArray(:)
type(simple) :: ThyType = simple(21), ThyType2 = simple(22)
class(simple), allocatable :: MyClass
class(simple), allocatable :: MyClassArray(:)
! ************************
! Derived type assignments
! ************************
! Since MyType is not allocated there should be no final call because
! there is nothing to finalize; ie. MyType is nullified on entry to scope.
MyType = ThyType
! ifort triggers this with final_count = 1 and ind = 0.
call test(0, 0, [0,0], 0)
if (.not. allocated(MyType)) allocate(MyType)
allocate(MyType2)
MyType%ind = 1
MyType2%ind = 2
! This should result in a final call with self = simple(1).
MyType = MyType2
call test(1, 1, [0,0], 10)
allocate(MyTypeArray(2))
MyTypeArray%ind = [42, 43]
! This should result in a final call with self = [simple(42),simple(43)].
MyTypeArray = [ThyType, ThyType2]
call test(2, 0, [42,43], 20)
! This should result in a final call with self = initialization = simple(22).
ThyType2 = simple(99)
call test(3, 22, [0,0], 30)
! This should result in a final call with self = simple(22).
ThyType = ThyType2
call test(4, 21, [0,0], 40)
! This should result in two final calls; the last is for self2 = simple(2).
deallocate (MyType, MyType2)
call test(6, 2, [0,0], 50)
! This should result in one final call; MyTypeArray = [simple(21),simple(22)].
deallocate (MyTypeArray)
call test(7, 0, [21,22], 60)
! Check that rhs function expressions do not interfere with finalization.
! The lhs is finalized before assignment.
! The function result is finalized after the assignment.
allocate (MyType, source = simple (11))
MyType = constructor1 (99)
call test(9, 99, [0,0], 70)
deallocate (MyType)
! *****************
! Class assignments
! *****************
final_count = 0
allocate (MyClass, source = simple (3))
! This should result in a final call with the allocated value.
MyClass = simple (4)
call test(1, 3, [0,0], 100)
! This should result in a final call with the assigned value.
deallocate (MyClass)
call test(2, 4, [0,0], 110)
allocate (MyClassArray, source = [simple (5), simple (6)])
! Make sure that there is no final call.
call test(2, 4, [0,0], 120)
MyClassArray = [simple (7), simple (8)]
! The final call should return the allocated value.
call test(3, 0, [5,6], 130)
! This should result in a final call with the assigned value.
deallocate (MyClassArray)
call test(4, 0, [7,8], 140)
! This should produce no final calls.
allocate (MyClassArray, source = [complicated(1, 2.0),complicated(3, 4.0)])
! This should produce calls to destructor4 then destructor2.
deallocate (MyClassArray)
! ifort correctly calls the rank 1 finalizer for the extended type
! but then calls the parent type finalizer for each element.
call test(6, 0, [1, 3], 150, rarray = [2.0, 4.0])
! Since 'constructor2; must finalize 'src' after the finalization of
! 'MyClassArray', the result in 'check_array' should be [10,20].
MyClassArray = constructor2 ([10,20], [10.0,20.0])
call test(10, 0, [10,20], 160, rarray = [10.0,20.0])
deallocate (MyClassArray)
call test(12, 0, [10, 20], 170, rarray = [10.0,20.0])
end program test_final
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2022-01-17 11:57 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-01-14 16:20 [Patch, fortran] PR64290 - [F03] No finalization at deallocation of LHS Paul Richard Thomas
2022-01-17 11:57 Paul Richard Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).