procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran/OpenMP: Add memory routines existing for C/C++

Browse source 
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.
This commit is contained in:
Tobias Burnus 2021-08-18 11:14:05 +02:00
parent 5079b7781a
commit 76bb3c50dd
6 changed files with 399 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

94
libgomp/omp_lib.f90.in
View file

@ -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

97
libgomp/omp_lib.h.in
View file

@ -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

16
libgomp/testsuite/libgomp.fortran/alloc-1.F90
View file

@ -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

16
libgomp/testsuite/libgomp.fortran/alloc-4.f90
View file

@ -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

61
libgomp/testsuite/libgomp.fortran/refcount-1.f90 Normal file
View file

@ -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

147
libgomp/testsuite/libgomp.fortran/target-12.f90 Normal file
View file

@ -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