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

libgomp: Add interop types and routines to OpenMP's headers and module

Browse source 
This commit adds OpenMP 5.1+'s interop enumeration, type and routine
declarations to the C/C++ header file and, new in OpenMP TR13, also to
the Fortran module and omp_lib.h header file.

While a stub implementation is provided, only with foreign runtime
support by the libgomp GPU plugins and with the 'interop' directive,
this becomes really useful.

libgomp/ChangeLog:

	* fortran.c (omp_get_interop_str_, omp_get_interop_name_,
	omp_get_interop_type_desc_, omp_get_interop_rc_desc_): Add.
	* libgomp.map (GOMP_5.1.3): New; add interop routines.
	* omp.h.in: Add interop typedefs, enum and prototypes.
	(__GOMP_DEFAULT_NULL): Define.
	(omp_target_memcpy_async, omp_target_memcpy_rect_async):
	Use it for the optional depend argument.
	* omp_lib.f90.in: Add paramters and interfaces for interop.
	* omp_lib.h.in: Likewise; move F90 '&' to column 81 for
	-ffree-length-80.
	* target.c (omp_get_num_interop_properties, omp_get_interop_int,
	omp_get_interop_ptr, omp_get_interop_str, omp_get_interop_name,
	omp_get_interop_type_desc, omp_get_interop_rc_desc): Add.
	* config/gcn/target.c (omp_get_num_interop_properties,
	omp_get_interop_int, omp_get_interop_ptr, omp_get_interop_str,
	omp_get_interop_name, omp_get_interop_type_desc,
	omp_get_interop_rc_desc): Add.
	* config/nvptx/target.c (omp_get_num_interop_properties,
	omp_get_interop_int, omp_get_interop_ptr, omp_get_interop_str,
	omp_get_interop_name, omp_get_interop_type_desc,
	omp_get_interop_rc_desc): Add.
	* testsuite/libgomp.c-c++-common/interop-routines-1.c: New test.
	* testsuite/libgomp.c-c++-common/interop-routines-2.c: New test.
	* testsuite/libgomp.fortran/interop-routines-1.F90: New test.
	* testsuite/libgomp.fortran/interop-routines-2.F90: New test.
	* testsuite/libgomp.fortran/interop-routines-3.F: New test.
	* testsuite/libgomp.fortran/interop-routines-4.F: New test.
	* testsuite/libgomp.fortran/interop-routines-5.F: New test.
	* testsuite/libgomp.fortran/interop-routines-6.F: New test.
	* testsuite/libgomp.fortran/interop-routines-7.F90: New test.
This commit is contained in:
Tobias Burnus 2024-08-28 11:50:43 +02:00
parent 7bd2a2f9e3
commit 0beac1db38
17 changed files with 1883 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

105
libgomp/config/gcn/target.c
View file

@ -185,3 +185,108 @@ GOMP_target_enter_exit_data (int device, size_t mapnum, void **hostaddrs,
(void) depend;
__builtin_unreachable ();
}
int
omp_get_num_interop_properties (const omp_interop_t interop
__attribute__ ((unused)))
{
return 0;
}
omp_intptr_t
omp_get_interop_int (const omp_interop_t interop,
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
if (ret_code == NULL)
return 0;
if (property_id < omp_ipr_first || property_id >= 0)
*ret_code = omp_irc_out_of_range;
else if (interop == omp_interop_none)
*ret_code = omp_irc_empty;
else
*ret_code = omp_irc_other;
return 0;
}
void *
omp_get_interop_ptr (const omp_interop_t interop,
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
if (ret_code == NULL)
return NULL;
if (property_id < omp_ipr_first || property_id >= 0)
*ret_code = omp_irc_out_of_range;
else if (interop == omp_interop_none)
*ret_code = omp_irc_empty;
else
*ret_code = omp_irc_other;
return NULL;
}
const char *
omp_get_interop_str (const omp_interop_t interop,
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
if (ret_code == NULL)
return NULL;
if (property_id < omp_ipr_first || property_id >= 0)
*ret_code = omp_irc_out_of_range;
else if (interop == omp_interop_none)
*ret_code = omp_irc_empty;
else
*ret_code = omp_irc_other;
return NULL;
}
const char *
omp_get_interop_name (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_property_t property_id)
{
static const char *prop_string[0 - omp_ipr_first]
= {"fr_id", "fr_name", "vendor", "vendor_name", "device_num", "platform",
"device", "device_context", "targetsync"};
if (property_id < omp_ipr_first || property_id >= 0)
return NULL;
return prop_string[omp_ipr_fr_id - property_id];
}
const char *
omp_get_interop_type_desc (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_property_t property_id
__attribute__ ((unused)))
{
return NULL;
}
const char *
omp_get_interop_rc_desc (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_rc_t ret_code)
{
static const char *rc_strings[omp_irc_no_value - omp_irc_other + 1]
= {"no meaningful value available",
"successful",
"provided interoperability object is equal to omp_interop_none",
"property ID is out of range",
"property type is integer; use omp_get_interop_int",
"property type is pointer; use omp_get_interop_ptr",
"property type is string; use omp_get_interop_str",
"obtaining properties is only supported on the initial device"};
/* omp_irc_other is returned by device-side omp_get_interop_{int,ptr,str};
the host returns for omp_irc_other NULL as it is not used. Besides the
three omp_interop_rc_t values used on the device side, handle host values
leaked to the device side. */
if (ret_code > omp_irc_no_value || ret_code < omp_irc_other)
return NULL;
return rc_strings[omp_irc_no_value - ret_code];
}
ialias (omp_get_num_interop_properties)
ialias (omp_get_interop_int)
ialias (omp_get_interop_ptr)
ialias (omp_get_interop_str)
ialias (omp_get_interop_name)
ialias (omp_get_interop_type_desc)
ialias (omp_get_interop_rc_desc)

105
libgomp/config/nvptx/target.c
View file

@ -197,3 +197,108 @@ GOMP_target_enter_exit_data (int device, size_t mapnum, void **hostaddrs,
(void) depend;
__builtin_unreachable ();
}
int
omp_get_num_interop_properties (const omp_interop_t interop
__attribute__ ((unused)))
{
return 0;
}
omp_intptr_t
omp_get_interop_int (const omp_interop_t interop,
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
if (ret_code == NULL)
return 0;
if (property_id < omp_ipr_first || property_id >= 0)
*ret_code = omp_irc_out_of_range;
else if (interop == omp_interop_none)
*ret_code = omp_irc_empty;
else
*ret_code = omp_irc_other;
return 0;
}
void *
omp_get_interop_ptr (const omp_interop_t interop,
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
if (ret_code == NULL)
return NULL;
if (property_id < omp_ipr_first || property_id >= 0)
*ret_code = omp_irc_out_of_range;
else if (interop == omp_interop_none)
*ret_code = omp_irc_empty;
else
*ret_code = omp_irc_other;
return NULL;
}
const char *
omp_get_interop_str (const omp_interop_t interop,
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
if (ret_code == NULL)
return NULL;
if (property_id < omp_ipr_first || property_id >= 0)
*ret_code = omp_irc_out_of_range;
else if (interop == omp_interop_none)
*ret_code = omp_irc_empty;
else
*ret_code = omp_irc_other;
return NULL;
}
const char *
omp_get_interop_name (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_property_t property_id)
{
static const char *prop_string[0 - omp_ipr_first]
= {"fr_id", "fr_name", "vendor", "vendor_name", "device_num", "platform",
"device", "device_context", "targetsync"};
if (property_id < omp_ipr_first || property_id >= 0)
return NULL;
return prop_string[omp_ipr_fr_id - property_id];
}
const char *
omp_get_interop_type_desc (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_property_t property_id
__attribute__ ((unused)))
{
return NULL;
}
const char *
omp_get_interop_rc_desc (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_rc_t ret_code)
{
static const char *rc_strings[omp_irc_no_value - omp_irc_other + 1]
= {"no meaningful value available",
"successful",
"provided interoperability object is equal to omp_interop_none",
"property ID is out of range",
"property type is integer; use omp_get_interop_int",
"property type is pointer; use omp_get_interop_ptr",
"property type is string; use omp_get_interop_str",
"obtaining properties is only supported on the initial device"};
/* omp_irc_other is returned by device-side omp_get_interop_{int,ptr,str};
the host returns for omp_irc_other NULL as it is not used. Besides the
three omp_interop_rc_t values used on the device side, handle host values
leaked to the device side. */
if (ret_code > omp_irc_no_value || ret_code < omp_irc_other)
return NULL;
return rc_strings[omp_irc_no_value - ret_code];
}
ialias (omp_get_num_interop_properties)
ialias (omp_get_interop_int)
ialias (omp_get_interop_ptr)
ialias (omp_get_interop_str)
ialias (omp_get_interop_name)
ialias (omp_get_interop_type_desc)
ialias (omp_get_interop_rc_desc)

41
libgomp/fortran.c
View file

@ -102,6 +102,10 @@ ialias_redirect (omp_set_default_allocator)
ialias_redirect (omp_get_default_allocator)
ialias_redirect (omp_display_env)
ialias_redirect (omp_fulfill_event)
ialias_redirect (omp_get_interop_str)
ialias_redirect (omp_get_interop_name)
ialias_redirect (omp_get_interop_type_desc)
ialias_redirect (omp_get_interop_rc_desc)
#endif
#ifndef LIBGOMP_GNU_SYMBOL_VERSIONING
@ -793,6 +797,43 @@ omp_get_default_allocator_ ()
return (intptr_t) omp_get_default_allocator ();
}
void
omp_get_interop_str_ (const char **res, size_t *res_len,
const omp_interop_t interop,
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
*res = omp_get_interop_str (interop, property_id, ret_code);
*res_len = *res ? strlen (*res) : 0;
}
void
omp_get_interop_name_ (const char **res, size_t *res_len,
const omp_interop_t interop,
omp_interop_property_t property_id)
{
*res = omp_get_interop_name (interop, property_id);
*res_len = *res ? strlen (*res) : 0;
}
void
omp_get_interop_type_desc_ (const char **res, size_t *res_len,
const omp_interop_t interop,
omp_interop_property_t property_id)
{
*res = omp_get_interop_type_desc (interop, property_id);
*res_len = *res ? strlen (*res) : 0;
}
void
omp_get_interop_rc_desc_ (const char **res, size_t *res_len,
const omp_interop_t interop,
omp_interop_rc_t ret_code)
{
*res = omp_get_interop_rc_desc (interop, ret_code);
*res_len = *res ? strlen (*res) : 0;
}
#ifndef LIBGOMP_OFFLOADED_ONLY
void

15
libgomp/libgomp.map
View file

@ -428,6 +428,21 @@ GOMP_5.1.2 {
GOMP_target_map_indirect_ptr;
} GOMP_5.1.1;
GOMP_5.1.3 {
global:
omp_get_num_interop_properties;
omp_get_interop_int;
omp_get_interop_ptr;
omp_get_interop_str;
omp_get_interop_name;
omp_get_interop_type_desc;
omp_get_interop_rc_desc;
omp_get_interop_str_;
omp_get_interop_name_;
omp_get_interop_type_desc_;
omp_get_interop_rc_desc_;
} GOMP_5.1.2;
OACC_2.0 {
global:
acc_get_num_devices;

78
libgomp/omp.h.in
View file

@ -105,6 +105,7 @@ typedef enum omp_pause_resource_t
omp_pause_hard = 2
} omp_pause_resource_t;
typedef __INTPTR_TYPE__ omp_intptr_t;
typedef __UINTPTR_TYPE__ omp_uintptr_t;
#if __cplusplus >= 201103L
@ -191,13 +192,60 @@ enum
omp_invalid_device = -4
};
typedef enum omp_interop_t __GOMP_UINTPTR_T_ENUM
{
omp_interop_none = 0,
__omp_interop_t_max__ = __UINTPTR_MAX__
} omp_interop_t;
typedef enum omp_interop_fr_t
{
omp_ifr_cuda = 1,
omp_ifr_cuda_driver = 2,
omp_ifr_opencl = 3,
omp_ifr_sycl = 4,
omp_ifr_hip = 5,
omp_ifr_level_zero = 6,
omp_ifr_hsa = 7,
omp_ifr_last = omp_ifr_hsa
} omp_interop_fr_t;
typedef enum omp_interop_property_t
{
omp_ipr_fr_id = -1,
omp_ipr_fr_name = -2,
omp_ipr_vendor = -3,
omp_ipr_vendor_name = -4,
omp_ipr_device_num = -5,
omp_ipr_platform = -6,
omp_ipr_device = -7,
omp_ipr_device_context = -8,
omp_ipr_targetsync = -9,
omp_ipr_first = -9
} omp_interop_property_t;
typedef enum omp_interop_rc_t
{
omp_irc_no_value = 1,
omp_irc_success = 0,
omp_irc_empty = -1,
omp_irc_out_of_range = -2,
omp_irc_type_int = -3,
omp_irc_type_ptr = -4,
omp_irc_type_str = -5,
omp_irc_other = -6
} omp_interop_rc_t;
#ifdef __cplusplus
extern "C" {
# define __GOMP_NOTHROW throw ()
# define __GOMP_DEFAULT_NULL_ALLOCATOR = omp_null_allocator
# define __GOMP_DEFAULT_NULL = __null
#else
# define __GOMP_NOTHROW __attribute__((__nothrow__))
# define __GOMP_DEFAULT_NULL_ALLOCATOR
# define __GOMP_DEFAULT_NULL
#endif
extern void omp_set_num_threads (int) __GOMP_NOTHROW;
@ -282,7 +330,7 @@ extern int omp_target_memcpy (void *, const void *, __SIZE_TYPE__,
__GOMP_NOTHROW;
extern int omp_target_memcpy_async (void *, const void *, __SIZE_TYPE__,
__SIZE_TYPE__, __SIZE_TYPE__, int, int,
int, omp_depend_t *)
int, omp_depend_t * __GOMP_DEFAULT_NULL)
__GOMP_NOTHROW;
extern int omp_target_memcpy_rect (void *, const void *, __SIZE_TYPE__, int,
const __SIZE_TYPE__ *,
@ -297,7 +345,7 @@ extern int omp_target_memcpy_rect_async (void *, const void *, __SIZE_TYPE__,
const __SIZE_TYPE__ *,
const __SIZE_TYPE__ *,
const __SIZE_TYPE__ *, int, int, int,
omp_depend_t *)
omp_depend_t * __GOMP_DEFAULT_NULL)
__GOMP_NOTHROW;
extern int omp_target_associate_ptr (const void *, const void *, __SIZE_TYPE__,
__SIZE_TYPE__, int) __GOMP_NOTHROW;
@ -351,6 +399,32 @@ extern void *omp_realloc (void *, __SIZE_TYPE__,
extern void omp_display_env (int) __GOMP_NOTHROW;
extern int omp_get_num_interop_properties (const omp_interop_t) __GOMP_NOTHROW;
extern omp_intptr_t omp_get_interop_int (const omp_interop_t,
omp_interop_property_t,
omp_interop_rc_t * __GOMP_DEFAULT_NULL)
__GOMP_NOTHROW;
extern void *omp_get_interop_ptr (const omp_interop_t, omp_interop_property_t,
omp_interop_rc_t * __GOMP_DEFAULT_NULL)
__GOMP_NOTHROW;
extern const char *omp_get_interop_str (const omp_interop_t,
omp_interop_property_t,
omp_interop_rc_t * __GOMP_DEFAULT_NULL)
__GOMP_NOTHROW;
extern const char *omp_get_interop_name (const omp_interop_t,
omp_interop_property_t) __GOMP_NOTHROW;
extern const char *omp_get_interop_type_desc (const omp_interop_t,
omp_interop_property_t)
__GOMP_NOTHROW;
extern const char *omp_get_interop_rc_desc (const omp_interop_t,
omp_interop_rc_t) __GOMP_NOTHROW;
#ifdef __cplusplus
}
#endif

99
libgomp/omp_lib.f90.in
View file

@ -40,6 +40,10 @@
integer, parameter :: omp_memspace_handle_kind = c_intptr_t
integer, parameter :: omp_depend_kind = @OMP_DEPEND_KIND@
integer, parameter :: omp_event_handle_kind = c_intptr_t
integer, parameter :: omp_interop_kind = c_intptr_t
integer, parameter :: omp_interop_fr_kind = c_int
integer, parameter :: omp_interop_property_kind = c_int
integer, parameter :: omp_interop_rc_kind = c_int
integer (omp_sched_kind), parameter :: omp_sched_static = 1
integer (omp_sched_kind), parameter :: omp_sched_dynamic = 2
integer (omp_sched_kind), parameter :: omp_sched_guided = 3
@ -172,6 +176,40 @@
parameter :: omp_low_lat_mem_space = 4
integer, parameter :: omp_initial_device = -1
integer, parameter :: omp_invalid_device = -4
integer (omp_interop_kind), &
parameter :: omp_interop_none = 0_omp_interop_kind
integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda = 1
integer (omp_interop_fr_kind), parameter :: omp_ifr_cuda_driver = 2
integer (omp_interop_fr_kind), parameter :: omp_ifr_opencl = 3
integer (omp_interop_fr_kind), parameter :: omp_ifr_sycl = 4
integer (omp_interop_fr_kind), parameter :: omp_ifr_hip = 5
integer (omp_interop_fr_kind), parameter :: omp_ifr_level_zero = 6
integer (omp_interop_fr_kind), parameter :: omp_ifr_hsa = 7
integer (omp_interop_fr_kind), &
parameter :: omp_ifr_last = omp_ifr_hsa
integer (omp_interop_property_kind), parameter :: omp_ipr_fr_id = -1
integer (omp_interop_property_kind), parameter :: omp_ipr_fr_name = -2
integer (omp_interop_property_kind), parameter :: omp_ipr_vendor = -3
integer (omp_interop_property_kind), &
parameter :: omp_ipr_vendor_name = -4
integer (omp_interop_property_kind), &
parameter :: omp_ipr_device_num = -5
integer (omp_interop_property_kind), parameter :: omp_ipr_platform = -6
integer (omp_interop_property_kind), parameter :: omp_ipr_device = -7
integer (omp_interop_property_kind), &
parameter :: omp_ipr_device_context = -8
integer (omp_interop_property_kind), &
parameter :: omp_ipr_targetsync = -9
integer (omp_interop_property_kind), &
parameter :: omp_ipr_first = omp_ipr_targetsync
integer (omp_interop_rc_kind), parameter :: omp_irc_no_value = 1
integer (omp_interop_rc_kind), parameter :: omp_irc_success = 0
integer (omp_interop_rc_kind), parameter :: omp_irc_empty = -1
integer (omp_interop_rc_kind), parameter :: omp_irc_out_of_range = -2
integer (omp_interop_rc_kind), parameter :: omp_irc_type_int = -3
integer (omp_interop_rc_kind), parameter :: omp_irc_type_ptr = -4
integer (omp_interop_rc_kind), parameter :: omp_irc_type_str = -5
integer (omp_interop_rc_kind), parameter :: omp_irc_other = -6
type omp_alloctrait
integer (kind=omp_alloctrait_key_kind) key
@ -904,6 +942,67 @@
end function omp_target_is_accessible
end interface
! Interop functions: Note that the interface is not identical to the
! OpenMP specification (c_int + VALUE + BIND(C) added) but usage
! compatible; the following declarations permit to directly call the C
! library function, except for the four string-returning functions.
interface
integer (c_int) function omp_get_num_interop_properties (interop) &
bind(C)
use, intrinsic :: iso_c_binding, only: c_int
use omp_lib_kinds
integer (omp_interop_kind), intent(in), value :: interop
end function omp_get_num_interop_properties
integer (c_intptr_t) function omp_get_interop_int (interop, &
property_id, ret_code) bind(C)
use, intrinsic :: iso_c_binding, only : c_intptr_t
use omp_lib_kinds
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
integer (omp_interop_rc_kind), optional, intent(out) :: ret_code
end function omp_get_interop_int
type (c_ptr) function omp_get_interop_ptr (interop, property_id, &
ret_code) bind(C)
use, intrinsic :: iso_c_binding, only : c_ptr
use omp_lib_kinds
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
integer (omp_interop_rc_kind), optional, intent(out) :: ret_code
end function omp_get_interop_ptr
character(:) function omp_get_interop_str (interop, property_id, &
ret_code)
use omp_lib_kinds
pointer :: omp_get_interop_str
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
integer (omp_interop_rc_kind), optional, intent(out) :: ret_code
end function omp_get_interop_str
character(:) function omp_get_interop_name (interop, property_id)
use omp_lib_kinds
pointer :: omp_get_interop_name
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
end function omp_get_interop_name
character(:) function omp_get_interop_type_desc (interop, property_id)
use omp_lib_kinds
pointer :: omp_get_interop_type_desc
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
end function omp_get_interop_type_desc
character(:) function omp_get_interop_rc_desc (interop, ret_code)
use omp_lib_kinds
pointer :: omp_get_interop_rc_desc
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_rc_kind), value :: ret_code
end function omp_get_interop_rc_desc
end interface
#if _OPENMP >= 201811
!GCC$ ATTRIBUTES DEPRECATED :: omp_get_nested, omp_set_nested
!GCC$ ATTRIBUTES DEPRECATED :: omp_lock_hint_kind, omp_lock_hint_none

170
libgomp/omp_lib.h.in
View file

@ -85,11 +85,17 @@
integer omp_allocator_handle_kind, omp_alloctrait_key_kind
integer omp_alloctrait_val_kind, omp_memspace_handle_kind
integer omp_event_handle_kind
integer omp_interop_kind, omp_interop_fr_kind
integer omp_interop_property_kind, omp_interop_rc_kind
parameter (omp_allocator_handle_kind = @INTPTR_T_KIND@)
parameter (omp_alloctrait_key_kind = 4)
parameter (omp_alloctrait_val_kind = @INTPTR_T_KIND@)
parameter (omp_memspace_handle_kind = @INTPTR_T_KIND@)
parameter (omp_event_handle_kind = @INTPTR_T_KIND@)
parameter (omp_interop_kind = @INTPTR_T_KIND@)
parameter (omp_interop_fr_kind = 4)
parameter (omp_interop_property_kind = 4)
parameter (omp_interop_rc_kind = 4)
integer (omp_alloctrait_key_kind) omp_atk_sync_hint
integer (omp_alloctrait_key_kind) omp_atk_alignment
integer (omp_alloctrait_key_kind) omp_atk_access
@ -179,6 +185,60 @@
integer omp_initial_device, omp_invalid_device
parameter (omp_initial_device = -1)
parameter (omp_invalid_device = -4)
integer (omp_interop_kind) omp_interop_none
parameter (omp_interop_none = 0_omp_interop_kind)
integer (omp_interop_fr_kind) omp_ifr_cuda
integer (omp_interop_fr_kind) omp_ifr_cuda_driver
integer (omp_interop_fr_kind) omp_ifr_opencl
integer (omp_interop_fr_kind) omp_ifr_sycl
integer (omp_interop_fr_kind) omp_ifr_hip
integer (omp_interop_fr_kind) omp_ifr_level_zero
integer (omp_interop_fr_kind) omp_ifr_hsa
integer (omp_interop_fr_kind) omp_ifr_last
parameter (omp_ifr_cuda = 1)
parameter (omp_ifr_cuda_driver = 2)
parameter (omp_ifr_opencl = 3)
parameter (omp_ifr_sycl = 4)
parameter (omp_ifr_hip = 5)
parameter (omp_ifr_level_zero = 6)
parameter (omp_ifr_hsa = 7)
parameter (omp_ifr_last = omp_ifr_hsa)
integer (omp_interop_property_kind) omp_ipr_fr_id
integer (omp_interop_property_kind) omp_ipr_fr_name
integer (omp_interop_property_kind) omp_ipr_vendor
integer (omp_interop_property_kind) omp_ipr_vendor_name
integer (omp_interop_property_kind) omp_ipr_device_num
integer (omp_interop_property_kind) omp_ipr_platform
integer (omp_interop_property_kind) omp_ipr_device
integer (omp_interop_property_kind) omp_ipr_device_context
integer (omp_interop_property_kind) omp_ipr_targetsync
integer (omp_interop_property_kind) omp_ipr_first
parameter (omp_ipr_fr_id = -1)
parameter (omp_ipr_fr_name = -2)
parameter (omp_ipr_vendor = -3)
parameter (omp_ipr_vendor_name = -4)
parameter (omp_ipr_device_num = -5)
parameter (omp_ipr_platform = -6)
parameter (omp_ipr_device = -7)
parameter (omp_ipr_device_context = -8)
parameter (omp_ipr_targetsync = -9)
parameter (omp_ipr_first = omp_ipr_targetsync)
integer (omp_interop_rc_kind) omp_irc_no_value
integer (omp_interop_rc_kind) omp_irc_success
integer (omp_interop_rc_kind) omp_irc_empty
integer (omp_interop_rc_kind) omp_irc_out_of_range
integer (omp_interop_rc_kind) omp_irc_type_int
integer (omp_interop_rc_kind) omp_irc_type_ptr
integer (omp_interop_rc_kind) omp_irc_type_str
integer (omp_interop_rc_kind) omp_irc_other
parameter (omp_irc_no_value = 1)
parameter (omp_irc_success = 0)
parameter (omp_irc_empty = -1)
parameter (omp_irc_out_of_range = -2)
parameter (omp_irc_type_int = -3)
parameter (omp_irc_type_ptr = -4)
parameter (omp_irc_type_str = -5)
parameter (omp_irc_other = -6)
type omp_alloctrait
integer (omp_alloctrait_key_kind) key
@ -323,7 +383,7 @@
end interface
interface
function omp_aligned_calloc (alignment, nmemb, size, allocator) &
function omp_aligned_calloc (alignment, nmemb, size, allocator) &
& bind(c)
use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t
use, intrinsic :: omp_lib_kinds
@ -334,7 +394,7 @@
end interface
interface
function omp_realloc (ptr, size, allocator, free_allocator) &
function omp_realloc (ptr, size, allocator, free_allocator) &
& bind(c)
use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t
use, intrinsic :: omp_lib_kinds
@ -373,8 +433,8 @@
end interface
interface
function omp_target_memcpy (dst, src, length, dst_offset, &
& src_offset, dst_device_num, &
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
@ -385,9 +445,9 @@
end interface
interface
function omp_target_memcpy_async (dst, src, length, dst_offset, &
& src_offset, dst_device_num, &
& src_device_num, depobj_count, &
function omp_target_memcpy_async (dst, src, length, dst_offset, &
& src_offset, dst_device_num, &
& src_device_num, depobj_count, &
& depobj_list) bind(c)
use, intrinsic :: iso_c_binding, only : c_ptr, c_int, c_size_t
import :: omp_depend_kind
@ -401,10 +461,10 @@
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, &
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
@ -420,14 +480,14 @@
end interface
interface
function omp_target_memcpy_rect_async (dst,src,element_size, &
& num_dims, volume, &
& dst_offsets, src_offsets, &
& dst_dimensions, &
& src_dimensions, &
& dst_device_num, &
& src_device_num, &
& depobj_count, &
function omp_target_memcpy_rect_async (dst,src,element_size, &
& num_dims, volume, &
& dst_offsets, src_offsets, &
& dst_dimensions, &
& src_dimensions, &
& dst_device_num, &
& src_device_num, &
& depobj_count, &
& depobj_list) bind(c)
use, intrinsic :: iso_c_binding, only : c_ptr, c_int, c_size_t
import :: omp_depend_kind
@ -445,8 +505,8 @@
end interface
interface
function omp_target_associate_ptr (host_ptr, device_ptr, size, &
& device_offset, device_num) &
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
@ -475,7 +535,7 @@
end interface
interface
function omp_target_is_accessible (ptr, size, device_num) &
function omp_target_is_accessible (ptr, size, device_num) &
& bind(c)
use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_int
integer(c_int) :: omp_target_is_accessible
@ -484,3 +544,69 @@
integer(c_int), value :: device_num
end function omp_target_is_accessible
end interface
! Interop functions: Note that the interface is not identical to the
! OpenMP specification (c_int + VALUE + BIND(C) added) but usage
! compatible; the following declarations permit to directly call the C
! library function, except for the four string-returning functions.
interface
integer (c_int) function omp_get_num_interop_properties(interop) &
& bind(C)
use, intrinsic :: iso_c_binding, only: c_int
use, intrinsic :: omp_lib_kinds
integer (omp_interop_kind), intent(in), value :: interop
end function omp_get_num_interop_properties
integer (c_intptr_t) function omp_get_interop_int (interop, &
& property_id, ret_code) bind(C)
use, intrinsic :: iso_c_binding, only : c_intptr_t
use, intrinsic :: omp_lib_kinds
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
integer (omp_interop_rc_kind), optional, &
& intent(out) :: ret_code
end function omp_get_interop_int
type (c_ptr) function omp_get_interop_ptr (interop, property_id, &
& ret_code) bind(C)
use, intrinsic :: iso_c_binding, only : c_ptr
use, intrinsic :: omp_lib_kinds
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
integer (omp_interop_rc_kind), optional, &
& intent(out) :: ret_code
end function omp_get_interop_ptr
character(:) function omp_get_interop_str (interop, property_id, &
& ret_code)
use, intrinsic :: omp_lib_kinds
pointer :: omp_get_interop_str
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
integer (omp_interop_rc_kind), optional, &
& intent(out) :: ret_code
end function omp_get_interop_str
character(:) function omp_get_interop_name(interop, property_id)
use, intrinsic :: omp_lib_kinds
pointer :: omp_get_interop_name
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
end function omp_get_interop_name
character(:) function omp_get_interop_type_desc (interop, &
& property_id)
use, intrinsic :: omp_lib_kinds
pointer :: omp_get_interop_type_desc
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_property_kind), value :: property_id
end function omp_get_interop_type_desc
character(:) function omp_get_interop_rc_desc (interop, &
& ret_code)
use, intrinsic :: omp_lib_kinds
pointer :: omp_get_interop_rc_desc
integer (omp_interop_kind), intent(in), value :: interop
integer (omp_interop_rc_kind), value :: ret_code
end function omp_get_interop_rc_desc
end interface

110
libgomp/target.c
View file

@ -5113,6 +5113,116 @@ omp_pause_resource_all (omp_pause_resource_t kind)
ialias (omp_pause_resource)
ialias (omp_pause_resource_all)
int
omp_get_num_interop_properties (const omp_interop_t interop
__attribute__ ((unused)))
{
/* Zero implementation defined. In total:
omp_get_num_interop_properties () - omp_ipr_first. */
return 0;
}
omp_intptr_t
omp_get_interop_int (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
if (ret_code == NULL)
return 0;
if (property_id < omp_ipr_first || property_id >= 0)
*ret_code = omp_irc_out_of_range;
else
*ret_code = omp_irc_empty; /* Assume omp_interop_none. */
return 0;
}
void *
omp_get_interop_ptr (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
if (ret_code == NULL)
return NULL;
if (property_id < omp_ipr_first || property_id >= 0)
*ret_code = omp_irc_out_of_range;
else
*ret_code = omp_irc_empty; /* Assume omp_interop_none. */
return NULL;
}
const char *
omp_get_interop_str (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_property_t property_id,
omp_interop_rc_t *ret_code)
{
if (ret_code == NULL)
return NULL;
if (property_id < omp_ipr_first || property_id >= 0)
*ret_code = omp_irc_out_of_range;
else
*ret_code = omp_irc_empty; /* Assume omp_interop_none. */
return NULL;
}
const char *
omp_get_interop_name (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_property_t property_id)
{
static const char *prop_string[0 - omp_ipr_first]
= {"fr_id", "fr_name", "vendor", "vendor_name", "device_num", "platform",
"device", "device_context", "targetsync"};
if (property_id < omp_ipr_first || property_id >= 0)
return NULL;
return prop_string[omp_ipr_fr_id - property_id];
}
const char *
omp_get_interop_type_desc (const omp_interop_t interop,
omp_interop_property_t property_id)
{
static const char *desc[omp_ipr_fr_id - omp_ipr_device_num + 1]
= {"omp_interop_t", /* fr_id */
"const char*", /* fr_name */
"int", /* vendor */
"const char *", /* vendor_name */
"int"}; /* device_num */
if (property_id > omp_ipr_fr_id || property_id < omp_ipr_first)
return NULL;
if (interop == omp_interop_none)
return NULL;
if (property_id >= omp_ipr_device_num)
return desc[omp_ipr_fr_id - property_id];
return NULL; /* FIXME: Call plugin. */
}
const char *
omp_get_interop_rc_desc (const omp_interop_t interop __attribute__ ((unused)),
omp_interop_rc_t ret_code)
{
static const char *rc_strings[omp_irc_no_value - omp_irc_other]
= {"no meaningful value available",
"successful",
"provided interoperability object is equal to omp_interop_none",
"property ID is out of range",
"property type is integer; use omp_get_interop_int",
"property type is pointer; use omp_get_interop_ptr",
"property type is string; use omp_get_interop_str"};
/* omp_irc_other is returned by device-side omp_get_interop_{int,ptr,str};
on the host it is not used, hence, return NULL here. */
if (ret_code > omp_irc_no_value || ret_code <= omp_irc_other)
return NULL;
return rc_strings[omp_irc_no_value - ret_code];
}
ialias (omp_get_num_interop_properties)
ialias (omp_get_interop_int)
ialias (omp_get_interop_ptr)
ialias (omp_get_interop_str)
ialias (omp_get_interop_name)
ialias (omp_get_interop_type_desc)
ialias (omp_get_interop_rc_desc)
#ifdef PLUGIN_SUPPORT
/* This function tries to load a plugin for DEVICE. Name of plugin is passed

287
libgomp/testsuite/libgomp.c-c++-common/interop-routines-1.c Normal file
View file

@ -0,0 +1,287 @@
/* { dg-do run } */
#include <assert.h>
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <omp.h>
int
main ()
{
omp_interop_t interop = omp_interop_none;
assert (omp_irc_no_value == 1);
assert (omp_irc_success == 0);
assert (omp_irc_empty == -1);
assert (omp_irc_out_of_range == -2);
assert (omp_irc_type_int == -3);
assert (omp_irc_type_ptr == -4);
assert (omp_irc_type_str == -5);
assert (omp_irc_other == -6);
/* Check values, including invalid values. */
for (omp_interop_rc_t ret_code3 = (omp_interop_rc_t)((int)omp_irc_other-1);
ret_code3 <= omp_irc_no_value + 1;
ret_code3 = (omp_interop_rc_t)((int)ret_code3 + 1))
{
const char *msg = omp_get_interop_rc_desc (interop, ret_code3);
if (ret_code3 < omp_irc_other || ret_code3 > omp_irc_no_value)
/* Assume NULL for an invalid value. */
assert (msg == NULL);
else if (ret_code3 == omp_irc_other)
/* Likely not to exist in an implementation; esp. not for
omp_interop_none. Thus, expect NULL. */
/* In GCC, it is used on the device side, only, to complain about
omp_get_interop_{int,ptr,str} usage. */
assert (msg == NULL);
else
/* Assume that omp_get_interop_rc_desc handles all of those and
not only omp_irc_empty (and possibly omp_irc_out_of_range),
which do occur for omp_interop_none. */
assert (msg != NULL && strlen (msg) > 5); /* Some sensible message. */
}
assert (omp_ifr_last >= omp_ifr_hsa);
for (omp_interop_fr_t fr = omp_ifr_cuda;
fr <= omp_ifr_last;
fr = (omp_interop_fr_t)((int)fr +1))
{
switch (fr)
{
/* Expect the id values from the additional-definition document. */
case omp_ifr_cuda:
if (fr != 1)
abort ();
break;
case omp_ifr_cuda_driver:
if (fr != 2)
abort ();
break;
case omp_ifr_opencl:
if (fr != 3)
abort ();
break;
case omp_ifr_sycl:
if (fr != 4)
abort ();
break;
case omp_ifr_hip:
if (fr != 5)
abort ();
break;
case omp_ifr_level_zero:
if (fr != 6)
abort ();
break;
case omp_ifr_hsa:
if (fr != 7)
abort ();
break;
default:
/* Valid, but unexpected to have more interop types. */
abort ();
}
}
assert (omp_ipr_first <= omp_ipr_targetsync
&& omp_get_num_interop_properties (interop) > omp_ipr_fr_id);
for (omp_interop_property_t ipr = omp_ipr_first;
ipr < omp_get_num_interop_properties (interop);
ipr = (omp_interop_property_t) ((int) ipr + 1))
{
/* As interop == omp_interop_none, NULL is permissible;
nonetheless, require != NULL for the GCC implementation. */
const char *name = omp_get_interop_name (interop, ipr);
if (name == NULL)
abort ();
switch (ipr)
{
case omp_ipr_fr_id:
if (ipr != -1 || !!strcmp (name, "fr_id"))
abort ();
break;
case omp_ipr_fr_name:
if (ipr != -2 || !!strcmp (name, "fr_name"))
abort ();
break;
case omp_ipr_vendor:
if (ipr != -3 || !!strcmp (name, "vendor"))
abort ();
break;
case omp_ipr_vendor_name:
if (ipr != -4 || !!strcmp (name, "vendor_name"))
abort ();
break;
case omp_ipr_device_num:
if (ipr != -5 || !!strcmp (name, "device_num"))
abort ();
break;
case omp_ipr_platform:
if (ipr != -6 || !!strcmp (name, "platform"))
abort ();
break;
case omp_ipr_device:
if (ipr != -7 || !!strcmp (name, "device"))
abort ();
break;
case omp_ipr_device_context:
if (ipr != -8 || !!strcmp (name, "device_context"))
abort ();
break;
case omp_ipr_targetsync:
if (ipr != -9 || !!strcmp (name, "targetsync"))
abort ();
break;
default:
/* Valid, but unexpected to have more interop types,
especially not for interop == omp_interop_none. */
abort ();
}
/* As interop == omp_interop_none, expect NULL. */
if (omp_get_interop_type_desc (interop, ipr) != NULL)
abort ();
omp_interop_rc_t ret_code;
const char *err;
ret_code = omp_irc_success;
omp_intptr_t ival = omp_get_interop_int (interop, ipr, &ret_code);
assert (ret_code == omp_irc_empty); /* As interop == omp_interop_none. */
assert (ival == 0); /* Implementation choice. */
err = omp_get_interop_rc_desc (interop, ret_code);
assert (err != NULL && strlen (err) > 5); /* Some sensible message. */
assert (!strcmp (err, "provided interoperability object is equal to "
"omp_interop_none")); /* GCC implementation choice. */
omp_intptr_t ival4 = omp_get_interop_int (interop, ipr, NULL);
assert(ival4 == ival);
ret_code = omp_irc_success;
void *ptr = omp_get_interop_ptr (interop, ipr, &ret_code);
assert (ret_code == omp_irc_empty); /* As interop == omp_interop_none. */
assert (ptr == NULL); /* Obvious implementation choice. */
err = omp_get_interop_rc_desc (interop, ret_code);
assert (err != NULL && strlen (err) > 5); /* Some sensible message. */
assert (!strcmp (err, "provided interoperability object is equal to "
"omp_interop_none")); /* GCC implementation choice. */
void *ptr4 = omp_get_interop_ptr (interop, ipr, NULL);
assert (ptr4 == ptr);
ret_code = omp_irc_success;
const char *str = omp_get_interop_str (interop, ipr, &ret_code);
assert (ret_code == omp_irc_empty); /* As interop == omp_interop_none. */
assert (str == NULL); /* Obvious implementation choice. */
err = omp_get_interop_rc_desc (interop, ret_code);
assert (err != NULL && strlen (err) > 5); /* Some sensible message. */
assert (!strcmp (err, "provided interoperability object is equal to "
"omp_interop_none")); /* GCC implementation choice. */
const char *str4 = omp_get_interop_str (interop, ipr, NULL);
assert (str4 == str);
}
/* Invalid ipr. */
/* Valid are either omp_irc_empty (due to omp_interop_none) or
omp_irc_out_of_range; assume omp_irc_out_of_range with GCC. */
omp_interop_rc_t ret_code2;
const char *err2;
omp_intptr_t ival2;
void *ptr2;
const char *str2;
/* omp_ipr_targetsync-1, i.e < lower bound. */
ret_code2 = omp_irc_success;
ival2 = omp_get_interop_int (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), &ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (ival2 == 0); /* Implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
omp_intptr_t ival5 = omp_get_interop_int (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), NULL);
assert (ival5 == ival2);
#ifdef __cplusplus
ival5 = omp_get_interop_int (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1));
assert (ival5 == ival2);
#endif
ret_code2 = omp_irc_success;
ptr2 = omp_get_interop_ptr (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), &ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (ptr2 == NULL); /* Obvious implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
void *ptr5 = omp_get_interop_ptr (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), NULL);
assert (ptr5 == ptr2);
#ifdef __cplusplus
ptr5 = omp_get_interop_ptr (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1));
assert (ptr5 == ptr2);
#endif
ret_code2 = omp_irc_success;
str2 = omp_get_interop_str (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), &ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (str2 == NULL); /* Obvious implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
const char *str5 = omp_get_interop_str (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), NULL);
assert (str2 == str5);
#ifdef __cplusplus
str5 = omp_get_interop_str (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1));
assert (str2 == str5);
#endif
/* omp_get_num_interop_properties (), i.e > upper bound. */
ret_code2 = omp_irc_success;
ival2 = omp_get_interop_int (interop,
(omp_interop_property_t) omp_get_num_interop_properties (interop),
&ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (ival2 == 0); /* Implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
ret_code2 = omp_irc_success;
ptr2 = omp_get_interop_ptr (interop,
(omp_interop_property_t) omp_get_num_interop_properties (interop),
&ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (ptr2 == NULL); /* Obvious implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
ret_code2 = omp_irc_success;
str2 = omp_get_interop_str (interop,
(omp_interop_property_t) omp_get_num_interop_properties (interop),
&ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (str2 == NULL); /* Obvious implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
return 0;
}

354
libgomp/testsuite/libgomp.c-c++-common/interop-routines-2.c Normal file
View file

@ -0,0 +1,354 @@
/* { dg-do run { target { offload_device } } } */
/* OpenMP permits using the interop functions on the device,
but it is not really supported. Hence, check that the stubs
are working. */
#include <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <omp.h>
/* Assert is not available with newlib on the device side, hence... */
#define assert(cond) \
do { \
if (!(cond)) \
{ \
__builtin_printf ("assert failed: " #cond "\n"); \
abort (); \
} \
} \
while (0)
#pragma omp begin declare target
void
target_test ()
{
if (omp_is_initial_device ())
return; /* Already tested in interop-routines-1.c. */
omp_interop_t interop = omp_interop_none;
assert (omp_irc_no_value == 1);
assert (omp_irc_success == 0);
assert (omp_irc_empty == -1);
assert (omp_irc_out_of_range == -2);
assert (omp_irc_type_int == -3);
assert (omp_irc_type_ptr == -4);
assert (omp_irc_type_str == -5);
assert (omp_irc_other == -6);
/* Check values, including invalid values. */
for (omp_interop_rc_t ret_code3 = (omp_interop_rc_t) ((int) omp_irc_other - 1);
ret_code3 <= omp_irc_no_value + 1;
ret_code3 = (omp_interop_rc_t) ((int) ret_code3 + 1))
{
const char *msg = omp_get_interop_rc_desc (interop, ret_code3);
if (ret_code3 < omp_irc_other || ret_code3 > omp_irc_no_value)
/* Assume NULL for an invalid value. */
assert (msg == NULL);
else if (ret_code3 == omp_irc_other)
/* In GCC, this is used on the device side, only, if the
omp_get_interop_{int,ptr,str} were invoked on the host.
see below for a check. */
assert (msg != NULL && strlen (msg) > 5); /* Some sensible message. */
else
/* Assume that omp_get_interop_rc_desc handles all of those and
not only omp_irc_empty (and possibly omp_irc_out_of_range),
which do occur for omp_interop_none. */
assert (msg != NULL && strlen (msg) > 5); /* Some sensible message. */
}
assert (omp_ifr_last >= omp_ifr_hsa);
for (omp_interop_fr_t fr = omp_ifr_cuda; fr <= omp_ifr_last;
fr = (omp_interop_fr_t) ((int) fr + 1))
{
switch (fr)
{
/* Expect the id values from the additional-definition document. */
case omp_ifr_cuda:
if (fr != 1)
abort ();
break;
case omp_ifr_cuda_driver:
if (fr != 2)
abort ();
break;
case omp_ifr_opencl:
if (fr != 3)
abort ();
break;
case omp_ifr_sycl:
if (fr != 4)
abort ();
break;
case omp_ifr_hip:
if (fr != 5)
abort ();
break;
case omp_ifr_level_zero:
if (fr != 6)
abort ();
break;
case omp_ifr_hsa:
if (fr != 7)
abort ();
break;
default:
/* Valid, but unexpected to have more interop types. */
abort ();
}
}
assert (omp_ipr_first <= omp_ipr_targetsync
&& omp_get_num_interop_properties (interop) > omp_ipr_fr_id);
for (omp_interop_property_t ipr = omp_ipr_first;
ipr < omp_get_num_interop_properties (interop);
ipr = (omp_interop_property_t) ((int) ipr + 1))
{
/* As interop == omp_interop_none, NULL is permissible;
nonetheless, require != NULL for the GCC implementation. */
const char *name = omp_get_interop_name (interop, ipr);
if (name == NULL)
abort ();
switch (ipr)
{
case omp_ipr_fr_id:
if (ipr != -1 || !!strcmp (name, "fr_id"))
abort ();
break;
case omp_ipr_fr_name:
if (ipr != -2 || !!strcmp (name, "fr_name"))
abort ();
break;
case omp_ipr_vendor:
if (ipr != -3 || !!strcmp (name, "vendor"))
abort ();
break;
case omp_ipr_vendor_name:
if (ipr != -4 || !!strcmp (name, "vendor_name"))
abort ();
break;
case omp_ipr_device_num:
if (ipr != -5 || !!strcmp (name, "device_num"))
abort ();
break;
case omp_ipr_platform:
if (ipr != -6 || !!strcmp (name, "platform"))
abort ();
break;
case omp_ipr_device:
if (ipr != -7 || !!strcmp (name, "device"))
abort ();
break;
case omp_ipr_device_context:
if (ipr != -8 || !!strcmp (name, "device_context"))
abort ();
break;
case omp_ipr_targetsync:
if (ipr != -9 || !!strcmp (name, "targetsync"))
abort ();
break;
default:
/* Valid, but unexpected to have more interop types,
especially not for interop == omp_interop_none. */
abort ();
}
/* As interop == omp_interop_none, expect NULL. */
if (omp_get_interop_type_desc (interop, ipr) != NULL)
abort ();
omp_interop_rc_t ret_code;
const char *err;
ret_code = omp_irc_success;
omp_intptr_t ival = omp_get_interop_int (interop, ipr, &ret_code);
assert (ret_code == omp_irc_empty); /* As interop == omp_interop_none. */
assert (ival == 0); /* Implementation choice. */
err = omp_get_interop_rc_desc (interop, ret_code);
assert (err != NULL && strlen (err) > 5); /* Some sensible message. */
assert (!strcmp (err, "provided interoperability object is equal to "
"omp_interop_none")); /* GCC implementation choice. */
ival = omp_get_interop_int (interop, ipr, NULL);
assert (ival == 0); /* Implementation choice. */
#ifdef __cplusplus
ival = omp_get_interop_int (interop, ipr);
assert (ival == 0); /* Implementation choice. */
#endif
ret_code = omp_irc_success;
void *ptr = omp_get_interop_ptr (interop, ipr, &ret_code);
assert (ret_code == omp_irc_empty); /* As interop == omp_interop_none. */
assert (ptr == NULL); /* Obvious implementation choice. */
err = omp_get_interop_rc_desc (interop, ret_code);
assert (err != NULL && strlen (err) > 5); /* Some sensible message. */
assert (!strcmp (err, "provided interoperability object is equal to "
"omp_interop_none")); /* GCC implementation choice. */
ptr = omp_get_interop_ptr (interop, ipr, NULL);
assert (ptr == NULL); /* Obvious implementation choice. */
#ifdef __cplusplus
ptr = omp_get_interop_ptr (interop, ipr);
assert (ptr == NULL); /* Obvious implementation choice. */
#endif
ret_code = omp_irc_success;
const char *str = omp_get_interop_str (interop, ipr, &ret_code);
assert (ret_code == omp_irc_empty); /* As interop == omp_interop_none. */
assert (str == NULL); /* Obvious implementation choice. */
err = omp_get_interop_rc_desc (interop, ret_code);
assert (err != NULL && strlen (err) > 5); /* Some sensible message. */
assert (!strcmp (err, "provided interoperability object is equal to "
"omp_interop_none")); /* GCC implementation choice. */
str = omp_get_interop_str (interop, ipr, NULL);
assert (str == NULL); /* Obvious implementation choice. */
#ifdef __cplusplus
str = omp_get_interop_str (interop, ipr);
assert (str == NULL); /* Obvious implementation choice. */
#endif
/* Special case of GCC: For any non-'omp_interop_none' valued interop,
a device-side call to omp_get_interop_{int,ptr,src} will yield
omp_irc_other - with the error message as checked below. */
omp_interop_t interop_not_none_invalid = (omp_interop_t) 0xDEADBEEF;
ret_code = omp_irc_success;
ival = omp_get_interop_int (interop_not_none_invalid, ipr, &ret_code);
assert (ret_code == omp_irc_other);
assert (ival == 0); /* Implementation choice. */
err = omp_get_interop_rc_desc (interop, ret_code);
assert (err != NULL && strlen (err) > 5); /* Some sensible message. */
ret_code = omp_irc_success;
ptr = omp_get_interop_ptr (interop_not_none_invalid, ipr, &ret_code);
assert (ret_code == omp_irc_other);
assert (ptr == NULL); /* Implementation choice. */
err = omp_get_interop_rc_desc (interop, ret_code);
assert (err != NULL && strlen (err) > 5); /* Some sensible message. */
assert (!strcmp (err, "obtaining properties is only supported on the "
"initial device")); /* GCC special case. */
ret_code = omp_irc_success;
str = omp_get_interop_str (interop_not_none_invalid, ipr, &ret_code);
assert (ret_code == omp_irc_other);
assert (str == NULL); /* Implementation choice. */
err = omp_get_interop_rc_desc (interop, ret_code);
assert (!strcmp (err, "obtaining properties is only supported on the "
"initial device")); /* GCC special case. */
}
/* Invalid ipr. */
/* Valid are either omp_irc_empty (due to omp_interop_none) or
omp_irc_out_of_range; assume omp_irc_out_of_range with GCC. */
omp_interop_rc_t ret_code2;
const char *err2;
omp_intptr_t ival2;
void *ptr2;
const char *str2;
/* omp_ipr_targetsync-1, i.e < lower bound. */
ret_code2 = omp_irc_success;
ival2 = omp_get_interop_int (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), &ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (ival2 == 0); /* Implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
ival2 = omp_get_interop_int (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), NULL);
assert (ival2 == 0); /* Implementation choice. */
#ifdef __cplusplus
ival2 = omp_get_interop_int (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1));
assert (ival2 == 0); /* Implementation choice. */
#endif
ret_code2 = omp_irc_success;
ptr2 = omp_get_interop_ptr (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), &ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (ptr2 == NULL); /* Obvious implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
ptr2 = omp_get_interop_ptr (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), NULL);
assert (ptr2 == NULL); /* Obvious implementation choice. */
#ifdef __cplusplus
ptr2 = omp_get_interop_ptr (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1));
assert (ptr2 == NULL); /* Obvious implementation choice. */
#endif
ret_code2 = omp_irc_success;
str2 = omp_get_interop_str (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), &ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (str2 == NULL); /* Obvious implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
str2 = omp_get_interop_str (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1), NULL);
assert (str2 == NULL); /* Obvious implementation choice. */
#ifdef __cplusplus
str2 = omp_get_interop_str (interop,
(omp_interop_property_t) ((int) omp_ipr_targetsync-1));
assert (str2 == NULL); /* Obvious implementation choice. */
#endif
/* omp_get_num_interop_properties (), i.e > upper bound. */
ret_code2 = omp_irc_success;
ival2 = omp_get_interop_int (interop,
(omp_interop_property_t) omp_get_num_interop_properties (interop),
&ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (ival2 == 0); /* Implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
ret_code2 = omp_irc_success;
ptr2 = omp_get_interop_ptr (interop,
(omp_interop_property_t) omp_get_num_interop_properties (interop),
&ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (ptr2 == NULL); /* Obvious implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
ret_code2 = omp_irc_success;
str2 = omp_get_interop_str (interop,
(omp_interop_property_t) omp_get_num_interop_properties (interop),
&ret_code2);
assert (ret_code2 == omp_irc_out_of_range);
assert (str2 == NULL); /* Obvious implementation choice. */
err2 = omp_get_interop_rc_desc (interop, ret_code2);
assert (err2 != NULL && strlen (err2) > 5); /* Some sensible message. */
/* GCC implementation choice. */
assert (!strcmp (err2, "property ID is out of range"));
}
#pragma omp end declare target
int
main ()
{
for (int dev = 0; dev < omp_get_num_devices (); dev++)
#pragma omp target device(device_num : dev)
target_test ();
return 0;
}

236
libgomp/testsuite/libgomp.fortran/interop-routines-1.F90 Normal file
View file

@ -0,0 +1,236 @@
program main
use iso_c_binding, only: c_intptr_t, c_ptr, c_associated
#ifndef USE_OMP_HEADER
use omp_lib
#endif
implicit none (type, external)
#ifdef USE_OMP_HEADER
include "omp_lib.h"
#endif
integer(omp_interop_kind) :: interop = omp_interop_none
integer(omp_interop_rc_kind) :: ret_code
integer(omp_interop_fr_kind) :: fr
integer(omp_interop_property_kind) :: ipr
integer(c_intptr_t) :: ival
type(c_ptr) :: ptr
character(len=:), pointer :: str
if (omp_irc_no_value /= 1) stop 1
if (omp_irc_success /= 0) stop 2
if (omp_irc_empty /= -1) stop 3
if (omp_irc_out_of_range /= -2) stop 4
if (omp_irc_type_int /= -3) stop 5
if (omp_irc_type_ptr /= -4) stop 6
if (omp_irc_type_str /= -5) stop 7
if (omp_irc_other /= -6) stop 8
! Check values, including invalid values.
do ret_code = omp_irc_other - 1, omp_irc_no_value + 1
str => omp_get_interop_rc_desc (interop, ret_code)
if (ret_code < omp_irc_other &
& .or. ret_code > omp_irc_no_value) then
! Assume disassociated for an invalid value.
if (associated (str)) stop 9
else if (ret_code == omp_irc_other) then
! Likely not to exist in an implementation; esp. not for
! omp_interop_none. Thus, assume disassociated.
! In GCC, omp_irc_other is used on the device side, only, to
! complain about omp_get_interop_{int,ptr,str} usage.
if (associated (str)) stop 10
else
! Assume that omp_get_interop_rc_desc handles all of those and
! not only omp_irc_empty (and possibly omp_irc_out_of_range),
! which do occur for omp_interop_none.
! Assume some sensible message, i.e. at least 5 characters.
if (len_trim (str) <= 5) stop 11
end if
end do
if (omp_ifr_last < omp_ifr_hsa) stop 12
do fr = omp_ifr_cuda, omp_ifr_last
select case (fr)
! Expect the id values from the additional-definition document.
case (omp_ifr_cuda)
if (fr /= 1) stop 13
case (omp_ifr_cuda_driver)
if (fr /= 2) stop 14
case (omp_ifr_opencl)
if (fr /= 3) stop 15
case (omp_ifr_sycl)
if (fr /= 4) stop 16
case (omp_ifr_hip)
if (fr /= 5) stop 17
case (omp_ifr_level_zero)
if (fr /= 6) stop 18
case (omp_ifr_hsa)
if (fr /= 7) stop 19
case default
! Valid, but unexpected to have more interop types.
stop 20
end select
end do
if (omp_ipr_first > omp_ipr_targetsync &
& .or. (omp_ipr_fr_id &
& >= omp_get_num_interop_properties (interop))) &
& stop 21
do ipr = omp_ipr_first, &
& omp_get_num_interop_properties (interop) - 1
! As interop == omp_interop_none, NULL is permissible;
! nonetheless, require != NULL for the GCC implementation.
str => omp_get_interop_name (interop, ipr)
select case (ipr)
case (omp_ipr_fr_id)
if (ipr /= -1 .or. str /= "fr_id") &
& stop 21
case (omp_ipr_fr_name)
if (ipr /= -2 .or. str /= "fr_name") &
& stop 22
case (omp_ipr_vendor)
if (ipr /= -3 .or. str /= "vendor") &
& stop 23
case (omp_ipr_vendor_name)
if (ipr /= -4 .or. str /= "vendor_name") &
& stop 24
case (omp_ipr_device_num)
if (ipr /= -5 .or. str /= "device_num") &
& stop 25
case (omp_ipr_platform)
if (ipr /= -6 .or. str /= "platform") &
& stop 26
case (omp_ipr_device)
if (ipr /= -7 .or. str /= "device") &
& stop 27
case (omp_ipr_device_context)
if (ipr /= -8 .or. str /= "device_context") &
& stop 28
case (omp_ipr_targetsync)
if (ipr /= -9 .or. str /= "targetsync") &
& stop 29
case default
! Valid, but unexpected to have more interop types,
! especially not for interop == omp_interop_none.
stop 30
end select
! As interop == omp_interop_none, expect NULL.
if (associated (omp_get_interop_type_desc (interop, ipr))) &
& stop 31
ret_code = omp_irc_success
ival = omp_get_interop_int (interop, ipr, ret_code)
if (ret_code /= omp_irc_empty) stop 32
if (ival /= 0) stop 33 ! Implementation choice
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 34
if (str /= "provided interoperability object is equal to " &
& // "omp_interop_none") &
& stop 35 ! GCC implementation choice.
ival = omp_get_interop_int (interop, ipr)
if (ival /= 0) stop 33 ! Implementation choice
ret_code = omp_irc_success
ptr = omp_get_interop_ptr (interop, ipr, ret_code)
if (ret_code /= omp_irc_empty) stop 36
if (c_associated (ptr)) stop 37 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 38
if (str /= "provided interoperability object is equal to " &
& // "omp_interop_none") &
& stop 39 ! GCC implementation choice.
ptr = omp_get_interop_ptr (interop, ipr)
if (c_associated (ptr)) stop 37 ! Obvious implementation choice.
ret_code = omp_irc_success
str => omp_get_interop_str (interop, ipr, ret_code)
if (ret_code /= omp_irc_empty) stop 40
if (associated (str)) stop 41 ! Obvious mplementation choice
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 42
if (str /= "provided interoperability object is equal to " &
& // "omp_interop_none") &
& stop 43 ! GCC implementation choice.
str => omp_get_interop_str (interop, ipr)
if (associated (str)) stop 41 ! Obvious mplementation choice
end do
! Invalid ipr.
! Valid are either omp_irc_empty (due to omp_interop_none) or
! omp_irc_out_of_range; assume omp_irc_out_of_range with GCC.
! omp_ipr_targetsync-1, i.e < lower bound.
ret_code = omp_irc_success
ival = omp_get_interop_int (interop, omp_ipr_targetsync-1, &
& ret_code)
if (ret_code /= omp_irc_out_of_range) stop 44
if (ival /= 0) stop 45 ! Implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 46
! GCC implementation choice.
if (str /= "property ID is out of range") stop 47
ival = omp_get_interop_int (interop, omp_ipr_targetsync-1)
if (ival /= 0) stop 45 ! Implementation choice.
ret_code = omp_irc_success
ptr = omp_get_interop_ptr (interop, omp_ipr_targetsync-1, &
& ret_code)
if (ret_code /= omp_irc_out_of_range) stop 48
if (c_associated (ptr)) stop 49 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 50
! GCC implementation choice.
if (str /= "property ID is out of range") stop 51
ptr = omp_get_interop_ptr (interop, omp_ipr_targetsync-1)
if (c_associated (ptr)) stop 49 ! Obvious implementation choice.
ret_code = omp_irc_success
str => omp_get_interop_str (interop, omp_ipr_targetsync-1, &
& ret_code)
if (ret_code /= omp_irc_out_of_range) stop 52
if (associated (str)) stop 53 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 54
! GCC implementation choice.
if (str /= "property ID is out of range") stop 55
str => omp_get_interop_str (interop, omp_ipr_targetsync-1)
if (associated (str)) stop 53 ! Obvious implementation choice.
! omp_get_num_interop_properties (), i.e > upper bound.
ret_code = omp_irc_success
ival = omp_get_interop_int (interop, &
& omp_get_num_interop_properties (interop), &
& ret_code)
if (ret_code /= omp_irc_out_of_range) stop 56
if (ival /= 0) stop 57 ! Implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 58
! GCC implementation choice.
if (str /= "property ID is out of range") stop 59
ret_code = omp_irc_success
ptr = omp_get_interop_ptr (interop, &
& omp_get_num_interop_properties (interop), ret_code)
if (ret_code /= omp_irc_out_of_range) stop 60
if (c_associated (ptr)) stop 61 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 62
! GCC implementation choice.
if (str /= "property ID is out of range") stop 63
ret_code = omp_irc_success
str => omp_get_interop_str (interop, &
& omp_get_num_interop_properties (interop), ret_code)
if (ret_code /= omp_irc_out_of_range) stop 64
if (associated (str)) stop 65 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 66
! GCC implementation choice.
if (str /= "property ID is out of range") stop 67
end

3
libgomp/testsuite/libgomp.fortran/interop-routines-2.F90 Normal file
View file

@ -0,0 +1,3 @@
! { dg-additional-options "-DUSE_OMP_HEADER=1" }
#include "interop-routines-1.F90"

2
libgomp/testsuite/libgomp.fortran/interop-routines-3.F Normal file
View file

@ -0,0 +1,2 @@
! Use fixed form
#include "interop-routines-1.F90"

4
libgomp/testsuite/libgomp.fortran/interop-routines-4.F Normal file
View file

@ -0,0 +1,4 @@
! { dg-additional-options "-DUSE_OMP_HEADER=1" }
! Use fixed form
#include "interop-routines-1.F90"

4
libgomp/testsuite/libgomp.fortran/interop-routines-5.F Normal file
View file

@ -0,0 +1,4 @@
! { dg-additional-options "-ffixed-line-length-80" }
! Use fixed form - but with 80 columns instead of 72
#include "interop-routines-1.F90"

4
libgomp/testsuite/libgomp.fortran/interop-routines-6.F Normal file
View file

@ -0,0 +1,4 @@
! { dg-additional-options "-DUSE_OMP_HEADER=1 -ffixed-line-length-80" }
! Use fixed form - but with 80 columns instead of 72
#include "interop-routines-1.F90"

290
libgomp/testsuite/libgomp.fortran/interop-routines-7.F90 Normal file
View file

@ -0,0 +1,290 @@
! { dg-do run { target { offload_device } } }
! OpenMP permits using the interop functions on the device,
! but it is not really supported. Hence, check that the stubs
! are working.
module m
contains
subroutine target_test
use iso_c_binding, only: c_intptr_t, c_ptr, c_associated
#ifndef USE_OMP_HEADER
use omp_lib
#endif
implicit none (type, external)
#ifdef USE_OMP_HEADER
include "omp_lib.h"
#endif
integer(omp_interop_kind) :: interop = omp_interop_none
integer(omp_interop_rc_kind) :: ret_code
integer(omp_interop_fr_kind) :: fr
integer(omp_interop_property_kind) :: ipr
integer(c_intptr_t) :: ival
type(c_ptr) :: ptr
character(len=:), pointer :: str
if (omp_is_initial_device()) &
! Already checked in interop-routines-1.F90
! And some assumptions below are only fulfilled for nonhost
& return
if (omp_irc_no_value /= 1) stop 1
if (omp_irc_success /= 0) stop 2
if (omp_irc_empty /= -1) stop 3
if (omp_irc_out_of_range /= -2) stop 4
if (omp_irc_type_int /= -3) stop 5
if (omp_irc_type_ptr /= -4) stop 6
if (omp_irc_type_str /= -5) stop 7
if (omp_irc_other /= -6) stop 8
! Check values, including invalid values.
do ret_code = omp_irc_other - 1, omp_irc_no_value + 1
str => omp_get_interop_rc_desc (interop, ret_code)
if (ret_code < omp_irc_other &
& .or. ret_code > omp_irc_no_value) then
! Assume disassociated for an invalid value.
if (associated (str)) stop 9
else if (ret_code == omp_irc_other) then
! Likely not to exist in an implementation; esp. not for
! omp_interop_none. Thus, assume disassociated.
! In GCC, omp_irc_other is used on the device side, only, to
! complain about omp_get_interop_{int,ptr,str} usage.
! See below for a check for the device side.
if (len_trim (str) <= 5) stop 11
else
! Assume that omp_get_interop_rc_desc handles all of those and
! not only omp_irc_empty (and possibly omp_irc_out_of_range),
! which do occur for omp_interop_none.
! Assume some sensible message, i.e. at least 5 characters.
if (len_trim (str) <= 5) stop 11
end if
end do
if (omp_ifr_last < omp_ifr_hsa) stop 12
do fr = omp_ifr_cuda, omp_ifr_last
select case (fr)
! Expect the id values from the additional-definition document.
case (omp_ifr_cuda)
if (fr /= 1) stop 13
case (omp_ifr_cuda_driver)
if (fr /= 2) stop 14
case (omp_ifr_opencl)
if (fr /= 3) stop 15
case (omp_ifr_sycl)
if (fr /= 4) stop 16
case (omp_ifr_hip)
if (fr /= 5) stop 17
case (omp_ifr_level_zero)
if (fr /= 6) stop 18
case (omp_ifr_hsa)
if (fr /= 7) stop 19
case default
! Valid, but unexpected to have more interop types.
stop 20
end select
end do
if (omp_ipr_first > omp_ipr_targetsync &
& .or. (omp_ipr_fr_id &
& >= omp_get_num_interop_properties (interop))) &
& stop 21
do ipr = omp_ipr_first, &
& omp_get_num_interop_properties (interop) - 1
! As interop == omp_interop_none, NULL is permissible;
! nonetheless, require != NULL for the GCC implementation.
str => omp_get_interop_name (interop, ipr)
select case (ipr)
case (omp_ipr_fr_id)
if (ipr /= -1 .or. str /= "fr_id") &
& stop 21
case (omp_ipr_fr_name)
if (ipr /= -2 .or. str /= "fr_name") &
& stop 22
case (omp_ipr_vendor)
if (ipr /= -3 .or. str /= "vendor") &
& stop 23
case (omp_ipr_vendor_name)
if (ipr /= -4 .or. str /= "vendor_name") &
& stop 24
case (omp_ipr_device_num)
if (ipr /= -5 .or. str /= "device_num") &
& stop 25
case (omp_ipr_platform)
if (ipr /= -6 .or. str /= "platform") &
& stop 26
case (omp_ipr_device)
if (ipr /= -7 .or. str /= "device") &
& stop 27
case (omp_ipr_device_context)
if (ipr /= -8 .or. str /= "device_context") &
& stop 28
case (omp_ipr_targetsync)
if (ipr /= -9 .or. str /= "targetsync") &
& stop 29
case default
! Valid, but unexpected to have more interop types,
! especially not for interop == omp_interop_none.
stop 30
end select
! As interop == omp_interop_none, expect NULL.
if (associated (omp_get_interop_type_desc (interop, ipr))) &
& stop 31
ret_code = omp_irc_success
ival = omp_get_interop_int (interop, ipr, ret_code)
if (ret_code /= omp_irc_empty) stop 32
if (ival /= 0) stop 33 ! Implementation choice
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 34
if (str /= "provided interoperability object is equal to " &
& // "omp_interop_none") &
& stop 35 ! GCC implementation choice.
ret_code = omp_irc_success
ptr = omp_get_interop_ptr (interop, ipr, ret_code)
if (ret_code /= omp_irc_empty) stop 36
if (c_associated (ptr)) stop 37 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 38
if (str /= "provided interoperability object is equal to " &
& // "omp_interop_none") &
& stop 39 ! GCC implementation choice.
ret_code = omp_irc_success
str => omp_get_interop_str (interop, ipr, ret_code)
if (ret_code /= omp_irc_empty) stop 40
if (associated (str)) stop 41 ! Obvious mplementation choice
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 42
if (str /= "provided interoperability object is equal to " &
& // "omp_interop_none") &
& stop 43 ! GCC implementation choice.
! Special case of GCC: For any non-'omp_interop_none' valued interop,
! a device-side call to omp_get_interop_{int,ptr,src} will yield
! omp_irc_other - with the error message as checked below.
block
integer(omp_interop_kind) :: interop_not_none_invalid &
& = int(z'DEADBEEF', omp_interop_kind)
ret_code = omp_irc_success
ival = omp_get_interop_int (interop_not_none_invalid, ipr, ret_code)
if (ret_code /= omp_irc_other) stop 101
if (ival /= 0) stop 102 ! Implementation choice
str => omp_get_interop_rc_desc (interop_not_none_invalid, ret_code)
if (len_trim (str) <= 5) stop 103
if (str /= "obtaining properties is only supported on the " &
& // "initial device") &
& stop 104 ! GCC implementation choice.
ret_code = omp_irc_success
ptr = omp_get_interop_ptr (interop_not_none_invalid, ipr, ret_code)
if (ret_code /= omp_irc_other) stop 105
if (c_associated (ptr)) stop 106 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop_not_none_invalid, ret_code)
if (len_trim (str) <= 5) stop 107
if (str /= "obtaining properties is only supported on the " &
& // "initial device") &
& stop 108 ! GCC implementation choice.
ret_code = omp_irc_success
str => omp_get_interop_str (interop_not_none_invalid, ipr, ret_code)
if (ret_code /= omp_irc_other) stop 109
if (associated (str)) stop 110 ! Obvious mplementation choice
str => omp_get_interop_rc_desc (interop_not_none_invalid, ret_code)
if (len_trim (str) <= 5) stop 111
if (str /= "obtaining properties is only supported on the " &
& // "initial device") &
& stop 112 ! GCC implementation choice.
end block
end do
! Invalid ipr.
! Valid are either omp_irc_empty (due to omp_interop_none) or
! omp_irc_out_of_range; assume omp_irc_out_of_range with GCC.
! omp_ipr_targetsync-1, i.e < lower bound.
ret_code = omp_irc_success
ival = omp_get_interop_int (interop, omp_ipr_targetsync-1, &
& ret_code)
if (ret_code /= omp_irc_out_of_range) stop 44
if (ival /= 0) stop 45 ! Implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 46
! GCC implementation choice.
if (str /= "property ID is out of range") stop 47
ret_code = omp_irc_success
ptr = omp_get_interop_ptr (interop, omp_ipr_targetsync-1, &
& ret_code)
if (ret_code /= omp_irc_out_of_range) stop 48
if (c_associated (ptr)) stop 49 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 50
! GCC implementation choice.
if (str /= "property ID is out of range") stop 51
ret_code = omp_irc_success
str => omp_get_interop_str (interop, omp_ipr_targetsync-1, &
& ret_code)
if (ret_code /= omp_irc_out_of_range) stop 52
if (associated (str)) stop 53 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 54
! GCC implementation choice.
if (str /= "property ID is out of range") stop 55
! omp_get_num_interop_properties (), i.e > upper bound.
ret_code = omp_irc_success
ival = omp_get_interop_int (interop, &
& omp_get_num_interop_properties (interop), &
& ret_code)
if (ret_code /= omp_irc_out_of_range) stop 56
if (ival /= 0) stop 57 ! Implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 58
! GCC implementation choice.
if (str /= "property ID is out of range") stop 59
ret_code = omp_irc_success
ptr = omp_get_interop_ptr (interop, &
& omp_get_num_interop_properties (interop), ret_code)
if (ret_code /= omp_irc_out_of_range) stop 60
if (c_associated (ptr)) stop 61 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 62
! GCC implementation choice.
if (str /= "property ID is out of range") stop 63
ret_code = omp_irc_success
str => omp_get_interop_str (interop, &
& omp_get_num_interop_properties (interop), ret_code)
if (ret_code /= omp_irc_out_of_range) stop 64
if (associated (str)) stop 65 ! Obvious implementation choice.
str => omp_get_interop_rc_desc (interop, ret_code)
if (len_trim (str) <= 5) stop 66
! GCC implementation choice.
if (str /= "property ID is out of range") stop 67
end
end module
program main
use omp_lib, only: omp_get_num_devices
use m
implicit none (type, external)
integer :: dev
do dev = 0, omp_get_num_devices () - 1
!$omp target device(device_num : dev)
call target_test
!$omp end target
end do
end