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 <tburnus@baylibre.com>

diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 1cdc83500a9349196b82eea12b4dc85d193dedf2..b796bcf142d74d8bad2260ccda10107d7a9f9775 100644 (file)
--- 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 43697e99453c81c02a53450638957f7c1d6388bf..3fa011b1382937ce7d99c37ce641174f21b4c6f5 100644 (file)
--- 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 f97fefd2ac05b945426258df7e575507ca93f6c4..0bdee5820fddfe2c4584da491cb6259476940f6b 100644 (file)
--- 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 fc409ec08b96781064d5bf18a339335c7834f4ff..33a99266187c114ea89f07bfca07fe3761508927 100644 (file)
--- 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 a34803ec7865b3e7146456b501e29fee5f054319..546d7ddcdfb9fc6018316a9ea4db1ffc4cb7a9cd 100644 (file)
--- 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 d31fa96dc8cb62b5e18793af0bc7b0341ec66a7c..02b62d54ba608e875c7bfd0099980f90acda3910 100644 (file)
--- 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 (file)
index 0000000..bf90af7
--- /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