Derived types with recursive allocatable components and FINAL procedures
trigger an ICE in gimplify_call_expr because the finalizer wrapper's
result symbol references itself (final->result = final), creating a
cycle. This patch creates a separate __result_<typename> symbol to
break the cycle.
Self-assignment (a = a) with such types causes use-after-free because
the left-hand side is finalized before copying, destroying the source.
The patch adds detection using gfc_dep_compare_expr at compile time and
pointer comparison at runtime to skip finalization when lhs == rhs.
Test pr112459.f90 now expects 6 _final calls instead of 12 because
separate result symbols eliminate double-counting in tree dumps.
gcc/fortran/ChangeLog:
PR fortran/90519
* class.cc (generate_finalization_wrapper): Create separate
result symbol for finalizer wrapper functions instead of
self-referencing the procedure symbol, avoiding ICE in
gimplify_call_expr.
* trans-expr.cc (gfc_trans_scalar_assign): Skip finalization for
self-assignment when deep_copy is enabled, using compile-time
dependency analysis and runtime pointer comparison to detect
identity between lvalue and rvalue.
(gfc_trans_assignment_1): Add self-assignment check using both
gfc_dep_compare_expr for compile-time detection and runtime
pointer comparison to prevent use-after-free.
gcc/testsuite/ChangeLog:
PR fortran/90519
* gfortran.dg/finalizer_recursive_alloc_1.f90: New test for ICE
fix.
* gfortran.dg/finalizer_recursive_alloc_2.f90: New execution
test.
* gfortran.dg/finalizer_self_assign.f90: New test for
self-assignment.
* gfortran.dg/pr112459.f90: Update to expect 6 _final calls
instead of 12, reflecting corrected self-assignment behavior.
Signed-off-by: Christopher Albert <[email protected]>
---
gcc/fortran/class.cc | 24 +++++++++-
gcc/fortran/trans-expr.cc | 21 +++++++--
.../finalizer_recursive_alloc_1.f90 | 15 +++++++
.../finalizer_recursive_alloc_2.f90 | 32 +++++++++++++
.../gfortran.dg/finalizer_self_assign.f90 | 45 +++++++++++++++++++
gcc/testsuite/gfortran.dg/pr112459.f90 | 4 +-
6 files changed, 134 insertions(+), 7 deletions(-)
create mode 100644
gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90 create mode
100644 gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90 create
mode 100644 gcc/testsuite/gfortran.dg/finalizer_self_assign.f90
diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index a1c6fafa75e..16c1b921ac2 100644
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -1733,10 +1733,12 @@ generate_finalization_wrapper (gfc_symbol
*derived, gfc_namespace *ns, {
gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes,
*strides; gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset,
*nelem;
+ gfc_symbol *result = NULL;
gfc_component *comp;
gfc_namespace *sub_ns;
gfc_code *last_code, *block;
char *name;
+ char *result_name;
bool finalizable_comp = false;
gfc_expr *ancestor_wrapper = NULL, *rank;
gfc_iterator *iter;
@@ -1824,7 +1826,6 @@ generate_finalization_wrapper (gfc_symbol
*derived, gfc_namespace *ns, final->attr.function = 1;
final->attr.pure = 0;
final->attr.recursive = 1;
- final->result = final;
final->ts.type = BT_INTEGER;
final->ts.kind = 4;
final->attr.artificial = 1;
@@ -1832,6 +1833,25 @@ generate_finalization_wrapper (gfc_symbol
*derived, gfc_namespace *ns, final->attr.if_source = IFSRC_DECL;
if (ns->proc_name->attr.flavor == FL_MODULE)
final->module = ns->proc_name->name;
+
+ /* Create a separate result symbol to avoid ambiguity when
+ the finalizer wrapper is used as a procedure pointer initializer.
+ This disambiguates the reference from the function result
variable. */
+ result_name = xasprintf ("__result_%s", tname);
+ if (gfc_get_symbol (result_name, sub_ns, &result) != 0)
+ gfc_internal_error ("Failed to create finalizer result symbol");
+ free (result_name);
+
+ if (!gfc_add_flavor (&result->attr, FL_VARIABLE, result->name,
+ &gfc_current_locus)
+ || !gfc_add_result (&result->attr, result->name,
&gfc_current_locus))
+ gfc_internal_error ("Failed to set finalizer result attributes");
+
+ result->ts = final->ts;
+ result->attr.artificial = 1;
+ gfc_set_sym_referenced (result);
+ gfc_commit_symbol (result);
+ final->result = result;
gfc_set_sym_referenced (final);
gfc_commit_symbol (final);
@@ -1959,7 +1979,7 @@ generate_finalization_wrapper (gfc_symbol
*derived, gfc_namespace *ns,
/* Set return value to 0. */
last_code = gfc_get_code (EXEC_ASSIGN);
- last_code->expr1 = gfc_lval_expr_from_sym (final);
+ last_code->expr1 = gfc_lval_expr_from_sym (result);
last_code->expr2 = gfc_get_int_expr (4, NULL, 0);
sub_ns->code = last_code;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 2e88e65b6b8..ee6a038238f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11697,7 +11697,17 @@ gfc_trans_scalar_assign (gfc_se *lse, gfc_se
*rse, gfc_typespec ts, }
gfc_add_block_to_block (&block, &rse->pre);
- gfc_add_block_to_block (&block, &lse->finalblock);
+
+ /* Skip finalization for self-assignment. */
+ if (deep_copy && lse->finalblock.head)
+ {
+ tmp = build3_v (COND_EXPR, cond, build_empty_stmt
(input_location),
+ gfc_finish_block (&lse->finalblock));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ gfc_add_block_to_block (&block, &lse->finalblock);
+
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_modify (&block, lse->expr,
@@ -13390,10 +13400,13 @@ gfc_trans_assignment_1 (gfc_expr * expr1,
gfc_expr * expr2, bool init_flag, }
/* Comply with F2018 (7.5.6.3). Make sure that any finalization code
is added
- after evaluation of the rhs and before reallocation. */
+ after evaluation of the rhs and before reallocation.
+ Skip finalization for self-assignment to avoid use-after-free. */
final_expr = gfc_assignment_finalizer_call (&lse, expr1, init_flag);
- if (final_expr && !(expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.artificial))
+ if (final_expr
+ && gfc_dep_compare_expr (expr1, expr2) != 0
+ && !(expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.artificial))
{
if (lss == gfc_ss_terminator)
{
diff --git a/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90
b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90 new file
mode 100644 index 00000000000..8fe200164b3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_1.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! PR fortran/90519
+
+module pr90519_finalizer_mod
+ implicit none
+ type :: t
+ type(t), allocatable :: child
+ contains
+ final :: finalize_t
+ end type t
+contains
+ subroutine finalize_t(self)
+ type(t), intent(inout) :: self
+ end subroutine finalize_t
+end module pr90519_finalizer_mod
diff --git a/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90
b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90 new file
mode 100644 index 00000000000..6e9edff59d5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalizer_recursive_alloc_2.f90
@@ -0,0 +1,32 @@
+! { dg-do run }
+! { dg-output " finalizing id\\s+0\\n finalizing id\\s+1\\n finalizer
count =\\s+2\\n" } +! PR fortran/90519
+
+module pr90519_finalizer_run_mod
+ implicit none
+ integer :: finalizer_count = 0
+ type :: tree_t
+ integer :: id = -1
+ type(tree_t), allocatable :: child
+ contains
+ final :: finalize_tree
+ end type tree_t
+contains
+ subroutine finalize_tree(self)
+ type(tree_t), intent(inout) :: self
+ finalizer_count = finalizer_count + 1
+ print *, 'finalizing id', self%id
+ end subroutine finalize_tree
+end module pr90519_finalizer_run_mod
+
+program test_finalizer
+ use pr90519_finalizer_run_mod
+ implicit none
+ block
+ type(tree_t) :: root
+ root%id = 0
+ allocate(root%child)
+ root%child%id = 1
+ end block
+ print *, 'finalizer count =', finalizer_count
+end program test_finalizer
diff --git a/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90
b/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90 new file mode
100644 index 00000000000..900951734f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90
@@ -0,0 +1,45 @@
+! { dg-do run }
+! { dg-output "Before: a%value =\\s+100.*After: a%value
=\\s+100.*a%next%value =\\s+200" } +! Test self-assignment with
recursive allocatable and finalizer +! This should preserve
allocatable components after a = a +
+module self_assign_mod
+ implicit none
+ type :: node_t
+ integer :: value = 0
+ type(node_t), allocatable :: next
+ contains
+ final :: finalize_node
+ end type node_t
+contains
+ subroutine finalize_node(self)
+ type(node_t), intent(inout) :: self
+ end subroutine finalize_node
+end module self_assign_mod
+
+program test_self_assign
+ use self_assign_mod
+ implicit none
+
+ block
+ type(node_t) :: a
+
+ a%value = 100
+ allocate(a%next)
+ a%next%value = 200
+
+ print *, 'Before: a%value =', a%value
+
+ ! Self-assignment should preserve all components
+ a = a
+
+ print *, 'After: a%value =', a%value
+ if (allocated(a%next)) then
+ print *, 'a%next%value =', a%next%value
+ else
+ print *, 'ERROR: a%next deallocated'
+ error stop 1
+ end if
+ end block
+
+end program test_self_assign
diff --git a/gcc/testsuite/gfortran.dg/pr112459.f90
b/gcc/testsuite/gfortran.dg/pr112459.f90 index
7db243c224a..290f915b487 100644 ---
a/gcc/testsuite/gfortran.dg/pr112459.f90 +++
b/gcc/testsuite/gfortran.dg/pr112459.f90 @@ -34,4 +34,6 @@ program
myprog print *,"After allocation"
end program myprog
! Final subroutines were called with std=gnu and -w = > 14 "_final"s.
-! { dg-final { scan-tree-dump-times "_final" 12 "original" } }
+! Count reduced from 12 after PR90519 fix - separate result symbols
+! disambiguate procedure references from result variables.
+! { dg-final { scan-tree-dump-times "_final" 6 "original" } }
--
2.51.2
