OpenMP: Fix use_device_{addr,ptr} with in-data-sharing arg

For array-descriptor vars, the descriptor is assigned to a temporary. However,
this failed when the clause's argument was in turn in a data-sharing clause
as the outer context's VALUE_EXPR wasn't used.

GCC 12/mainline patch submitted at:
https://gcc.gnu.org/pipermail/gcc-patches/2022-April/593419.html

gcc/ChangeLog:

        * omp-low.c (lower_omp_target): Fix use_device_{addr,ptr} with list
        item that is in an outer data-sharing clause.

libgomp/ChangeLog:

        * testsuite/libgomp.fortran/use_device_addr-5.f90: New test.

diff --git a/gcc/omp-low.c b/gcc/omp-low.c
index ce30f53dbb59c97f725b2dcc5149d63774ff5dc5..ee6b42714473dc3f088b7d0f7059d5356ebcfed5 100644 (file)
--- a/gcc/omp-low.c
+++ b/gcc/omp-low.c
@@ -14570,26 +14570,30 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
                new_var = lookup_decl (var, ctx);
                new_var = DECL_VALUE_EXPR (new_var);
                tree v = new_var;
+               tree v2 = var;
+               if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_PTR
+                   || OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR)
+                 {
+                   v2 = maybe_lookup_decl_in_outer_ctx (var, ctx);
+                   if (DECL_HAS_VALUE_EXPR_P (v2))
+                     v2 = DECL_VALUE_EXPR (v2);
+                 }
 
                if (is_ref)
                  {
-                   var = build_fold_indirect_ref (var);
-                   gimplify_expr (&var, &assign_body, NULL, is_gimple_val,
-                                  fb_rvalue);
-                   v = create_tmp_var_raw (TREE_TYPE (var), get_name (var));
+                   v2 = build_fold_indirect_ref (v2);
+                   v = create_tmp_var_raw (TREE_TYPE (v2), get_name (var));
                    gimple_add_tmp_var (v);
                    TREE_ADDRESSABLE (v) = 1;
-                   gimple_seq_add_stmt (&assign_body,
-                                        gimple_build_assign (v, var));
+                   gimplify_assign (v, v2, &assign_body);
                    tree rhs = build_fold_addr_expr (v);
                    gimple_seq_add_stmt (&assign_body,
                                         gimple_build_assign (new_var, rhs));
                  }
                else
-                 gimple_seq_add_stmt (&assign_body,
-                                      gimple_build_assign (new_var, var));
+                 gimplify_assign (new_var, v2, &assign_body);
 
-               tree v2 = lang_hooks.decls.omp_array_data (unshare_expr (v), false);
+               v2 = lang_hooks.decls.omp_array_data (unshare_expr (v), false);
                gcc_assert (v2);
                gimplify_expr (&x, &assign_body, NULL, is_gimple_val, fb_rvalue);
                gimple_seq_add_stmt (&assign_body,

diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-5.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-5.f90
new file mode 100644 (file)
index 0000000..3892b8b
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-5.f90
@@ -0,0 +1,143 @@
+program main
+  use omp_lib
+  implicit none
+  integer, allocatable :: aaa(:,:,:)
+  integer :: i
+
+  allocate (aaa(-4:10,-3:8,2))
+  aaa(:,:,:) = reshape ([(i, i = 1, size(aaa))], shape(aaa))
+
+  do i = 0, omp_get_num_devices()
+    !$omp target data map(to: aaa) device(i)
+      call test_addr (aaa, i)
+      call test_ptr (aaa, i)
+    !$omp end target data
+  end do
+  deallocate (aaa)
+
+contains
+
+  subroutine test_addr (aaaa, dev)
+    use iso_c_binding
+    integer, target, allocatable :: aaaa(:,:,:), bbbb(:,:,:)
+    integer, value :: dev
+    integer :: i
+    type(c_ptr) :: ptr
+    logical :: is_shared
+
+    is_shared = .false.
+    !$omp target device(dev) map(to: is_shared)
+      is_shared = .true.
+    !$omp end target
+
+    allocate (bbbb(-4:10,-3:8,2))
+    bbbb(:,:,:) = reshape ([(-i, i = 1, size(bbbb))], shape(bbbb))
+    !$omp target enter data map(to: bbbb) device(dev)
+    if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 1
+    if (any (shape (aaaa) /= [15, 12, 2])) error stop 2
+    if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 3
+    if (any (shape (bbbb) /= [15, 12, 2])) error stop 4
+    if (any (aaaa /= -bbbb)) error stop 5
+    if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
+      error stop 6
+
+    !$omp parallel do shared(bbbb, aaaa)
+    do i = 1,1
+      if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 5
+      if (any (shape (aaaa) /= [15, 12, 2])) error stop 6
+      if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 7
+      if (any (shape (bbbb) /= [15, 12, 2])) error stop 8
+      if (any (aaaa /= -bbbb)) error stop 5
+      if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
+        error stop 6
+      ptr = c_loc (aaaa)
+      !$omp target data use_device_addr(bbbb, aaaa) device(dev)
+        if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 9
+        if (any (shape (aaaa) /= [15, 12, 2])) error stop 10
+        if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 11
+        if (any (shape (bbbb) /= [15, 12, 2])) error stop 12
+        if (is_shared) then
+          if (any (aaaa /= -bbbb)) error stop 5
+          if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
+            error stop 6
+        end if
+        if (is_shared .neqv. c_associated (ptr, c_loc (aaaa))) error stop
+
+!        !$omp target has_device_addr(bbbb, aaaa) device(dev)
+!           if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 9
+!           if (any (shape (aaaa) /= [15, 12, 2])) error stop 10
+!           if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 11
+!           if (any (shape (bbbb) /= [15, 12, 2])) error stop 12
+!           if (any (aaaa /= -bbbb)) error stop 5
+!           if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
+!             error stop 6
+!        !$omp end target
+      !$omp end target data
+    end do
+    !$omp target exit data map(delete: bbbb) device(dev)
+    deallocate (bbbb)
+  end subroutine test_addr
+
+  subroutine test_ptr (aaaa, dev)
+    use iso_c_binding
+    integer, target, allocatable :: aaaa(:,:,:), bbbb(:,:,:)
+    integer, value :: dev
+    integer :: i
+    type(c_ptr) :: ptr
+    logical :: is_shared
+
+    is_shared = .false.
+    !$omp target device(dev) map(to: is_shared)
+      is_shared = .true.
+    !$omp end target
+
+    allocate (bbbb(-4:10,-3:8,2))
+    bbbb(:,:,:) = reshape ([(-i, i = 1, size(bbbb))], shape(bbbb))
+    !$omp target enter data map(to: bbbb) device(dev)
+    if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 1
+    if (any (shape (aaaa) /= [15, 12, 2])) error stop 2
+    if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 3
+    if (any (shape (bbbb) /= [15, 12, 2])) error stop 4
+    if (any (aaaa /= -bbbb)) error stop 5
+    if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
+      error stop 6
+
+    !$omp parallel do shared(bbbb, aaaa)
+    do i = 1,1
+      if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 5
+      if (any (shape (aaaa) /= [15, 12, 2])) error stop 6
+      if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 7
+      if (any (shape (bbbb) /= [15, 12, 2])) error stop 8
+      if (any (aaaa /= -bbbb)) error stop 5
+      if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
+        error stop 6
+      ptr = c_loc (aaaa)
+      !$omp target data use_device_ptr(bbbb, aaaa) device(dev)
+        if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 9
+        if (any (shape (aaaa) /= [15, 12, 2])) error stop 10
+        if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 11
+        if (any (shape (bbbb) /= [15, 12, 2])) error stop 12
+        if (is_shared) then
+          if (any (aaaa /= -bbbb)) error stop 5
+          if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
+            error stop 6
+        end if
+        if (is_shared .neqv. c_associated (ptr, c_loc (aaaa))) error stop
+
+        ! Uses has_device_addr due to PR fortran/105318
+        !!$omp target is_device_ptr(bbbb, aaaa) device(dev)
+!        !$omp target has_device_addr(bbbb, aaaa) device(dev)
+!           if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 9
+!           if (any (shape (aaaa) /= [15, 12, 2])) error stop 10
+!           if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 11
+!           if (any (shape (bbbb) /= [15, 12, 2])) error stop 12
+!           if (any (aaaa /= -bbbb)) error stop 5
+!           if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
+!             error stop 6
+!        !$omp end target
+      !$omp end target data
+    end do
+    !$omp target exit data map(delete: bbbb) device(dev)
+    deallocate (bbbb)
+  end subroutine test_ptr
+end program main