From 35ce96e508271800e50bd8ba234469bfccf0655f Mon Sep 17 00:00:00 2001 From: Christopher Albert Date: Sat, 18 Oct 2025 07:55:26 +0200 Subject: [PATCH] gfortran: Runtime deep copy via descriptor walker gcc/fortran/ * trans-array.cc (get_copy_helper_function_type): New cached function type helper for copy wrappers. * trans-array.cc (get_copy_helper_pointer_type): New helper returning pointer type for wrapper. * trans-array.cc (generate_element_copy_wrapper): Generate artificial wrapper functions using GIMPLE. * trans-array.cc (structure_alloc_comps): Invoke runtime deep copy helper for recursive components. * trans-decl.cc (gfortran_init_builtin_functions): Initialize gfor_fndecl_cfi_deep_copy_array. * trans.h (gfor_fndecl_cfi_deep_copy_array): New extern declaration. * testsuite/gfortran.dg/alloc_comp_deep_copy_recursive_array.f90: New test covering recursive arrays. * testsuite/gfortran.dg/alloc_comp_deep_copy_nested_recursive.f90: New test covering nested derived types. libgfortran/ * Makefile.am: Add runtime/deep_copy.c to libgfortran sources. * Makefile.in: Regenerate. * gfortran.map: Export cfi_deep_copy_array. * libgfortran.h: Declare cfi_deep_copy_array. * runtime/deep_copy.c: New descriptor-based deep copy walker used by the front end. --- gcc/fortran/trans-array.cc | 190 +++++++++++++++++- gcc/fortran/trans-decl.cc | 20 ++ gcc/fortran/trans.h | 3 + .../alloc_comp_deep_copy_nested_recursive.f90 | 29 +++ .../alloc_comp_deep_copy_recursive_array.f90 | 22 ++ libgfortran/Makefile.am | 1 + libgfortran/Makefile.in | 8 +- libgfortran/gfortran.map | 1 + libgfortran/libgfortran.h | 8 + libgfortran/runtime/deep_copy.c | 125 ++++++++++++ 10 files changed, 402 insertions(+), 5 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_nested_recursive.f90 create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_recursive_array.f90 create mode 100644 libgfortran/runtime/deep_copy.c diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index e2b17a725be..1ec3fb3503a 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -92,6 +92,11 @@ along with GCC; see the file COPYING3. If not see #include "trans-array.h" #include "trans-const.h" #include "dependency.h" +#include "cgraph.h" /* For cgraph_node::finalize_function. */ +#include "gimplify.h" /* For gimplify_function_tree. */ +#include "function.h" /* For push/pop_function_context, allocate_struct_function. */ +#include "toplev.h" /* For announce_function, rest_of_decl_compilation. */ +#include "varasm.h" /* For make_decl_rtl. */ static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base); @@ -10029,6 +10034,132 @@ enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, static gfc_actual_arglist *pdt_param_list; +/* Forward declaration of structure_alloc_comps for wrapper generator. */ +static tree structure_alloc_comps (gfc_symbol *, tree, tree, int, int, int, + gfc_co_subroutines_args *, bool); + +/* Generate a wrapper function that performs element-wise deep copy for + recursive allocatable array components. This wrapper is passed as a + function pointer to the runtime helper _gfortran_cfi_deep_copy_array, + allowing recursion to happen at runtime instead of compile time. */ + +static tree +get_copy_helper_function_type (void) +{ + static tree fn_type = NULL_TREE; + if (fn_type == NULL_TREE) + fn_type = build_function_type_list (void_type_node, + pvoid_type_node, + pvoid_type_node, + NULL_TREE); + return fn_type; +} + +static tree +get_copy_helper_pointer_type (void) +{ + static tree ptr_type = NULL_TREE; + if (ptr_type == NULL_TREE) + ptr_type = build_pointer_type (get_copy_helper_function_type ()); + return ptr_type; +} + +static tree +generate_element_copy_wrapper (gfc_symbol *der_type, tree comp_type, + int purpose, int caf_mode, + gfc_co_subroutines_args *args) +{ + tree fndecl, fntype, result_decl, saved_function_decl; + tree dest_parm, src_parm, dest_typed, src_typed; + tree der_type_ptr; + stmtblock_t block; + tree decls; + tree body; + + saved_function_decl = current_function_decl; + push_function_context (); + + fntype = get_copy_helper_function_type (); + + fndecl = build_decl (input_location, FUNCTION_DECL, + create_tmp_var_name ("copy_element"), + fntype); + + TREE_PUBLIC (fndecl) = 0; + TREE_STATIC (fndecl) = 1; + TREE_USED (fndecl) = 1; + DECL_ARTIFICIAL (fndecl) = 1; + + result_decl = build_decl (input_location, RESULT_DECL, NULL_TREE, + void_type_node); + DECL_ARTIFICIAL (result_decl) = 1; + DECL_IGNORED_P (result_decl) = 1; + DECL_CONTEXT (result_decl) = fndecl; + DECL_RESULT (fndecl) = result_decl; + + dest_parm = build_decl (input_location, PARM_DECL, + get_identifier ("dest"), pvoid_type_node); + src_parm = build_decl (input_location, PARM_DECL, + get_identifier ("src"), pvoid_type_node); + + DECL_ARTIFICIAL (dest_parm) = 1; + DECL_ARTIFICIAL (src_parm) = 1; + DECL_ARG_TYPE (dest_parm) = pvoid_type_node; + DECL_ARG_TYPE (src_parm) = pvoid_type_node; + DECL_CONTEXT (dest_parm) = fndecl; + DECL_CONTEXT (src_parm) = fndecl; + + DECL_ARGUMENTS (fndecl) = dest_parm; + TREE_CHAIN (dest_parm) = src_parm; + + pushdecl (fndecl); + current_function_decl = fndecl; + announce_function (fndecl); + + rest_of_decl_compilation (fndecl, 0, 0); + make_decl_rtl (fndecl); + allocate_struct_function (fndecl, false); + + pushlevel (); + gfc_init_block (&block); + + der_type_ptr = build_pointer_type (comp_type); + dest_typed = fold_convert (der_type_ptr, dest_parm); + src_typed = fold_convert (der_type_ptr, src_parm); + + dest_typed = build_fold_indirect_ref (dest_typed); + src_typed = build_fold_indirect_ref (src_typed); + + body = structure_alloc_comps (der_type, src_typed, dest_typed, + 0, purpose, caf_mode, args, false); + gfc_add_expr_to_block (&block, body); + + body = gfc_finish_block (&block); + decls = getdecls (); + + poplevel (1, 1); + BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; + + DECL_SAVED_TREE (fndecl) + = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, + void_type_node, decls, body, DECL_INITIAL (fndecl)); + + gimplify_function_tree (fndecl); + + cfun->function_end_locus = input_location; + set_cfun (NULL); + + if (decl_function_context (fndecl)) + (void) cgraph_node::create (fndecl); + else + cgraph_node::finalize_function (fndecl, true); + + pop_function_context (); + current_function_decl = saved_function_decl; + + return build1 (ADDR_EXPR, get_copy_helper_pointer_type (), fndecl); +} + static tree structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, int rank, int purpose, int caf_mode, @@ -10192,6 +10323,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, && seen_derived_types.contains (c->ts.u.derived)) || (c->ts.type == BT_CLASS && seen_derived_types.contains (CLASS_DATA (c)->ts.u.derived)); + bool inside_wrapper + = (current_function_decl != NULL + && DECL_ARTIFICIAL (current_function_decl) + && DECL_NAME (current_function_decl) != NULL + && strncmp (IDENTIFIER_POINTER (DECL_NAME (current_function_decl)), + "copy_element", 12) == 0); bool is_pdt_type = c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type; @@ -10868,9 +11005,58 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, false, false, NULL_TREE, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); } + /* Special case: recursive allocatable array components require runtime + helper to avoid compile-time infinite recursion. Generate a call to + _gfortran_cfi_deep_copy_array with an element copy wrapper. */ + else if (c->attr.allocatable && c->as && cmp_has_alloc_comps && same_type + && purpose == COPY_ALLOC_COMP && !c->attr.proc_pointer + && !c->attr.codimension && !caf_in_coarray (caf_mode) + && c->ts.type == BT_DERIVED && c->ts.u.derived != NULL) + { + tree copy_wrapper, call, dest_addr, src_addr, elem_type; + tree helper_ptr_type; + tree alloc_expr; + int comp_rank; + + /* Get the element type from ctype (which is already the component type). + For arrays, we need the element type, not the array type. */ + elem_type = ctype; + if (GFC_DESCRIPTOR_TYPE_P (ctype)) + elem_type = gfc_get_element_type (ctype); + else if (TREE_CODE (ctype) == ARRAY_TYPE) + elem_type = TREE_TYPE (ctype); + + helper_ptr_type = get_copy_helper_pointer_type (); + + comp_rank = c->as ? c->as->rank : 0; + alloc_expr = gfc_duplicate_allocatable_nocopy (dcmp, comp, ctype, + comp_rank); + gfc_add_expr_to_block (&fnblock, alloc_expr); + + /* Generate or reuse the element copy helper. Inside an existing helper + we can reuse the current function to prevent recursive generation. */ + if (inside_wrapper) + copy_wrapper = gfc_build_addr_expr (NULL_TREE, current_function_decl); + else + copy_wrapper = generate_element_copy_wrapper (c->ts.u.derived, + elem_type, + purpose, caf_mode, + args); + copy_wrapper = fold_convert (helper_ptr_type, copy_wrapper); + + /* Build addresses of descriptors. */ + dest_addr = gfc_build_addr_expr (pvoid_type_node, dcmp); + src_addr = gfc_build_addr_expr (pvoid_type_node, comp); + + /* Build call: _gfortran_cfi_deep_copy_array (&dcmp, &comp, wrapper). */ + call = build_call_expr_loc (input_location, + gfor_fndecl_cfi_deep_copy_array, 3, + dest_addr, src_addr, copy_wrapper); + gfc_add_expr_to_block (&fnblock, call); + } else if (c->attr.allocatable && !c->attr.proc_pointer - && (!(cmp_has_alloc_comps && c->as) || c->attr.codimension - || caf_in_coarray (caf_mode))) + && (add_when_allocated != NULL_TREE || !cmp_has_alloc_comps || !c->as + || c->attr.codimension || caf_in_coarray (caf_mode))) { rank = c->as ? c->as->rank : 0; if (c->attr.codimension) diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index c31c7569882..419de2c63cf 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -248,6 +248,9 @@ tree gfor_fndecl_zgemm; /* RANDOM_INIT function. */ tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */ +/* Deep copy helper for recursive allocatable array components. */ +tree gfor_fndecl_cfi_deep_copy_array; + static void gfc_add_decl_to_parent_function (tree decl) { @@ -3588,6 +3591,23 @@ gfc_build_intrinsic_function_decls (void) gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node, gfc_logical4_type_node); + { + tree copy_helper_ptr_type; + tree copy_helper_fn_type; + + copy_helper_fn_type = build_function_type_list (void_type_node, + pvoid_type_node, + pvoid_type_node, + NULL_TREE); + copy_helper_ptr_type = build_pointer_type (copy_helper_fn_type); + + gfor_fndecl_cfi_deep_copy_array + = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("cfi_deep_copy_array")), ". R R . ", + void_type_node, 3, pvoid_type_node, pvoid_type_node, + copy_helper_ptr_type); + } + gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("adjustl")), ". W . R ", void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 1d04b22abc8..6a465f480dd 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -1004,6 +1004,9 @@ extern GTY(()) tree gfor_fndecl_ieee_procedure_exit; extern GTY(()) tree gfor_fndecl_random_init; extern GTY(()) tree gfor_fndecl_caf_random_init; +/* Deep copy helper for recursive allocatable array components. */ +extern GTY(()) tree gfor_fndecl_cfi_deep_copy_array; + /* True if node is an integer constant. */ #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST) diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_nested_recursive.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_nested_recursive.f90 new file mode 100644 index 00000000000..8ea5374ea8c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_nested_recursive.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +program alloc_comp_deep_copy_nested_recursive + use, intrinsic :: iso_fortran_env, only: dp => real64 + implicit none + + type :: node_t + real(dp), allocatable :: values(:) + type(node_t), allocatable :: children(:) + end type node_t + + type(node_t) :: src, dst + + allocate (src%values(3)) + src%values = [ 1.0_dp, 2.0_dp, 3.0_dp ] + + allocate (src%children(1)) + allocate (src%children(1)%values(2)) + src%children(1)%values = [ 4.0_dp, 5.0_dp ] + + dst = src + + dst%values(1) = -1.0_dp + dst%children(1)%values(1) = -2.0_dp + + if (any(src%values /= [ 1.0_dp, 2.0_dp, 3.0_dp ])) stop 1 + if (any(src%children(1)%values /= [ 4.0_dp, 5.0_dp ])) stop 2 + if (any(dst%values /= [ -1.0_dp, 2.0_dp, 3.0_dp ])) stop 3 + if (any(dst%children(1)%values /= [ -2.0_dp, 5.0_dp ])) stop 4 +end program alloc_comp_deep_copy_nested_recursive diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_recursive_array.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_recursive_array.f90 new file mode 100644 index 00000000000..7cbd2b29b25 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_recursive_array.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +program alloc_comp_deep_copy_recursive_array + implicit none + + type :: node_t + character(len=10) :: name + type(node_t), allocatable :: children(:) + end type node_t + + type(node_t) :: src, dst + + src%name = "root" + allocate (src%children(2)) + src%children(1)%name = "child-one" + src%children(2)%name = "child-two" + + dst = src + dst%children(1)%name = "modified" + + if (src%children(1)%name /= "child-one") stop 1 + if (dst%children(1)%name /= "modified") stop 2 +end program alloc_comp_deep_copy_recursive_array diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 4f3b3033224..46e7df5e728 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -218,6 +218,7 @@ endif gfor_src= \ runtime/bounds.c \ runtime/compile_options.c \ +runtime/deep_copy.c \ runtime/memory.c \ runtime/string.c \ runtime/select.c diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index ce828b2f8d0..116e80ffe3c 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -231,7 +231,7 @@ libgfortran_la_LIBADD = @LIBGFOR_MINIMAL_FALSE@ runtime/fpu.lo runtime/main.lo \ @LIBGFOR_MINIMAL_FALSE@ runtime/pause.lo runtime/stop.lo am__objects_3 = runtime/bounds.lo runtime/compile_options.lo \ - runtime/memory.lo runtime/string.lo runtime/select.lo \ + runtime/deep_copy.lo runtime/memory.lo runtime/string.lo runtime/select.lo \ $(am__objects_1) $(am__objects_2) am__objects_4 = generated/matmul_i1.lo generated/matmul_i2.lo \ generated/matmul_i4.lo generated/matmul_i8.lo \ @@ -1013,8 +1013,8 @@ gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \ @IEEE_SUPPORT_TRUE@ieee/ieee_exceptions.F90 \ @IEEE_SUPPORT_TRUE@ieee/ieee_features.F90 -gfor_src = runtime/bounds.c runtime/compile_options.c runtime/memory.c \ - runtime/string.c runtime/select.c $(am__append_6) \ +gfor_src = runtime/bounds.c runtime/compile_options.c runtime/deep_copy.c \ + runtime/memory.c runtime/string.c runtime/select.c $(am__append_6) \ $(am__append_7) i_matmul_c = \ generated/matmul_i1.c \ @@ -1981,6 +1981,8 @@ runtime/bounds.lo: runtime/$(am__dirstamp) \ runtime/$(DEPDIR)/$(am__dirstamp) runtime/compile_options.lo: runtime/$(am__dirstamp) \ runtime/$(DEPDIR)/$(am__dirstamp) +runtime/deep_copy.lo: runtime/$(am__dirstamp) \ + runtime/$(DEPDIR)/$(am__dirstamp) runtime/memory.lo: runtime/$(am__dirstamp) \ runtime/$(DEPDIR)/$(am__dirstamp) runtime/string.lo: runtime/$(am__dirstamp) \ diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 98808dc304f..fc0166580d8 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -2037,4 +2037,5 @@ GFORTRAN_16 { global: _gfortran_string_split; _gfortran_string_split_char4; + _gfortran_cfi_deep_copy_array; } GFORTRAN_15.2; diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 25c3cb6641c..22fe75ba89c 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -914,6 +914,14 @@ internal_proto(xcalloc); extern void *xrealloc (void *, size_t); internal_proto(xrealloc); +/* deep_copy.c - Runtime helper for recursive allocatable array components */ + +struct CFI_cdesc_t; +extern void cfi_deep_copy_array (gfc_array_void *, + gfc_array_void *, + void (*)(void*, void*)); +export_proto(cfi_deep_copy_array); + /* environ.c */ extern void init_variables (void); diff --git a/libgfortran/runtime/deep_copy.c b/libgfortran/runtime/deep_copy.c new file mode 100644 index 00000000000..3d8af16d040 --- /dev/null +++ b/libgfortran/runtime/deep_copy.c @@ -0,0 +1,125 @@ +/* Deep copy support for allocatable components in derived types. + Copyright (C) 2025 Free Software Foundation, Inc. + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +. */ + +#include "libgfortran.h" +#include + +/* Runtime helper for deep copying allocatable array components when the + element type contains nested allocatable components. The front end handles + allocation and deallocation; this helper performs element-wise copies using + the compiler-generated element copier so that recursion takes place at + runtime. */ + +static inline size_t +descriptor_elem_size (gfc_array_void *desc) +{ + size_t size = GFC_DESCRIPTOR_SIZE (desc); + return size == 0 ? 1 : size; +} + +void +cfi_deep_copy_array (gfc_array_void *dest, gfc_array_void *src, + void (*copy_element)(void*, void*)) +{ + int rank; + size_t src_elem_size; + size_t dest_elem_size; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type src_stride_bytes[GFC_MAX_DIMENSIONS]; + index_type dest_stride_bytes[GFC_MAX_DIMENSIONS]; + index_type count[GFC_MAX_DIMENSIONS]; + char *src_ptr; + char *dest_ptr; + + if (src == NULL || dest == NULL) + return; + + if (GFC_DESCRIPTOR_DATA (src) == NULL) + { + if (GFC_DESCRIPTOR_DATA (dest) != NULL) + internal_error (NULL, "cfi_deep_copy_array: destination must be " + "deallocated when source is not allocated"); + return; + } + + if (GFC_DESCRIPTOR_DATA (dest) == NULL) + internal_error (NULL, "cfi_deep_copy_array: destination not allocated"); + + rank = GFC_DESCRIPTOR_RANK (src); + src_elem_size = descriptor_elem_size (src); + dest_elem_size = descriptor_elem_size (dest); + + if (rank <= 0) + { + memcpy (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_DATA (src), + src_elem_size); + if (copy_element != NULL) + copy_element (GFC_DESCRIPTOR_DATA (dest), + GFC_DESCRIPTOR_DATA (src)); + return; + } + + for (int dim = 0; dim < rank; dim++) + { + extent[dim] = GFC_DESCRIPTOR_EXTENT (src, dim); + if (extent[dim] <= 0) + return; + + src_stride_bytes[dim] + = GFC_DESCRIPTOR_STRIDE (src, dim) * src_elem_size; + dest_stride_bytes[dim] + = GFC_DESCRIPTOR_STRIDE (dest, dim) * dest_elem_size; + count[dim] = 0; + } + + src_ptr = (char *) GFC_DESCRIPTOR_DATA (src); + dest_ptr = (char *) GFC_DESCRIPTOR_DATA (dest); + + while (true) + { + memcpy (dest_ptr, src_ptr, src_elem_size); + if (copy_element != NULL) + copy_element (dest_ptr, src_ptr); + + dest_ptr += dest_stride_bytes[0]; + src_ptr += src_stride_bytes[0]; + count[0]++; + + int dim = 0; + while (count[dim] == extent[dim]) + { + count[dim] = 0; + dest_ptr -= dest_stride_bytes[dim] * extent[dim]; + src_ptr -= src_stride_bytes[dim] * extent[dim]; + dim++; + if (dim == rank) + return; + count[dim]++; + dest_ptr += dest_stride_bytes[dim]; + src_ptr += src_stride_bytes[dim]; + } + } +} + +export_proto(cfi_deep_copy_array); -- 2.51.0