[PATCH, OpenMP, Fortran] PR122910 fix POINTER array mis-privatization

Chung-Lin Tang <[email protected]>
Newsgroups gmane.comp.gcc.patches,gmane.comp.gcc.fortran
Message-ID <[email protected]> 
This patch fixes a case where POINTER attribute arrays are deep copied when not supposed to.

This creates a new langhook 'omp_array_data_privatize' to differentiate cases in certain
places during omp-low.

Still under final testing. Okay for mainline if everything passes?

Thanks,
Chung-Lin

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.
pr122910.patch (text/plain, 6.3 KB) 
diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 45aab34865f..12ab1d251da 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 b9c09d114b7..e64fa82a238 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -176,6 +176,24 @@ gfc_omp_array_data (tree decl, bool type_only)
   return decl;
 }
 
+/* Returns true if it is an array descriptor where the data is to be copied
+   and privatized.  Assumes the above 'omp_array_data' to already be true
+   (hence the assertion of descriptor type here).  */
+
+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 f97fefd2ac0..0bdee5820fd 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 fc409ec08b9..33a99266187 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 6eb5c1602f8..aa983165ab5 100644
--- a/gcc/langhooks.h
+++ b/gcc/langhooks.h
@@ -243,6 +243,10 @@ 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 data of an array descriptor is to be copied and
+     privatized.  Assumes omp_array_data returns 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 b93012107f1..79228b6350a 100644
--- a/gcc/omp-low.cc
+++ b/gcc/omp-low.cc
@@ -1443,7 +1443,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);
@@ -13046,7 +13047,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:
@@ -13725,7 +13727,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 00000000000..6081dfa4ea9
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/pr122910.f90
@@ -0,0 +1,23 @@
+! { dg-do run { target { ! offload_device } } }
+
+program main
+  implicit none
+
+  !$omp requires self_maps
+
+  integer :: i
+  INTEGER, POINTER :: fptr(:)
+  integer, parameter :: N = 5
+
+  ALLOCATE(fptr(N))
+  fptr = 0
+
+  !$omp target firstprivate(fptr)
+  DO i=1, N
+     fptr(i) = 5*i
+  END DO
+  !$omp end target
+
+  if (any (fptr /= 5*[1,2,3,4,5])) stop 1
+
+end program
lmpx.com only provides a reader for public news (NNTP) servers. It is not affiliated with the servers or forums shown here and is not responsible for the content of articles, which is written by their respective authors.