OpenMP: Enable has_device_addr clause for 'dispatch' in Fortran

Fortran version of commit r15-6178-g2cbb2408a830a6 for C/C++.
However, the has_device_addr clause on dispatch only becomes really
useful (for C++ and Fortran) once the 'need_device_addr' modifier
to declare variant's 'adjust_args' clause is supported (i.e. with
a future commit).

gcc/fortran/ChangeLog:

	* openmp.cc (OMP_DISPATCH_CLAUSES): Add OMP_CLAUSE_HAS_DEVICE_ADDR.

gcc/testsuite/ChangeLog:

	* gfortran.dg/gomp/adjust-args-10.f90: New test.

diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 73d7803ff9c55a188b9697dd4031a6b5ba446735..79c0f1b2e62a5f5cc7dfe3d91348b7acef0a6fe8 100644 (file)
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -5018,7 +5018,8 @@ cleanup:
    | OMP_CLAUSE_INIT | OMP_CLAUSE_DESTROY | OMP_CLAUSE_USE)
 #define OMP_DISPATCH_CLAUSES                                                   \
   (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS    \
-   | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT)
+   | OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT       \
+   | OMP_CLAUSE_HAS_DEVICE_ADDR)
 
 
 static match

diff --git a/gcc/testsuite/gfortran.dg/gomp/adjust-args-10.f90 b/gcc/testsuite/gfortran.dg/gomp/adjust-args-10.f90
new file mode 100644 (file)
index 0000000..3b649b5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/adjust-args-10.f90
@@ -0,0 +1,99 @@
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! This mainly checks 'has_device_addr' without associated 'need_device_addr'
+!
+! Do diagnostic check / dump check only;
+! Note: this test should work as run-test as well.
+
+module m
+  use iso_c_binding
+  ! use omp_lib
+  implicit none (type, external)
+  interface
+    integer function omp_get_default_device (); end
+    integer function omp_get_num_devices (); end
+  end interface
+
+contains
+  subroutine g (x, y)
+    !$omp declare variant(f) adjust_args(need_device_ptr: x, y) match(construct={dispatch})
+    type(c_ptr), value :: x, y
+  end
+
+  subroutine f (cfrom, cto)
+    type(c_ptr), value :: cfrom, cto
+    integer, save :: cnt = 0
+    cnt = cnt + 1
+    if (cnt >= 3) then
+      if (omp_get_default_device () /= -1  &
+          .and. omp_get_default_device () < omp_get_num_devices ()) then
+        ! On offload device but not mapped
+        if (.not. c_associated(cfrom)) & ! Not mapped
+          stop 1
+      else
+        block
+          integer, pointer :: from(:)
+          call c_f_pointer(cfrom, from, shape=[1])
+          if (from(1) /= 5) &
+            stop 2
+        end block
+      end if
+      return
+    end if
+
+    !$omp target is_device_ptr(cfrom, cto)
+      block
+        integer, pointer :: from(:), to(:)
+        call c_f_pointer(cfrom, from, shape=[2])
+        call c_f_pointer(cto, to, shape=[2])
+        to(1) = from(1) * 10
+        to(2) = from(2) * 10
+      end block
+  end
+
+  subroutine sub (a, b)
+    integer, target :: a(:), b(:)
+    type(c_ptr), target :: ca, cb
+
+    ca = c_loc(a)
+    cb = c_loc(b)
+
+    ! The has_device_addr is a bit questionable as the caller is not actually
+    ! passing a device address - but we cannot pass one because of the
+    ! following:
+    !
+    ! As for 'b' need_device_ptr has been specified and 'b' is not
+    ! in the semantic requirement set 'is_device_ptr' (and only in 'has_device_addr')
+    ! "the argument is converted in the same manner that a use_device_ptr clause
+    !  on a target_data construct converts its pointer"
+
+    !$omp dispatch is_device_ptr(ca), has_device_addr(cb)
+      call g (ca, cb)  ! { dg-warning "'has_device_addr' for 'cb' does not imply 'is_device_ptr' required for 'need_device_ptr' \\\[-Wopenmp\\\]" }
+  end
+end
+
+program main
+  use m
+  implicit none (type, external)
+
+  integer, target :: A(2), B(2) = [123, 456], C(1) = [5]
+  integer, pointer :: p(:)
+
+  p => A
+
+  !$omp target enter data map(A, B)
+
+  ! Note: We don't add  'use_device_addr(B)' here;
+  ! if we do, it will fail with an illegal memory access (why?).
+  !$omp target data use_device_ptr(p)
+    call sub(p, B)
+    call sub(C, B)  ! C is not mapped -> 'from' ptr == NULL
+  !$omp end target data
+
+  !$omp target exit data map(A, B)
+end
+
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch is_device_ptr\\(ca\\) has_device_addr\\(cb\\)" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "__builtin_omp_get_mapped_ptr" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = __builtin_omp_get_mapped_ptr \\(cb" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "f \\(ca\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } }