OpenMP: Handle descriptors in target's firstprivate [PR104949]
authorTobias Burnus <tobias@codesourcery.com>
Mon, 23 May 2022 08:54:32 +0000 (10:54 +0200)
committerTobias Burnus <tobias@codesourcery.com>
Mon, 23 May 2022 08:54:32 +0000 (10:54 +0200)
For allocatable/pointer arrays, a firstprivate to a device
not only needs to privatize the descriptor but also the actual
data. This is implemented as:
  firstprivate(x) firstprivate(x.data) attach(x [bias: &x.data-&x)
where the address of x in device memory is saved in hostaddrs[i]
by libgomp and the middle end actually passes hostaddrs[i]' to
attach.

As side effect, has_device_addr(array_desc) had to be changed:
before, it was converted to firstprivate in the front end; now
it is handled in omp-low.cc as has_device_addr requires a shallow
firstprivate (not touching the data pointer) while the normal
firstprivate requires (now) a deep firstprivate.

gcc/fortran/ChangeLog:

PR fortran/104949
* f95-lang.cc (LANG_HOOKS_OMP_ARRAY_SIZE): Redefine.
* trans-openmp.cc (gfc_omp_array_size): New.
(gfc_trans_omp_variable_list): Never turn has_device_addr
to firstprivate.
* trans.h (gfc_omp_array_size): New.

gcc/ChangeLog:

PR fortran/104949
* langhooks-def.h (lhd_omp_array_size): New.
(LANG_HOOKS_OMP_ARRAY_SIZE): Define.
(LANG_HOOKS_DECLS): Add it.
* langhooks.cc (lhd_omp_array_size): New.
* langhooks.h (struct lang_hooks_for_decls): Add hook.
* omp-low.cc (scan_sharing_clauses, lower_omp_target):
Handle GOMP_MAP_FIRSTPRIVATE for array descriptors.

libgomp/ChangeLog:

PR fortran/104949
* target.c (gomp_map_vars_internal, copy_firstprivate_data):
Support attach for GOMP_MAP_FIRSTPRIVATE.
* testsuite/libgomp.fortran/target-firstprivate-1.f90: New test.
* testsuite/libgomp.fortran/target-firstprivate-2.f90: New test.
* testsuite/libgomp.fortran/target-firstprivate-3.f90: New test.

gcc/fortran/f95-lang.cc
gcc/fortran/trans-openmp.cc
gcc/fortran/trans.h
gcc/langhooks-def.h
gcc/langhooks.cc
gcc/langhooks.h
gcc/omp-low.cc
libgomp/target.c
libgomp/testsuite/libgomp.fortran/target-firstprivate-1.f90 [new file with mode: 0644]
libgomp/testsuite/libgomp.fortran/target-firstprivate-2.f90 [new file with mode: 0644]
libgomp/testsuite/libgomp.fortran/target-firstprivate-3.f90 [new file with mode: 0644]

index 1a895a2..e83fef3 100644 (file)
@@ -114,6 +114,7 @@ static const struct attribute_spec gfc_attribute_table[] =
 #undef LANG_HOOKS_TYPE_FOR_SIZE
 #undef LANG_HOOKS_INIT_TS
 #undef LANG_HOOKS_OMP_ARRAY_DATA
+#undef LANG_HOOKS_OMP_ARRAY_SIZE
 #undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR
 #undef LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT
 #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
@@ -152,6 +153,7 @@ static const struct attribute_spec gfc_attribute_table[] =
 #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_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
 #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE  gfc_omp_privatize_by_reference
index e1907a4..bfd24f9 100644 (file)
@@ -169,6 +169,48 @@ gfc_omp_array_data (tree decl, bool type_only)
   return decl;
 }
 
+/* Return the byte-size of the passed array descriptor. */
+
+tree
+gfc_omp_array_size (tree decl, gimple_seq *pre_p)
+{
+  stmtblock_t block;
+  if (POINTER_TYPE_P (TREE_TYPE (decl)))
+    decl = build_fold_indirect_ref (decl);
+  tree type = TREE_TYPE (decl);
+  gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  bool allocatable = (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+                     || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
+                     || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT);
+  gfc_init_block (&block);
+  tree size = gfc_full_array_size (&block, decl,
+                                  GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)));
+  size = fold_convert (size_type_node, size);
+  tree elemsz = gfc_get_element_type (TREE_TYPE (decl));
+  if (TREE_CODE (elemsz) == ARRAY_TYPE && TYPE_STRING_FLAG (elemsz))
+    elemsz = gfc_conv_descriptor_elem_len (decl);
+  else
+    elemsz = TYPE_SIZE_UNIT (elemsz);
+  size = fold_build2 (MULT_EXPR, size_type_node, size, elemsz);
+  if (!allocatable)
+    gimplify_and_add (gfc_finish_block (&block), pre_p);
+  else
+    {
+      tree var = create_tmp_var (size_type_node);
+      gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, sizetype, var, size));
+      tree tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+                                 gfc_conv_descriptor_data_get (decl),
+                                 null_pointer_node);
+      tmp = build3_loc (input_location, COND_EXPR, void_type_node, tmp,
+                       gfc_finish_block (&block),
+                       build2 (MODIFY_EXPR, sizetype, var, size_zero_node));
+      gimplify_and_add (tmp, pre_p);
+      size = var;
+    }
+  return size;
+}
+
+
 /* True if OpenMP should privatize what this DECL points to rather
    than the DECL itself.  */
 
@@ -1922,16 +1964,7 @@ gfc_trans_omp_variable_list (enum omp_clause_code code,
        if (t != error_mark_node)
          {
            tree node;
-           /* For HAS_DEVICE_ADDR of an array descriptor, firstprivatize the
-              descriptor such that the bounds are available; its data component
-              is unmodified; it is handled as device address inside target. */
-           if (code == OMP_CLAUSE_HAS_DEVICE_ADDR
-               && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (t))
-                   || (POINTER_TYPE_P (TREE_TYPE (t))
-                       && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (t))))))
-             node = build_omp_clause (input_location, OMP_CLAUSE_FIRSTPRIVATE);
-           else
-             node = build_omp_clause (input_location, code);
+           node = build_omp_clause (input_location, code);
            OMP_CLAUSE_DECL (node) = t;
            list = gfc_trans_add_clause (node, list);
 
index 623acee..03d5288 100644 (file)
@@ -808,6 +808,7 @@ bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
 bool gfc_omp_is_allocatable_or_ptr (const_tree);
 tree gfc_omp_check_optional_argument (tree, bool);
 tree gfc_omp_array_data (tree, bool);
+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);
 enum omp_clause_defaultmap_kind gfc_omp_predetermined_mapping (tree);
index e226395..95d8dec 100644 (file)
@@ -84,6 +84,7 @@ extern enum omp_clause_default_kind lhd_omp_predetermined_sharing (tree);
 extern enum omp_clause_defaultmap_kind lhd_omp_predetermined_mapping (tree);
 extern tree lhd_omp_assignment (tree, tree, tree);
 extern void lhd_omp_finish_clause (tree, gimple_seq *, bool);
+extern tree lhd_omp_array_size (tree, gimple_seq *);
 struct gimplify_omp_ctx;
 extern void lhd_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *,
                                               tree);
@@ -257,6 +258,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_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
 #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE hook_bool_const_tree_false
@@ -290,6 +292,7 @@ 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_IS_ALLOCATABLE_OR_PTR, \
   LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT, \
   LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE, \
index df97067..97e5139 100644 (file)
@@ -634,6 +634,14 @@ lhd_omp_finish_clause (tree, gimple_seq *, bool)
 {
 }
 
+/* Return array size; cf. omp_array_data.  */
+
+tree
+lhd_omp_array_size (tree, gimple_seq *)
+{
+  return NULL_TREE;
+}
+
 /* Return true if DECL is a scalar variable (for the purpose of
    implicit firstprivatization & mapping). Only if alloc_ptr_ok
    are allocatables and pointers accepted. */
index 4731f08..7502555 100644 (file)
@@ -246,6 +246,11 @@ 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 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.  */
+  tree (*omp_array_size) (tree, gimple_seq *pre_p);
+
   /* True if OpenMP should regard this DECL as being a scalar which has Fortran's
      allocatable or pointer attribute.  */
   bool (*omp_is_allocatable_or_ptr) (const_tree);
index b037938..16f5965 100644 (file)
@@ -1372,7 +1372,9 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
               || OMP_CLAUSE_CODE (c) == OMP_CLAUSE_HAS_DEVICE_ADDR)
              && is_gimple_omp_offloaded (ctx->stmt))
            {
-             if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_FIRSTPRIVATE)
+             if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_FIRSTPRIVATE
+                 || (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_HAS_DEVICE_ADDR
+                     && lang_hooks.decls.omp_array_data (decl, true)))
                {
                  by_ref = !omp_privatize_by_reference (decl);
                  install_var_field (decl, by_ref, 3, ctx);
@@ -1424,6 +1426,15 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
                install_var_field (decl, by_ref, 3, ctx);
            }
          install_var_local (decl, ctx);
+         /* For descr arrays on target: firstprivatize data + attach ptr.  */
+         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))
+           {
+             install_var_field (decl, false, 16 | 3, ctx);
+             install_var_field (decl, true, 8 | 3, ctx);
+           }
          break;
 
        case OMP_CLAUSE_USE_DEVICE_PTR:
@@ -12871,6 +12882,7 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
        break;
 
       case OMP_CLAUSE_FIRSTPRIVATE:
+      omp_firstprivate_recv:
        gcc_checking_assert (offloaded);
        if (is_gimple_omp_oacc (ctx->stmt))
          {
@@ -12902,6 +12914,10 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
            SET_DECL_VALUE_EXPR (new_var, x);
            DECL_HAS_VALUE_EXPR_P (new_var) = 1;
          }
+         /* 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))
+           map_cnt += 2;
        break;
 
       case OMP_CLAUSE_PRIVATE:
@@ -12941,6 +12957,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
            while (TREE_CODE (var) == INDIRECT_REF
                   || TREE_CODE (var) == ARRAY_REF)
              var = TREE_OPERAND (var, 0);
+           if (lang_hooks.decls.omp_array_data (var, true))
+             goto omp_firstprivate_recv;
          }
        map_cnt++;
        if (is_variable_sized (var))
@@ -13354,6 +13372,7 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
            break;
 
          case OMP_CLAUSE_FIRSTPRIVATE:
+         omp_has_device_addr_descr:
            if (is_gimple_omp_oacc (ctx->stmt))
              goto oacc_firstprivate_map;
            ovar = OMP_CLAUSE_DECL (c);
@@ -13419,6 +13438,82 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
                                 <= tree_to_uhwi (TYPE_MAX_VALUE (tkind_type)));
            CONSTRUCTOR_APPEND_ELT (vkind, purpose,
                                    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))
+             {
+               tree not_null_lb, null_lb, after_lb;
+               tree var1, var2, size1, size2;
+               tree present = omp_check_optional_argument (ovar, true);
+               if (present)
+                 {
+                   location_t clause_loc = OMP_CLAUSE_LOCATION (c);
+                   not_null_lb = create_artificial_label (clause_loc);
+                   null_lb = create_artificial_label (clause_loc);
+                   after_lb = create_artificial_label (clause_loc);
+                   gimple_seq seq = NULL;
+                   present = force_gimple_operand (present, &seq, true,
+                                                   NULL_TREE);
+                   gimple_seq_add_seq (&ilist, seq);
+                   gimple_seq_add_stmt (&ilist,
+                     gimple_build_cond_from_tree (present,
+                                                  not_null_lb, null_lb));
+                   gimple_seq_add_stmt (&ilist,
+                                        gimple_build_label (not_null_lb));
+                 }
+               var1 = lang_hooks.decls.omp_array_data (var, false);
+               size1 = lang_hooks.decls.omp_array_size (var, &ilist);
+               var2 = build_fold_addr_expr (x);
+               if (!POINTER_TYPE_P (TREE_TYPE (var)))
+                 var = build_fold_addr_expr (var);
+               size2 = fold_build2 (POINTER_DIFF_EXPR, ssizetype,
+                                  build_fold_addr_expr (var1), var);
+               size2 = fold_convert (sizetype, size2);
+               if (present)
+                 {
+                   tree tmp = create_tmp_var (TREE_TYPE (var1));
+                   gimplify_assign (tmp, var1, &ilist);
+                   var1 = tmp;
+                   tmp = create_tmp_var (TREE_TYPE (var2));
+                   gimplify_assign (tmp, var2, &ilist);
+                   var2 = tmp;
+                   tmp = create_tmp_var (TREE_TYPE (size1));
+                   gimplify_assign (tmp, size1, &ilist);
+                   size1 = tmp;
+                   tmp = create_tmp_var (TREE_TYPE (size2));
+                   gimplify_assign (tmp, size2, &ilist);
+                   size2 = tmp;
+                   gimple_seq_add_stmt (&ilist, gimple_build_goto (after_lb));
+                   gimple_seq_add_stmt (&ilist, gimple_build_label (null_lb));
+                   gimplify_assign (var1, null_pointer_node, &ilist);
+                   gimplify_assign (var2, null_pointer_node, &ilist);
+                   gimplify_assign (size1, size_zero_node, &ilist);
+                   gimplify_assign (size2, size_zero_node, &ilist);
+                   gimple_seq_add_stmt (&ilist, gimple_build_label (after_lb));
+                 }
+               x = build_sender_ref ((splay_tree_key) &DECL_NAME (ovar), ctx);
+               gimplify_assign (x, var1, &ilist);
+               tkind = GOMP_MAP_FIRSTPRIVATE;
+               talign = DECL_ALIGN_UNIT (ovar);
+               talign = ceil_log2 (talign);
+               tkind |= talign << talign_shift;
+               gcc_checking_assert (tkind
+                                    <= tree_to_uhwi (
+                                         TYPE_MAX_VALUE (tkind_type)));
+               purpose = size_int (map_idx++);
+               CONSTRUCTOR_APPEND_ELT (vsize, purpose, size1);
+               if (TREE_CODE (size1) != INTEGER_CST)
+                 TREE_STATIC (TREE_VEC_ELT (t, 1)) = 0;
+               CONSTRUCTOR_APPEND_ELT (vkind, purpose,
+                                       build_int_cstu (tkind_type, tkind));
+               x = build_sender_ref ((splay_tree_key) &DECL_UID (ovar), ctx);
+               gimplify_assign (x, var2, &ilist);
+               tkind = GOMP_MAP_ATTACH;
+               purpose = size_int (map_idx++);
+               CONSTRUCTOR_APPEND_ELT (vsize, purpose, size2);
+               CONSTRUCTOR_APPEND_ELT (vkind, purpose,
+                                       build_int_cstu (tkind_type, tkind));
+             }
            break;
 
          case OMP_CLAUSE_USE_DEVICE_PTR:
@@ -13428,6 +13523,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
            ovar = OMP_CLAUSE_DECL (c);
            if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_HAS_DEVICE_ADDR)
              {
+               if (lang_hooks.decls.omp_array_data (ovar, true))
+                 goto omp_has_device_addr_descr;
                while (TREE_CODE (ovar) == INDIRECT_REF
                       || TREE_CODE (ovar) == ARRAY_REF)
                  ovar = TREE_OPERAND (ovar, 0);
@@ -13594,6 +13691,7 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
          default:
            break;
          case OMP_CLAUSE_FIRSTPRIVATE:
+         omp_firstprivatize_data_region:
            if (is_gimple_omp_oacc (ctx->stmt))
              break;
            var = OMP_CLAUSE_DECL (c);
@@ -13688,6 +13786,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
            do_optional_check = false;
            var = OMP_CLAUSE_DECL (c);
            is_array_data = lang_hooks.decls.omp_array_data (var, true) != NULL;
+           if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_HAS_DEVICE_ADDR && is_array_data)
+             goto omp_firstprivatize_data_region;
 
            if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR
                && OMP_CLAUSE_CODE (c) != OMP_CLAUSE_HAS_DEVICE_ADDR)
index ab2191b..4740f8a 100644 (file)
@@ -1352,7 +1352,24 @@ gomp_map_vars_internal (struct gomp_device_descr *devicep,
                gomp_copy_host2dev (devicep, aq,
                                    (void *) (tgt->tgt_start + tgt_size),
                                    (void *) hostaddrs[i], len, false, cbufp);
+               /* Save device address in hostaddr to permit latter availablity
+                  when doing a deep-firstprivate with pointer attach.  */
+               hostaddrs[i] = (void *) (tgt->tgt_start + tgt_size);
                tgt_size += len;
+
+               /* If followed by GOMP_MAP_ATTACH, pointer assign this
+                  firstprivate to hostaddrs[i+1], which is assumed to contain a
+                  device address.  */
+               if (i + 1 < mapnum
+                   && (GOMP_MAP_ATTACH
+                       == (typemask & get_kind (short_mapkind, kinds, i+1))))
+                 {
+                   uintptr_t target = (uintptr_t) hostaddrs[i];
+                   void *devptr = *(void**) hostaddrs[i+1] + sizes[i+1];
+                   gomp_copy_host2dev (devicep, aq, devptr, &target,
+                                       sizeof (void *), false, cbufp);
+                   ++i;
+                 }
                continue;
              case GOMP_MAP_FIRSTPRIVATE_INT:
              case GOMP_MAP_ZERO_LEN_ARRAY_SECTION:
@@ -2519,6 +2536,11 @@ copy_firstprivate_data (char *tgt, size_t mapnum, void **hostaddrs,
        memcpy (tgt + tgt_size, hostaddrs[i], sizes[i]);
        hostaddrs[i] = tgt + tgt_size;
        tgt_size = tgt_size + sizes[i];
+       if (i + 1 < mapnum && (kinds[i+1] & 0xff) == GOMP_MAP_ATTACH)
+         {
+           *(*(uintptr_t**) hostaddrs[i+1] + sizes[i+1]) = (uintptr_t) hostaddrs[i];
+           ++i;
+         }
       }
 }
 
diff --git a/libgomp/testsuite/libgomp.fortran/target-firstprivate-1.f90 b/libgomp/testsuite/libgomp.fortran/target-firstprivate-1.f90
new file mode 100644 (file)
index 0000000..7b77992
--- /dev/null
@@ -0,0 +1,33 @@
+! PR fortran/104949
+
+implicit none (type,external)
+integer, allocatable :: A(:)
+A = [1,2,3,4,5,6]
+
+!$omp parallel firstprivate(A)
+!$omp master
+  if (any (A /= [1,2,3,4,5])) error stop
+  A(:) = [99,88,77,66,55]
+!$omp end master
+!$omp end parallel
+
+!$omp target firstprivate(A)
+  if (any (A /= [1,2,3,4,5])) error stop
+  A(:) = [99,88,77,66,55]
+!$omp end target
+if (any (A /= [1,2,3,4,5])) error stop
+
+!$omp parallel default(firstprivate)
+!$omp master
+  if (any (A /= [1,2,3,4,5])) error stop
+  A(:) = [99,88,77,66,55]
+!$omp end master
+!$omp end parallel
+if (any (A /= [1,2,3,4,5])) error stop
+
+!$omp target defaultmap(firstprivate)
+  if (any (A /= [1,2,3,4,5])) error stop
+  A(:) = [99,88,77,66,55]
+!$omp end target
+if (any (A /= [1,2,3,4,5])) error stop
+end
diff --git a/libgomp/testsuite/libgomp.fortran/target-firstprivate-2.f90 b/libgomp/testsuite/libgomp.fortran/target-firstprivate-2.f90
new file mode 100644 (file)
index 0000000..d00b407
--- /dev/null
@@ -0,0 +1,113 @@
+! PR fortran/104949
+
+module m
+use omp_lib
+implicit none (type, external)
+
+contains
+subroutine one
+  integer, allocatable :: x(:)
+  integer :: i
+
+  do i = 1, omp_get_num_devices() + 1
+    !$omp target firstprivate(x)
+      if (allocated(x)) error stop
+    !$omp end target
+    if (allocated(x)) error stop
+  end do
+
+  do i = 1, omp_get_num_devices() + 1
+    !$omp target firstprivate(x, i)
+      if (allocated(x)) error stop
+      x = [10,20,30,40] + i
+      if (any (x /= [10,20,30,40] + i)) error stop
+      ! This leaks memory!
+      ! deallocate(x)
+    !$omp end target
+    if (allocated(x)) error stop
+  end do
+
+  x = [1,2,3,4]
+
+  do i = 1, omp_get_num_devices() + 1
+    !$omp target firstprivate(x, i)
+      if (i <= 0) error stop
+      if (.not.allocated(x)) error stop
+      if (size(x) /= 4) error stop
+      if (lbound(x,1) /= 1) error stop
+      if (any (x /= [1,2,3,4])) error stop
+      ! no reallocation, just malloced + assignment
+      x = [10,20,30,40] + i
+      if (any (x /= [10,20,30,40] + i)) error stop
+      ! This leaks memory!
+      ! deallocate(x)
+    !$omp end target
+    if (.not.allocated(x)) error stop
+    if (size(x) /= 4) error stop
+    if (lbound(x,1) /= 1) error stop
+    if (any (x /= [1,2,3,4])) error stop
+  end do
+  deallocate(x)
+end
+
+subroutine two
+  character(len=:), allocatable :: x(:)
+  character(len=5)  :: str
+  integer :: i
+
+  str = "abcde" ! work around for PR fortran/91544
+  do i = 1, omp_get_num_devices() + 1
+    !$omp target firstprivate(x)
+      if (allocated(x)) error stop
+    !$omp end target
+    if (allocated(x)) error stop
+  end do
+
+  do i = 1, omp_get_num_devices() + 1
+    !$omp target firstprivate(x, i)
+      if (allocated(x)) error stop
+      ! no reallocation, just malloced + assignment
+      x = [character(len=2+i) :: str,"fhji","klmno"]
+      if (len(x) /= 2+i) error stop
+      if (any (x /= [character(len=2+i) :: str,"fhji","klmno"])) error stop
+      ! This leaks memory!
+      ! deallocate(x)
+    !$omp end target
+    if (allocated(x)) error stop
+  end do
+
+  x = [character(len=4) :: "ABCDE","FHJI","KLMNO"]
+
+  do i = 1, omp_get_num_devices() + 1
+    !$omp target firstprivate(x, i)
+      if (i <= 0) error stop
+      if (.not.allocated(x)) error stop
+      if (size(x) /= 3) error stop
+      if (lbound(x,1) /= 1) error stop
+      if (len(x) /= 4) error stop
+      if (any (x /= [character(len=4) :: "ABCDE","FHJI","KLMNO"])) error stop
+      !! Reallocation runs into the issue PR fortran/105538
+      !!
+      !!x = [character(len=2+i) :: str,"fhji","klmno"]
+      !!if (len(x) /= 2+i) error stop
+      !!if (any (x /= [character(len=2+i) :: str,"fhji","klmno"])) error stop
+      !! This leaks memory!
+      !! deallocate(x)
+      ! Just assign:
+      x = [character(len=4) :: "abcde","fhji","klmno"]
+      if (any (x /= [character(len=4) :: "abcde","fhji","klmno"])) error stop
+    !$omp end target
+    if (.not.allocated(x)) error stop
+    if (lbound(x,1) /= 1) error stop
+    if (size(x) /= 3) error stop
+    if (len(x) /= 4) error stop
+    if (any (x /= [character(len=4) :: "ABCDE","FHJI","KLMNO"])) error stop
+  end do
+  deallocate(x)
+end
+end module m
+
+use m
+call one
+call two
+end
diff --git a/libgomp/testsuite/libgomp.fortran/target-firstprivate-3.f90 b/libgomp/testsuite/libgomp.fortran/target-firstprivate-3.f90
new file mode 100644 (file)
index 0000000..7406cdc
--- /dev/null
@@ -0,0 +1,24 @@
+implicit none
+  integer, allocatable :: x(:)
+  x = [1,2,3,4]
+  call foo(x)
+  if (any (x /= [1,2,3,4])) error stop
+  call foo()
+contains
+subroutine foo(c)
+  integer, allocatable, optional :: c(:)
+  logical :: is_present
+  is_present = present (c)
+  !$omp target firstprivate(c)
+    if (is_present) then
+      if (.not. allocated(c)) error stop
+      if (any (c /= [1,2,3,4])) error stop
+      c = [99,88,77,66]
+      if (any (c /= [99,88,77,66])) error stop
+    end if
+  !$omp end target
+  if (is_present) then
+    if (any (c /= [1,2,3,4])) error stop
+  end if
+end
+end