OpenMP: Handle descriptors in target's firstprivate [PR104949]

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.

4 files changed, 192 insertions, 0 deletions

diff --git a/libgomp/target.c b/libgomp/target.c
index ab2191b..4740f8a 100644
--- a/libgomp/target.c
+++ b/libgomp/target.c
@@ -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
index 0000000..7b77992
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-firstprivate-1.f90
@@ -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
index 0000000..d00b407
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-firstprivate-2.f90
@@ -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
index 0000000..7406cdc
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-firstprivate-3.f90
@@ -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