[gcc/devel/omp/gcc-16] Fortran/OpenMP: Fix POINTER array mis-privatization [PR122910]

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