[gcc r16-8359] fortran: Give up reference factoring in case of shared tree [PR124661]
Mikael Morin
mikael@gcc.gnu.org
Tue Mar 31 13:34:57 GMT 2026
https://gcc.gnu.org/g:1c795ee4bc6b08f16cf1ad43acac47dc7c4b6b94
commit r16-8359-g1c795ee4bc6b08f16cf1ad43acac47dc7c4b6b94
Author: Mikael Morin <mikael@gcc.gnu.org>
Date: Tue Mar 31 15:34:29 2026 +0200
fortran: Give up reference factoring in case of shared tree [PR124661]
When we are about to create a variable to factor a subreference of an
array descriptor, check whether that subreference is shared with some of
the preliminary code and abort the factoring in that case.
In the example from the PR, the preliminary code contained bounds
checking code and the replacement of the subreferences by fresh
variables was causing those variables to be used before they were
defined in that bounds checking code.
PR fortran/121185
PR fortran/124661
gcc/fortran/ChangeLog:
* trans-array.cc (maybe_save_ref): New wrapper function around
save ref.
(set_factored_descriptor_value): Use the new wrapper function.
Add argument PRELIMINARY_CODE.
(gfc_conv_ss_descriptor): Update caller.
gcc/ChangeLog:
* tree-inline.cc (debug_find_tree, debug_find_tree_1): Move
and rename functions...
* tree.cc (find_tree, find_tree_1): ... here.
* tree-inline.h (debug_find_tree): Move renamed declaration...
* tree.h (find_tree): ... here.
gcc/testsuite/ChangeLog:
* gfortran.dg/bounds_check_28.f90: New test.
Co-authored-by: Christopher Albert <albert@tugraz.at>
Diff:
---
gcc/fortran/trans-array.cc | 37 +++++++++++---
gcc/testsuite/gfortran.dg/bounds_check_28.f90 | 70 +++++++++++++++++++++++++++
gcc/tree-inline.cc | 18 -------
gcc/tree-inline.h | 1 -
gcc/tree.cc | 20 ++++++++
gcc/tree.h | 3 ++
6 files changed, 123 insertions(+), 26 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a2da4fe7c7d5..4ab1d04440dc 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -3520,20 +3520,37 @@ save_ref (tree &code, tree &ref, vec<tree> &replacement_roots)
}
+/* If REF isn't shared with code in PREVIOUS_CODE, replace it with a fresh
+ variable in all of REPLACEMENT_ROOTS, appending extra code to CODE. */
+
+static void
+maybe_save_ref (tree &code, tree &ref, vec<tree> &replacement_roots,
+ stmtblock_t *previous_code)
+{
+ if (find_tree (previous_code->head, ref))
+ return;
+
+ save_ref (code, ref, replacement_roots);
+}
+
+
/* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before
- that, try to factor subexpressions of VALUE to variables, adding extra code
- to BLOCK.
+ that, try to create fresh variables to factor subexpressions of VALUE, if
+ those subexpressions aren't shared with code in PRELIMINARY_CODE. Add any
+ necessary additional code (initialization of variables typically) to BLOCK.
The candidate references to factoring are dereferenced pointers because they
are cheap to copy and array descriptors because they are often the base of
multiple subreferences. */
static void
-set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block)
+set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block,
+ stmtblock_t *preliminary_code)
{
/* As the reference is processed from outer to inner, variable definitions
will be generated in reversed order, so can't be put directly in BLOCK.
- We use TMP_BLOCK instead. */
+ We use temporary blocks instead, which we save in ACCUMULATED_CODE, and
+ only append to BLOCK at the end. */
tree accumulated_code = NULL_TREE;
/* The current candidate to factoring. */
@@ -3572,7 +3589,8 @@ set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block)
previous reference to save wasn't the current one, do save
it now. Otherwise drop it as we prefer saving the
pointer. */
- save_ref (accumulated_code, saveable_ref, replacement_roots);
+ maybe_save_ref (accumulated_code, saveable_ref,
+ replacement_roots, preliminary_code);
}
/* Don't evaluate the pointer to a variable yet; do it only if the
@@ -3602,7 +3620,8 @@ set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block)
if (saveable_ref != NULL_TREE)
/* We have seen a reference worth saving. Do it now. */
- save_ref (accumulated_code, saveable_ref, replacement_roots);
+ maybe_save_ref (accumulated_code, saveable_ref, replacement_roots,
+ preliminary_code);
if (TREE_CODE (data_ref) != ARRAY_REF)
break;
@@ -3635,8 +3654,12 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base)
gfc_init_se (&se, NULL);
se.descriptor_only = 1;
gfc_conv_expr_lhs (&se, ss_info->expr);
+ stmtblock_t tmp_block;
+ gfc_init_block (&tmp_block);
+ set_factored_descriptor_value (&info->descriptor, se.expr, &tmp_block,
+ &se.pre);
gfc_add_block_to_block (block, &se.pre);
- set_factored_descriptor_value (&info->descriptor, se.expr, block);
+ gfc_add_block_to_block (block, &tmp_block);
ss_info->string_length = se.string_length;
ss_info->class_container = se.class_container;
diff --git a/gcc/testsuite/gfortran.dg/bounds_check_28.f90 b/gcc/testsuite/gfortran.dg/bounds_check_28.f90
new file mode 100644
index 000000000000..0947e308e7af
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bounds_check_28.f90
@@ -0,0 +1,70 @@
+! { dg-do run }
+! { dg-options "-fcheck=bounds" }
+!
+! PR fortran/124661
+! Check that the temporary variables used to prevent redundant data
+! references aren't used uninitialized in the bounds checking code.
+!
+! Original testcase from Jakub Benda <albandil at atlas dot cz>.
+! Extended and adapted to the testsuite by Christopher Albert <albert at tugraz dot at>.
+
+module m
+ implicit none
+
+ type point_t
+ real :: coords(1:3)
+ end type point_t
+
+ type intermediary_t
+ type(point_t), allocatable :: ac(:)
+ end type intermediary_t
+
+ type point_cloud_t
+ type(point_t), allocatable :: points(:)
+ contains
+ procedure :: init_point_cloud
+ end type point_cloud_t
+
+ type nested_point_cloud_t
+ type(intermediary_t), allocatable :: points(:)
+ contains
+ procedure :: init_nested_point_cloud
+ end type nested_point_cloud_t
+
+contains
+
+ subroutine init_point_cloud (c)
+ class(point_cloud_t) :: c
+ real :: expected(3)
+
+ expected = [1.0, 2.0, 3.0]
+ allocate (c%points(1))
+ c%points(1)%coords = expected
+
+ if (c%points(1)%coords(3) /= expected(3)) stop 1
+ if (any (c%points(1)%coords /= expected)) stop 2
+ end subroutine init_point_cloud
+
+ subroutine init_nested_point_cloud (c)
+ class(nested_point_cloud_t) :: c
+ real :: expected(3)
+
+ expected = [4.0, 5.0, 6.0]
+ allocate (c%points(1))
+ allocate (c%points(1)%ac(1))
+ c%points(1)%ac(1)%coords = expected
+
+ if (c%points(1)%ac(1)%coords(3) /= expected(3)) stop 3
+ if (any (c%points(1)%ac(1)%coords /= expected)) stop 4
+ end subroutine init_nested_point_cloud
+end module m
+
+program p
+ use m, only: nested_point_cloud_t, point_cloud_t
+ implicit none
+ type(point_cloud_t) :: c
+ type(nested_point_cloud_t) :: nested
+
+ call c%init_point_cloud
+ call nested%init_nested_point_cloud
+end program p
diff --git a/gcc/tree-inline.cc b/gcc/tree-inline.cc
index 087fcc8a8b87..df5597ef30dd 100644
--- a/gcc/tree-inline.cc
+++ b/gcc/tree-inline.cc
@@ -6057,24 +6057,6 @@ copy_gimple_seq_and_replace_locals (gimple_seq seq)
}
-/* Allow someone to determine if SEARCH is a child of TOP from gdb. */
-
-static tree
-debug_find_tree_1 (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
-{
- if (*tp == data)
- return (tree) data;
- else
- return NULL;
-}
-
-DEBUG_FUNCTION bool
-debug_find_tree (tree top, tree search)
-{
- return walk_tree_without_duplicates (&top, debug_find_tree_1, search) != 0;
-}
-
-
/* Declare the variables created by the inliner. Add all the variables in
VARS to BIND_EXPR. */
diff --git a/gcc/tree-inline.h b/gcc/tree-inline.h
index 4642c87f89b8..aeedab0c26fd 100644
--- a/gcc/tree-inline.h
+++ b/gcc/tree-inline.h
@@ -242,7 +242,6 @@ bool tree_versionable_function_p (tree);
extern tree remap_decl (tree decl, copy_body_data *id);
extern tree remap_type (tree type, copy_body_data *id);
extern gimple_seq copy_gimple_seq_and_replace_locals (gimple_seq seq);
-extern bool debug_find_tree (tree, tree);
extern tree copy_fn (tree, tree&, tree&);
extern const char *copy_forbidden (struct function *fun);
extern tree copy_decl_for_dup_finish (copy_body_data *id, tree decl, tree copy);
diff --git a/gcc/tree.cc b/gcc/tree.cc
index d0e745e8d281..2868cb0867dd 100644
--- a/gcc/tree.cc
+++ b/gcc/tree.cc
@@ -15298,6 +15298,26 @@ verify_type_context (location_t loc, type_context_kind context,
|| targetm.verify_type_context (loc, context, type, silent_p));
}
+/* Callback of walk_tree telling whether the current tree pointed by TP is the
+ one provided as DATA. */
+
+static tree
+find_tree_1 (tree *tp, int *walk_subtrees ATTRIBUTE_UNUSED, void *data)
+{
+ if (*tp == data)
+ return (tree) data;
+ else
+ return NULL;
+}
+
+/* Return whether SEARCH is a subtree of TOP. */
+
+bool
+find_tree (tree top, tree search)
+{
+ return walk_tree_without_duplicates (&top, find_tree_1, search) != 0;
+}
+
/* Return true if NEW_ASM and DELETE_ASM name a valid pair of new and
delete operators. Return false if they may or may not name such
a pair and, when nonnull, set *PCERTAIN to true if they certainly
diff --git a/gcc/tree.h b/gcc/tree.h
index 19bc67718d14..f8b2d718b7ee 100644
--- a/gcc/tree.h
+++ b/gcc/tree.h
@@ -6001,6 +6001,9 @@ extern int get_range_pos_neg (tree, gimple * = NULL);
/* Return true for a valid pair of new and delete operators. */
extern bool valid_new_delete_pair_p (tree, tree, bool * = NULL);
+/* Return whether the second argument is a subtree of the first one. */
+extern bool find_tree (tree, tree);
+
/* Return simplified tree code of type that is used for canonical type
merging. */
inline enum tree_code
More information about the Gcc-cvs
mailing list