Thanks, Harald! On Sun, 9 Nov 2025 22:57:29 +0100 Harald Anlauf <[email protected]> wrote:
> Am 08.11.25 um 18:03 schrieb Jerry D: > > On 11/7/25 8:30 PM, Christopher Albert wrote: > >> 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. > > > > --- snip --- > > > > Applies and test OK here. I want to see if any one else has any > > comments. > > > > Jerry > > > > Albert, > > I did see the patch with commit messages inlined, not attached. > Hope this did not lead me to wrong observations. I attach now an updated patch (still not used to the process). > The commit message is not properly formed here; there should not > be <TAB><SPACE><SPACE> for continuation lines, just <TAB>. > Trying to push would lead to a rejection by the filters. Thanks for pointing that out, this is fixed. > Regarding the run-time testcases: while writing to stdout and > checking the output with a pattern works, also please consider > the alternative > "if (result /= expected) stop n" > where you think it is appropriate (e.g. the total finalization count) > and where it may make the testcase easier to read for others. > (Not critical, though). > > I modified testcase finalizer_self_assign.f90 slightly by replacing > the self-assignment > > a = a > > by > > a = (a) > > and get a runtime failure: > > ERROR: a%next deallocated > ERROR STOP 1 > > with a traceback from the ERROR STOP. That case might need a > different treatment, maybe a temporary, to be able keep the nested > components. Can you have a further look? > > If you do not find a simple fix, we might proceed and track this > issue either in the existing PR or move it to a different one. > (NAG and Intel seem to get this variant right.) Found a simple fix, should work now. Hope this is clean enough. > Thanks, > Harald > > Best, Chris
>From 1f0bcc08ee292486c390f68126642a1cfc5caaa7 Mon Sep 17 00:00:00 2001 From: Christopher Albert <[email protected]> Date: Fri, 7 Nov 2025 12:41:42 +0100 Subject: [PATCH] fortran: Fix ICE and self-assignment bugs with recursive allocatable finalizers [PR90519] 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. This patch adds detection using gfc_dep_compare_expr at compile time and pointer comparison at runtime to skip finalization when lhs == rhs. Parenthesized self-assignment (a = (a)) creates a temporary, defeating the simple self-assignment detection. This patch adds strip_parentheses() to look through INTRINSIC_PARENTHESES operators and ensure deep_copy is enabled for such cases. Test pr112459.f90 now expects 6 _final calls instead of 12 because separate result symbols eliminate double-counting in tree dumps. PR fortran/90519 gcc/fortran/ChangeLog: * trans-expr.cc (strip_parentheses): New helper function to strip INTRINSIC_PARENTHESES operators from expressions. (is_runtime_conformable): Use strip_parentheses to handle cases like a = (a) when checking for self-assignment. (gfc_trans_assignment_1): Strip parentheses before checking if expr2 is a variable, ensuring deep_copy is enabled for cases like a = (a). Also strip parentheses when checking for self-assignment to avoid use-after-free in finalization. (gfc_trans_scalar_assign): Add comment about parentheses handling. * 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. gcc/testsuite/ChangeLog: * 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 including a = a, a = (a), and a = (((a))) cases using if/stop pattern. * 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 | 25 ++++++- gcc/fortran/trans-expr.cc | 60 ++++++++++++--- .../finalizer_recursive_alloc_1.f90 | 15 ++++ .../finalizer_recursive_alloc_2.f90 | 32 ++++++++ .../gfortran.dg/finalizer_self_assign.f90 | 74 +++++++++++++++++++ gcc/testsuite/gfortran.dg/pr112459.f90 | 4 +- 6 files changed, 196 insertions(+), 14 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..079240cd2df 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,26 @@ 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 instead of using final->result = final. + Self-referencing result symbols (final->result = final) create a cycle + in the symbol structure that causes an ICE in gimplify_call_expr when + the finalizer wrapper is used as a procedure pointer initializer. */ + 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 +1980,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..b87c935a703 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, @@ -12683,12 +12693,30 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, to make sure we do not check for reallocation unneccessarily. */ +/* Strip parentheses from an expression to get the underlying variable. + This is needed for self-assignment detection since (a) creates a + parentheses operator node. */ + +static gfc_expr * +strip_parentheses (gfc_expr *expr) +{ + while (expr->expr_type == EXPR_OP + && expr->value.op.op == INTRINSIC_PARENTHESES) + expr = expr->value.op.op1; + return expr; +} + + static bool is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) { gfc_actual_arglist *a; gfc_expr *e1, *e2; + /* Strip parentheses to handle cases like a = (a). */ + expr1 = strip_parentheses (expr1); + expr2 = strip_parentheses (expr2); + switch (expr2->expr_type) { case EXPR_VARIABLE: @@ -13390,10 +13418,15 @@ 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. + Strip parentheses from both sides to handle cases like a = (a). */ 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 (strip_parentheses (expr1), + strip_parentheses (expr2)) != 0 + && !(strip_parentheses (expr2)->expr_type == EXPR_VARIABLE + && strip_parentheses (expr2)->symtree->n.sym->attr.artificial)) { if (lss == gfc_ss_terminator) { @@ -13416,13 +13449,18 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* If nothing else works, do it the old fashioned way! */ if (tmp == NULL_TREE) - tmp - = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, - gfc_expr_is_variable (expr2) || scalar_to_array - || expr2->expr_type == EXPR_ARRAY, - !(l_is_temp || init_flag) && dealloc, - expr1->symtree->n.sym->attr.codimension, - assoc_assign); + { + /* Strip parentheses to detect cases like a = (a) which need deep_copy. */ + gfc_expr *expr2_stripped = strip_parentheses (expr2); + tmp + = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, + gfc_expr_is_variable (expr2_stripped) + || scalar_to_array + || expr2->expr_type == EXPR_ARRAY, + !(l_is_temp || init_flag) && dealloc, + expr1->symtree->n.sym->attr.codimension, + assoc_assign); + } /* Add the lse pre block to the body */ gfc_add_block_to_block (&body, &lse.pre); 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..c970044c4e8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/finalizer_self_assign.f90 @@ -0,0 +1,74 @@ +! { dg-do run } +! Test self-assignment with recursive allocatable and finalizer +! This should preserve allocatable components after a = a and 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 + + call test_simple_self_assign() + call test_parenthesized_self_assign() + call test_triple_parenthesized_self_assign() + +contains + + subroutine test_simple_self_assign() + type(node_t) :: a + + a%value = 100 + allocate(a%next) + a%next%value = 200 + + ! Simple self-assignment should preserve all components + a = a + + if (a%value /= 100) stop 1 + if (.not. allocated(a%next)) stop 2 + if (a%next%value /= 200) stop 3 + end subroutine test_simple_self_assign + + subroutine test_parenthesized_self_assign() + type(node_t) :: a + + a%value = 100 + allocate(a%next) + a%next%value = 200 + + ! Parenthesized self-assignment should also preserve all components + a = (a) + + if (a%value /= 100) stop 4 + if (.not. allocated(a%next)) stop 5 + if (a%next%value /= 200) stop 6 + end subroutine test_parenthesized_self_assign + + subroutine test_triple_parenthesized_self_assign() + type(node_t) :: a + + a%value = 100 + allocate(a%next) + a%next%value = 200 + + ! Triple-nested parentheses should also work correctly + a = (((a))) + + if (a%value /= 100) stop 7 + if (.not. allocated(a%next)) stop 8 + if (a%next%value /= 200) stop 9 + end subroutine test_triple_parenthesized_self_assign + +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
