https://gcc.gnu.org/g:7e63c28c08d4668b3b81bf0b361b7f2dab377d48
commit 7e63c28c08d4668b3b81bf0b361b7f2dab377d48 Author: Chung-Lin Tang <[email protected]> Date: Wed Jun 10 14:29:06 2026 +0000 Fortran/OpenMP: Fix POINTER array mis-privatization [PR122910] This patch fixes a case where POINTER attribute arrays are deep copied when not supposed to. Namely, OpenMP states for the "firstprivate Clause": "If an original list item has the POINTER attribute, the new list items receive the same association status as the original list item, as if by pointer assignment." This creates a new langhook 'omp_array_data_privatize' to differentiate cases in certain places during omp-low. PR fortran/122910 gcc/fortran/ChangeLog: * f95-lang.cc (LANG_HOOKS_OMP_ARRAY_DATA_PRIVATIZE): Define as gfc_omp_array_data_privatize. * trans-openmp.cc (gfc_omp_array_data_privatize): New function. * trans.h (gfc_omp_array_data_privatize): New declaration. gcc/ChangeLog: * langhooks-def.h (LANG_HOOKS_OMP_ARRAY_DATA_PRIVATIZE): Define. * langhooks.h (struct lang_hooks_for_decls): Define omp_array_data_privatize hook. * omp-low.cc (scan_sharing_clauses): Add new calls to lang_hooks.decls.omp_array_data_privatize, (lower_omp_target): Likewise. libgomp/ChangeLog: * testsuite/libgomp.fortran/pr122910.f90: New test. Reviewed-by: Tobias Burnus <[email protected]> (cherry picked from commit 800227516cf3d407ef17e7206b8bebe2d29f4dc1) Diff: --- gcc/fortran/f95-lang.cc | 2 + gcc/fortran/trans-openmp.cc | 18 ++++++ gcc/fortran/trans.h | 1 + gcc/langhooks-def.h | 4 +- gcc/langhooks.h | 7 +++ gcc/omp-low.cc | 9 ++- libgomp/testsuite/libgomp.fortran/pr122910.f90 | 84 ++++++++++++++++++++++++++ 7 files changed, 121 insertions(+), 4 deletions(-) diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 1cdc83500a93..b796bcf142d7 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -135,6 +135,7 @@ gfc_get_sarif_source_language (const char *) #undef LANG_HOOKS_TYPE_FOR_SIZE #undef LANG_HOOKS_INIT_TS #undef LANG_HOOKS_OMP_ARRAY_DATA +#undef LANG_HOOKS_OMP_ARRAY_DATA_PRIVATIZE #undef LANG_HOOKS_OMP_ARRAY_SIZE #undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR #undef LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT @@ -178,6 +179,7 @@ gfc_get_sarif_source_language (const char *) #define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size #define LANG_HOOKS_INIT_TS gfc_init_ts #define LANG_HOOKS_OMP_ARRAY_DATA gfc_omp_array_data +#define LANG_HOOKS_OMP_ARRAY_DATA_PRIVATIZE gfc_omp_array_data_privatize #define LANG_HOOKS_OMP_ARRAY_SIZE gfc_omp_array_size #define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR gfc_omp_is_allocatable_or_ptr #define LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT gfc_omp_check_optional_argument diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 6fe5c0f33393..516b1fda83d8 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -177,6 +177,24 @@ gfc_omp_array_data (tree decl, bool type_only) return decl; } +/* Returns true if DECL is an array for which the actual array data has to be + privatized; the caller must ensure that DECL is an array descriptor, + i.e. 'omp_array_data' returns true. */ + +bool +gfc_omp_array_data_privatize (tree decl) +{ + tree type = TREE_TYPE (decl); + + if (POINTER_TYPE_P (type)) + type = TREE_TYPE (type); + + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + + return (GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_POINTER + && GFC_TYPE_ARRAY_AKIND (type) != GFC_ARRAY_POINTER_CONT); +} + /* Return the byte-size of the passed array descriptor. */ tree diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index f97fefd2ac05..0bdee5820fdd 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -827,6 +827,7 @@ tree gfc_omp_call_is_alloc (tree); bool gfc_omp_is_allocatable_or_ptr (const_tree); tree gfc_omp_check_optional_argument (tree, bool); tree gfc_omp_array_data (tree, bool); +bool gfc_omp_array_data_privatize (tree); tree gfc_omp_array_size (tree, gimple_seq *); bool gfc_omp_privatize_by_reference (const_tree); enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree); diff --git a/gcc/langhooks-def.h b/gcc/langhooks-def.h index fc409ec08b96..33a99266187c 100644 --- a/gcc/langhooks-def.h +++ b/gcc/langhooks-def.h @@ -263,6 +263,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree); #define LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS NULL #define LANG_HOOKS_DECL_OK_FOR_SIBCALL lhd_decl_ok_for_sibcall #define LANG_HOOKS_OMP_ARRAY_DATA hook_tree_tree_bool_null +#define LANG_HOOKS_OMP_ARRAY_DATA_PRIVATIZE hook_bool_tree_false #define LANG_HOOKS_OMP_ARRAY_SIZE lhd_omp_array_size #define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR hook_bool_const_tree_false #define LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT hook_tree_tree_bool_null @@ -305,7 +306,8 @@ extern tree lhd_unit_size_without_reusable_padding (tree); LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS, \ LANG_HOOKS_DECL_OK_FOR_SIBCALL, \ LANG_HOOKS_OMP_ARRAY_DATA, \ - LANG_HOOKS_OMP_ARRAY_SIZE, \ + LANG_HOOKS_OMP_ARRAY_DATA_PRIVATIZE, \ + LANG_HOOKS_OMP_ARRAY_SIZE, \ LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR, \ LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT, \ LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE, \ diff --git a/gcc/langhooks.h b/gcc/langhooks.h index cfcb38092d58..b7a75a5e0427 100644 --- a/gcc/langhooks.h +++ b/gcc/langhooks.h @@ -243,6 +243,13 @@ struct lang_hooks_for_decls is true, only the TREE_TYPE is returned without generating a new tree. */ tree (*omp_array_data) (tree, bool); + /* Return true if the actual array data of the passed array descriptor decl + shall be privatized as well, otherwise only the array descriptor is to + be privatized. The argument must be a decl for an array descriptor, + i.e. it may only be called for a decl for which omp_array_data returns + a non-NULL_TREE. */ + bool (*omp_array_data_privatize) (tree); + /* Return a tree for the actual data of an array descriptor - or NULL_TREE if original tree is not an array descriptor. If the second argument is true, only the TREE_TYPE is returned without generating a new tree. */ diff --git a/gcc/omp-low.cc b/gcc/omp-low.cc index e8716d9fa37e..56a6bfaee5e3 100644 --- a/gcc/omp-low.cc +++ b/gcc/omp-low.cc @@ -1464,7 +1464,8 @@ scan_sharing_clauses (tree clauses, omp_context *ctx) if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_FIRSTPRIVATE && is_gimple_omp_offloaded (ctx->stmt) && !is_gimple_omp_oacc (ctx->stmt) - && lang_hooks.decls.omp_array_data (decl, true)) + && lang_hooks.decls.omp_array_data (decl, true) + && lang_hooks.decls.omp_array_data_privatize (decl)) { install_var_field (decl, false, 16 | 3, ctx); install_var_field (decl, true, 8 | 3, ctx); @@ -13078,7 +13079,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx) } /* Fortran array descriptors: firstprivate of data + attach. */ if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_HAS_DEVICE_ADDR - && lang_hooks.decls.omp_array_data (var, true)) + && lang_hooks.decls.omp_array_data (var, true) + && lang_hooks.decls.omp_array_data_privatize (var)) map_cnt += 2; do_dtor: @@ -13757,7 +13759,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx) build_int_cstu (tkind_type, tkind)); /* Fortran array descriptors: firstprivate of data + attach. */ if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_HAS_DEVICE_ADDR - && lang_hooks.decls.omp_array_data (ovar, true)) + && lang_hooks.decls.omp_array_data (ovar, true) + && lang_hooks.decls.omp_array_data_privatize (ovar)) { tree not_null_lb, null_lb, after_lb; tree var1, var2, size1, size2; diff --git a/libgomp/testsuite/libgomp.fortran/pr122910.f90 b/libgomp/testsuite/libgomp.fortran/pr122910.f90 new file mode 100644 index 000000000000..bf90af7a3897 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/pr122910.f90 @@ -0,0 +1,84 @@ +! { dg-do run } + +program main + implicit none + + !$omp requires self_maps + + integer :: i + INTEGER, POINTER :: fptr(:) + INTEGER, ALLOCATABLE :: alloc_array(:) + integer, parameter :: N = 5 + + ALLOCATE(fptr(N)) + fptr = 7 + alloc_array = [1,2,3,4,5,6] + + !$omp target firstprivate(fptr, alloc_array) + DO i=1, N + fptr(i) = 5*i + fptr(i) + END DO + fptr => null() ! ptr must be privatized, pointer target not + if (any (alloc_array /= [1,2,3,4,5,6])) stop 1 + alloc_array = alloc_array * 21 + !$omp end target + + ! pointer array: values shall be updated + if (any (fptr /= 7 + 5*[1,2,3,4,5])) stop 2 + ! allocatables: shall not be updated + if (any (alloc_array /= [1,2,3,4,5,6])) stop 3 + + ! Check data-sharing constructs as well: + !$omp parallel firstprivate(fptr, alloc_array) + !$omp masked + fptr = fptr * 10 + fptr => null() + if (any (alloc_array /= [1,2,3,4,5,6])) stop 4 + alloc_array = alloc_array * 21 + !$omp end masked + !$omp end parallel + + if (any (fptr /= (7 + 5*[1,2,3,4,5])*10)) stop 5 + if (any (alloc_array /= [1,2,3,4,5,6])) stop 6 + + call assumed_shape(alloc_array, N) + + DEALLOCATE(fptr, alloc_array) + +contains + subroutine assumed_shape(x, m) + integer, value :: m + integer :: x(:) + integer :: y(m) + integer, save :: z(5) + + y = [11,22,33,44,55] + z = [111,222,333,444,555] + !$omp target firstprivate(x,y,z) + if (any (x /= [1,2,3,4,5,6])) stop 7 + if (any (y /= [11,22,33,44,55])) stop 8 + if (any (z /= [111,222,333,444,555])) stop 9 + x = 31 * x + y = 47 * y + z = 53 * z + !$omp end target + + if (any (x /= [1,2,3,4,5,6])) stop 10 + if (any (y /= [11,22,33,44,55])) stop 11 + if (any (z /= [111,222,333,444,555])) stop 12 + + !$omp parallel firstprivate(x,y,z) if(.false.) + if (any (x /= [1,2,3,4,5,6])) stop 13 + if (any (y /= [11,22,33,44,55])) stop 14 + if (any (z /= [111,222,333,444,555])) stop 15 + x = 31 * x + y = 47 * y + z = 53 * z + !$omp end parallel + + if (any (x /= [1,2,3,4,5,6])) stop 16 + if (any (y /= [11,22,33,44,55])) stop 17 + if (any (z /= [111,222,333,444,555])) stop 18 + end subroutine + +end program
