From 76bb3c50dd43a5f87d4f949cf0d0979144562e6c Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Wed, 18 Aug 2021 11:14:05 +0200 Subject: [PATCH] Fortran/OpenMP: Add memory routines existing for C/C++ This patch adds the Fortran interface for omp_alloc/omp_free and the omp_target_* memory routines, which were added in OpenMP 5.0 for C/C++ but only OpenMP 5.1 added them for Fortran. Those functions use BIND(C), i.e. on the libgomp side, the same interface as for C/C++ is used. Note: By using BIND(C) in omp_lib.h, files including this file no longer compiler with -std=f95 but require at least -std=f2003. libgomp/ChangeLog: * omp_lib.f90.in (omp_alloc, omp_free, omp_target_alloc, omp_target_free. omp_target_is_present, omp_target_memcpy, omp_target_memcpy_rect, omp_target_associate_ptr, omp_target_disassociate_ptr): Add interface. * omp_lib.h.in (omp_alloc, omp_free, omp_target_alloc, omp_target_free. omp_target_is_present, omp_target_memcpy, omp_target_memcpy_rect, omp_target_associate_ptr, omp_target_disassociate_ptr): Add interface. * testsuite/libgomp.fortran/alloc-1.F90: Remove local interface block for omp_alloc + omp_free. * testsuite/libgomp.fortran/alloc-4.f90: Likewise. * testsuite/libgomp.fortran/refcount-1.f90: New test. * testsuite/libgomp.fortran/target-12.f90: New test. --- libgomp/omp_lib.f90.in | 94 +++++++++++ libgomp/omp_lib.h.in | 97 ++++++++++++ libgomp/testsuite/libgomp.fortran/alloc-1.F90 | 16 -- libgomp/testsuite/libgomp.fortran/alloc-4.f90 | 16 -- .../testsuite/libgomp.fortran/refcount-1.f90 | 61 ++++++++ .../testsuite/libgomp.fortran/target-12.f90 | 147 ++++++++++++++++++ 6 files changed, 399 insertions(+), 32 deletions(-) create mode 100644 libgomp/testsuite/libgomp.fortran/refcount-1.f90 create mode 100644 libgomp/testsuite/libgomp.fortran/target-12.f90 diff --git a/libgomp/omp_lib.f90.in b/libgomp/omp_lib.f90.in index 6394e65bbf7..a36a5626123 100644 --- a/libgomp/omp_lib.f90.in +++ b/libgomp/omp_lib.f90.in @@ -670,6 +670,100 @@ end subroutine omp_display_env_8 end interface + interface + function omp_alloc (size, allocator) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t + import :: omp_allocator_handle_kind + type(c_ptr) :: omp_alloc + integer(c_size_t), value :: size + integer(omp_allocator_handle_kind), value :: allocator + end function omp_alloc + end interface + + interface + subroutine omp_free(ptr, allocator) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr + import :: omp_allocator_handle_kind + type(c_ptr), value :: ptr + integer(omp_allocator_handle_kind), value :: allocator + end subroutine + end interface + + interface + function omp_target_alloc (size, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int + type(c_ptr) :: omp_target_alloc + integer(c_size_t), value :: size + integer(c_int), value :: device_num + end function omp_target_alloc + end interface + + interface + subroutine omp_target_free (device_ptr, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int + type(c_ptr), value :: device_ptr + integer(c_int), value :: device_num + end subroutine omp_target_free + end interface + + interface + function omp_target_is_present (ptr, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int + integer(c_int) :: omp_target_is_present + type(c_ptr), value :: ptr + integer(c_int), value :: device_num + end function omp_target_is_present + end interface + + interface + function omp_target_memcpy (dst, src, length, dst_offset, & + src_offset, dst_device_num, & + src_device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int, c_size_t + integer(c_int) :: omp_target_memcpy + type(c_ptr), value :: dst, src + integer(c_size_t), value :: length, dst_offset, src_offset + integer(c_int), value :: dst_device_num, src_device_num + end function omp_target_memcpy + end interface + + interface + function omp_target_memcpy_rect (dst,src,element_size, num_dims, & + volume, dst_offsets, src_offsets, & + dst_dimensions, src_dimensions, & + dst_device_num, src_device_num) & + bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int, c_size_t + integer(c_int) :: omp_target_memcpy_rect + type(c_ptr), value :: dst, src + integer(c_size_t), value :: element_size + integer(c_int), value :: num_dims, dst_device_num, src_device_num + integer(c_size_t), intent(in) :: volume(*), dst_offsets(*), & + src_offsets(*), dst_dimensions(*), & + src_dimensions(*) + end function omp_target_memcpy_rect + end interface + + interface + function omp_target_associate_ptr (host_ptr, device_ptr, size, & + device_offset, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int + integer(c_int) :: omp_target_associate_ptr + type(c_ptr), value :: host_ptr, device_ptr + integer(c_size_t), value :: size, device_offset + integer(c_int), value :: device_num + end function omp_target_associate_ptr + end interface + + interface + function omp_target_disassociate_ptr (ptr, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int + integer(c_int) :: omp_target_disassociate_ptr + type(c_ptr), value :: ptr + integer(c_int), value :: device_num + end function omp_target_disassociate_ptr + end interface + #if _OPENMP >= 201811 !GCC$ ATTRIBUTES DEPRECATED :: omp_get_nested, omp_set_nested #endif diff --git a/libgomp/omp_lib.h.in b/libgomp/omp_lib.h.in index f2ad445f924..1c2eacba554 100644 --- a/libgomp/omp_lib.h.in +++ b/libgomp/omp_lib.h.in @@ -271,3 +271,100 @@ integer (omp_allocator_handle_kind) omp_get_default_allocator external omp_display_env + + interface + function omp_alloc (size, allocator) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t + use, intrinsic :: omp_lib_kinds + type(c_ptr) :: omp_alloc + integer(c_size_t), value :: size + integer(omp_allocator_handle_kind), value :: allocator + end function omp_alloc + end interface + + interface + subroutine omp_free(ptr, allocator) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr + use, intrinsic :: omp_lib_kinds + type(c_ptr), value :: ptr + integer(omp_allocator_handle_kind), value :: allocator + end subroutine + end interface + + interface + function omp_target_alloc (size, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int + type(c_ptr) :: omp_target_alloc + integer(c_size_t), value :: size + integer(c_int), value :: device_num + end function omp_target_alloc + end interface + + interface + subroutine omp_target_free (device_ptr, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int + type(c_ptr), value :: device_ptr + integer(c_int), value :: device_num + end subroutine omp_target_free + end interface + + interface + function omp_target_is_present (ptr, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int + integer(c_int) :: omp_target_is_present + type(c_ptr), value :: ptr + integer(c_int), value :: device_num + end function omp_target_is_present + end interface + + interface + function omp_target_memcpy (dst, src, length, dst_offset, & + & src_offset, dst_device_num, & + & src_device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int, c_size_t + integer(c_int) :: omp_target_memcpy + type(c_ptr), value :: dst, src + integer(c_size_t), value :: length, dst_offset, src_offset + integer(c_int), value :: dst_device_num, src_device_num + end function omp_target_memcpy + end interface + + interface + function omp_target_memcpy_rect (dst,src,element_size, num_dims, & + & volume, dst_offsets, & + & src_offsets, dst_dimensions, & + & src_dimensions, dst_device_num, & + & src_device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int, c_size_t + integer(c_int) :: omp_target_memcpy_rect + type(c_ptr), value :: dst, src + integer(c_size_t), value :: element_size + integer(c_int), value :: num_dims + integer(c_int), value :: dst_device_num, src_device_num + integer(c_size_t), intent(in) :: volume(*), dst_offsets(*) + integer(c_size_t), intent(in) :: src_offsets(*) + integer(c_size_t), intent(in) :: dst_dimensions(*) + integer(c_size_t), intent(in) :: src_dimensions(*) + end function omp_target_memcpy_rect + end interface + + interface + function omp_target_associate_ptr (host_ptr, device_ptr, size, & + & device_offset, device_num) & + & bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int + integer(c_int) :: omp_target_associate_ptr + type(c_ptr), value :: host_ptr, device_ptr + integer(c_size_t), value :: size, device_offset + integer(c_int), value :: device_num + end function omp_target_associate_ptr + end interface + + interface + function omp_target_disassociate_ptr (ptr, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int + integer(c_int) :: omp_target_disassociate_ptr + type(c_ptr), value :: ptr + integer(c_int), value :: device_num + end function omp_target_disassociate_ptr + end interface diff --git a/libgomp/testsuite/libgomp.fortran/alloc-1.F90 b/libgomp/testsuite/libgomp.fortran/alloc-1.F90 index 178ce771d45..e6365831984 100644 --- a/libgomp/testsuite/libgomp.fortran/alloc-1.F90 +++ b/libgomp/testsuite/libgomp.fortran/alloc-1.F90 @@ -36,22 +36,6 @@ type (omp_alloctrait), allocatable :: traits(:), traits5(:) - interface - ! omp_alloc + omp_free part of OpenMP for C/C++ - ! but not (yet) in the OpenMP spec for Fortran - type(c_ptr) function omp_alloc (size, handle) bind(C) - import - integer (c_size_t), value :: size - integer (omp_allocator_handle_kind), value :: handle - end function - - subroutine omp_free (ptr, handle) bind(C) - import - type (c_ptr), value :: ptr - integer (omp_allocator_handle_kind), value :: handle - end subroutine - end interface - type(c_ptr), volatile :: cp, cq, cr integer :: i integer(c_intptr_t) :: intptr diff --git a/libgomp/testsuite/libgomp.fortran/alloc-4.f90 b/libgomp/testsuite/libgomp.fortran/alloc-4.f90 index ce353b55eb0..87b6adda645 100644 --- a/libgomp/testsuite/libgomp.fortran/alloc-4.f90 +++ b/libgomp/testsuite/libgomp.fortran/alloc-4.f90 @@ -3,22 +3,6 @@ program main use ISO_C_Binding implicit none (external, type) - interface - ! omp_alloc + omp_free part of OpenMP for C/C++ - ! but not (yet) in the OpenMP spec for Fortran - type(c_ptr) function omp_alloc (size, handle) bind(C) - import - integer (c_size_t), value :: size - integer (omp_allocator_handle_kind), value :: handle - end function - - subroutine omp_free (ptr, handle) bind(C) - import - type (c_ptr), value :: ptr - integer (omp_allocator_handle_kind), value :: handle - end subroutine - end interface - type (omp_alloctrait) :: traits(3) integer (omp_allocator_handle_kind) :: a diff --git a/libgomp/testsuite/libgomp.fortran/refcount-1.f90 b/libgomp/testsuite/libgomp.fortran/refcount-1.f90 new file mode 100644 index 00000000000..e3b9d04af81 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/refcount-1.f90 @@ -0,0 +1,61 @@ +program main + use omp_lib + use iso_c_binding + implicit none (type, external) + + integer :: d, id + integer(kind=1), target :: a(4) + integer(kind=1), pointer :: p, q + + d = omp_get_default_device () + id = omp_get_initial_device () + + if (d < 0 .or. d >= omp_get_num_devices ()) & + d = id + + a = transfer (int(z'cdcdcdcd'), mold=a) + + !$omp target enter data map (to:a) + + a = transfer (int(z'abababab'), mold=a) + p => a(1) + q => a(3) + + !$omp target enter data map (alloc:p, q) + + if (d /= id) then + if (omp_target_is_present (c_loc(a), d) == 0) & + stop 1 + if (omp_target_is_present (c_loc(p), d) == 0) & + stop 2 + if (omp_target_is_present (c_loc(q), d) == 0) & + stop 3 + end if + + !$omp target exit data map (release:a) + + if (d /= id) then + if (omp_target_is_present (c_loc(a), d) == 0) & + stop 4 + if (omp_target_is_present (c_loc(p), d) == 0) & + stop 5 + if (omp_target_is_present (c_loc(q), d) == 0) & + stop 6 + end if + + !$omp target exit data map (from:q) + + if (d /= id) then + if (omp_target_is_present (c_loc(a), d) /= 0) & + stop 7 + if (omp_target_is_present (c_loc(p), d) /= 0) & + stop 8 + if (omp_target_is_present (c_loc(q), d) /= 0) & + stop 9 + + if (q /= int(z'cd', kind=1)) & + stop 10 + if (p /= int(z'ab', kind=1)) & + stop 11 + end if +end program main diff --git a/libgomp/testsuite/libgomp.fortran/target-12.f90 b/libgomp/testsuite/libgomp.fortran/target-12.f90 new file mode 100644 index 00000000000..17c78f18f9b --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/target-12.f90 @@ -0,0 +1,147 @@ +program main + use omp_lib + use iso_c_binding + implicit none (external, type) + integer :: d, id, i, j, k, l + logical :: err + integer, target :: q(0:127) + type(c_ptr) :: p + + integer(kind=c_size_t) :: volume(0:2) + integer(kind=c_size_t) :: dst_offsets(0:2) + integer(kind=c_size_t) :: src_offsets(0:2) + integer(kind=c_size_t) :: dst_dimensions(0:2) + integer(kind=c_size_t) :: src_dimensions(0:2) + integer(kind=c_size_t) :: empty(1:0) + + err = .false. + d = omp_get_default_device () + id = omp_get_initial_device () + + if (d < 0 .or. d >= omp_get_num_devices ()) & + d = id + + q = [(i, i = 0, 127)] + p = omp_target_alloc (130 * c_sizeof (q), d) + if (.not. c_associated (p)) & + stop 0 ! okay + + if (omp_target_memcpy_rect (C_NULL_PTR, C_NULL_PTR, 0_c_size_t, 0, & + empty, empty, empty, empty, empty, d, id) < 3 & + .or. omp_target_memcpy_rect (C_NULL_PTR, C_NULL_PTR, 0_c_size_t, 0, & + empty, empty, empty, empty, empty, & + id, d) < 3 & + .or. omp_target_memcpy_rect (C_NULL_PTR, C_NULL_PTR, 0_c_size_t, 0, & + empty, empty, empty, empty, empty, & + id, id) < 3) & + stop 1 + + if (omp_target_associate_ptr (c_loc (q), p, 128 * c_sizeof (q(0)), & + c_sizeof (q(0)), d) == 0) then + volume = [ 128, 0, 0 ] + dst_offsets = [ 0, 0, 0 ] + src_offsets = [ 1, 0, 0 ] + dst_dimensions = [ 128, 0, 0 ] + src_dimensions = [ 128, 0, 0 ] + + + if (omp_target_associate_ptr (c_loc (q), p, 128 * sizeof (q(0)), & + sizeof (q(0)), d) /= 0) & + stop 2 + + if (omp_target_is_present (c_loc (q), d) /= 1 & + .or. omp_target_is_present (c_loc (q(32)), d) /= 1 & + .or. omp_target_is_present (c_loc (q(127)), d) /= 1) & + stop 3 + + if (omp_target_memcpy (p, c_loc (q), 128 * sizeof (q(0)), sizeof (q(0)), & + 0_c_size_t, d, id) /= 0) & + stop 4 + + i = 0 + if (d >= 0) i = d + !$omp target if (d >= 0) device (i) map(alloc:q(0:31)) map(from:err) + err = .false. + do j = 0, 127 + if (q(j) /= j) then + err = .true. + else + q(j) = q(j) + 4 + end if + end do + !$omp end target + + if (err) & + stop 5 + + if (omp_target_memcpy_rect (c_loc (q), p, sizeof (q(0)), 1, volume, & + dst_offsets, src_offsets, dst_dimensions, & + src_dimensions, id, d) /= 0) & + stop 6 + + do i = 0, 127 + if (q(i) /= i + 4) & + stop 7 + end do + + volume(2) = 2 + volume(1) = 3 + volume(0) = 6 + dst_offsets(2) = 1 + dst_offsets(1) = 0 + dst_offsets(0) = 0 + src_offsets(2) = 1 + src_offsets(1) = 0 + src_offsets(0) = 3 + dst_dimensions(2) = 2 + dst_dimensions(1) = 3 + dst_dimensions(0) = 6 + src_dimensions(2) = 3 + src_dimensions(1) = 4 + src_dimensions(0) = 6 + + if (omp_target_memcpy_rect (p, c_loc (q), sizeof (q(0)), 3, volume, & + dst_offsets, src_offsets, dst_dimensions, & + src_dimensions, d, id) /= 0) & + stop 8 + + i = 0 + if (d >= 0) i = d + !$omp target if (d >= 0) device (i) map(alloc:q(1:32)) map(from:err) + err = .false. + do j = 0, 5 + do k = 0, 2 + do l = 0, 1 + if (q(j * 6 + k * 2 + l) /= 3 * 12 + 4 + 1 + l + k * 3 + j * 12) & + err = .true. + end do + end do + end do + !$omp end target + + if (err) & + stop 9 + + if (omp_target_memcpy (p, p, 10 * sizeof (q(1)), 51 * sizeof (q(1)), & + 111 * sizeof (q(1)), d, d) /= 0) & + stop 10 + + i = 0 + if (d >= 0) i = d + !$omp target if (d >= 0) device (i) map(alloc:q(0:31)) map(from:err) + err = .false. + do j = 1, 9 + if (q(50+j) /= q(110 + j)) & + err = .true. + end do + !$omp end target + + if (err) & + stop 11 + + if (omp_target_disassociate_ptr (c_loc (q), d) /= 0) & + stop 12 + end if + + call omp_target_free (p, d) +end program main