This is nearly identical to v2, except that I presumably used 'git add
testsuite' when intending to use 'git add -u testsuite' in a last-minute
change as it contained a bunch of unrelated test files …
The only other change besides removing unrelated files is that for the
generic part of omp_get_interop_type_desc, the data types ('int' for
fr_id, vendor, device_num; const char*' for fr_name, vendor_name) are
now returned in target.c while the specific types (for device,
device_context, targetsync platform) will eventually be handled by the
plugin function.
Tobias
Am 21.08.24 um 20:27 schrieb Tobias Burnus:
Nearly identical to v1, except that I realized that OpenMP permits to
call those functions also from target regions.
Hence, those also got those functions, including a use of
omp_irc_other to make clear why it will fail …
In addition, two (nonhost) target-region test files were added.
Comments, remarks, suggestions before I commit it?
Otherwise, the following still applies:
This patch adds 'interop' to C/C++'s omp.h and Fortran's omp_lib.h
and omp_lib module.
The implementation should match OpenMP 5.1 (which added interop) and
also TR13; the Fortran routine support is new in TR13. It also adds
'hsa' as foreign object enum/paramter, which is currently being added
to the additional-definitions document.
* * *
The routine interface does not exactly match the OpenMP spec as some
VALUE and BIND(C) and one c_int has been used to reduce pointless
differences between OpenMP and C/C++.
This shouldn't affect the usage as almost no user will worries about
the API used for a procedure reference. But if a user defines the
routine interface him-/herself, this will fail. (But why should
(s)he? There is 'omp_lib.h' and the 'omp_lib' module, after all – and
several items in those files are implementation defined.)
On the C/C++ side, there are also some differences (at least with
TR13) with regards to unsigned vs. signed and to enum (of size
__UINTPTR_T__) vs. 'typdef (u)intptr_t', but they shouldn't matter
either (effectively same API) – and, again, there is a omp.h, which
any sensible user should use.
* * *
While there is a stub implementation for the routines, to make them
really useful, two things are missing: Support for the 'interop'
directive in the compiler itself (+ a libgomp function for it) and
supporting some foreign run time types in the libgomp plugin. Also
missing is the documentation of the added routines in libgomp.texi.
All of which will be added in later patches.
Build + tested on x86-64-gnu-linux (with offloading enabled but
that's not yet relevant).
Cheers,
Tobias
libgomp: Add interop types and routines to OpenMP's headers and module
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.
* 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/interop-routines-1.c: New test.
* testsuite/libgomp.c/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.
libgomp/config/gcn/target.c | 99 +++++++
libgomp/config/nvptx/target.c | 99 +++++++
libgomp/fortran.c | 41 +++
libgomp/libgomp.map | 15 +
libgomp/omp.h.in | 69 +++++
libgomp/omp_lib.f90.in | 99 +++++++
libgomp/omp_lib.h.in | 167 +++++++++--
libgomp/target.c | 104 +++++++
libgomp/testsuite/libgomp.c/interop-routines-1.c | 248 +++++++++++++++++
libgomp/testsuite/libgomp.c/interop-routines-2.c | 304 +++++++++++++++++++++
.../libgomp.fortran/interop-routines-1.F90 | 224 +++++++++++++++
.../libgomp.fortran/interop-routines-2.F90 | 3 +
.../testsuite/libgomp.fortran/interop-routines-3.F | 2 +
.../testsuite/libgomp.fortran/interop-routines-4.F | 4 +
.../testsuite/libgomp.fortran/interop-routines-5.F | 4 +
.../testsuite/libgomp.fortran/interop-routines-6.F | 4 +
.../libgomp.fortran/interop-routines-7.F90 | 290 ++++++++++++++++++++
17 files changed, 1754 insertions(+), 22 deletions(-)
diff --git a/libgomp/config/gcn/target.c b/libgomp/config/gcn/target.c
index 9cafea4e2cc..e9141f20ef3 100644
--- a/libgomp/config/gcn/target.c
+++ b/libgomp/config/gcn/target.c
@@ -185,3 +185,102 @@ 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 (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 (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 (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)
diff --git a/libgomp/config/nvptx/target.c b/libgomp/config/nvptx/target.c
index 8d4dc5f661a..ca53ef1b6d3 100644
--- a/libgomp/config/nvptx/target.c
+++ b/libgomp/config/nvptx/target.c
@@ -197,3 +197,102 @@ 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 (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 (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 (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)
diff --git a/libgomp/fortran.c b/libgomp/fortran.c
index cfbea32b022..a76c33cee52 100644
--- a/libgomp/fortran.c
+++ b/libgomp/fortran.c
@@ -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
diff --git a/libgomp/libgomp.map b/libgomp/libgomp.map
index 65901dff235..7c2345eb29b 100644
--- a/libgomp/libgomp.map
+++ b/libgomp/libgomp.map
@@ -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;
diff --git a/libgomp/omp.h.in b/libgomp/omp.h.in
index 4438d341160..9fadf890c2c 100644
--- a/libgomp/omp.h.in
+++ b/libgomp/omp.h.in
@@ -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,6 +192,51 @@ 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 ()
@@ -351,6 +397,29 @@ 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_NOTHROW;
+
+extern void *omp_get_interop_ptr (const omp_interop_t, omp_interop_property_t,
+ omp_interop_rc_t *) __GOMP_NOTHROW;
+
+extern const char *omp_get_interop_str (const omp_interop_t,
+ omp_interop_property_t,
+ omp_interop_rc_t *) __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
diff --git a/libgomp/omp_lib.f90.in b/libgomp/omp_lib.f90.in
index 545a79fcec9..093ae2d195b 100644
--- a/libgomp/omp_lib.f90.in
+++ b/libgomp/omp_lib.f90.in
@@ -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), 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), 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), 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
diff --git a/libgomp/omp_lib.h.in b/libgomp/omp_lib.h.in
index b5144bb4144..bac0724bfe1 100644
--- a/libgomp/omp_lib.h.in
+++ b/libgomp/omp_lib.h.in
@@ -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,66 @@
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), 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), 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), 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
diff --git a/libgomp/target.c b/libgomp/target.c
index fb9a6fb5c79..cc1074243e0 100644
--- a/libgomp/target.c
+++ b/libgomp/target.c
@@ -5113,6 +5113,110 @@ 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 (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 (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 (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 __attribute__ ((unused)),
+ omp_interop_property_t property_id
+ __attribute__ ((unused)))
+{
+ static const char *desc = {"int", /* fr_id */
+ "const char*", /* fr_name */
+ "int", /* vendor */
+ "const char *", /* vendor_name */
+ "int"}; /* device_num */
+ if (interop == omp_interop_none)
+ return NULL;
+ if (property_id > fr_id || property_id < omp_ipr_first)
+ 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
diff --git a/libgomp/testsuite/libgomp.c/interop-routines-1.c b/libgomp/testsuite/libgomp.c/interop-routines-1.c
new file mode 100644
index 00000000000..9f13b49bbe8
--- /dev/null
+++ b/libgomp/testsuite/libgomp.c/interop-routines-1.c
@@ -0,0 +1,248 @@
+/* { 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_irc_other-1;
+ ret_code3 <= omp_irc_no_value + 1; ret_code3++)
+ {
+ 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++)
+ {
+ 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++)
+ {
+ /* 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. */
+
+ 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. */
+
+ 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. */
+ }
+
+ /* 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_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"));
+
+ ret_code2 = omp_irc_success;
+ ptr2 = omp_get_interop_ptr (interop, 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"));
+
+ ret_code2 = omp_irc_success;
+ str2 = omp_get_interop_str (interop, 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"));
+
+ /* omp_get_num_interop_properties (), i.e > upper bound. */
+
+ ret_code2 = omp_irc_success;
+ ival2 = omp_get_interop_int (interop,
+ 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_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_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;
+}
diff --git a/libgomp/testsuite/libgomp.c/interop-routines-2.c b/libgomp/testsuite/libgomp.c/interop-routines-2.c
new file mode 100644
index 00000000000..9993c6f24ef
--- /dev/null
+++ b/libgomp/testsuite/libgomp.c/interop-routines-2.c
@@ -0,0 +1,304 @@
+/* { 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_irc_other-1;
+ ret_code3 <= omp_irc_no_value + 1; ret_code3++)
+ {
+ 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++)
+ {
+ 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++)
+ {
+ /* 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. */
+
+ 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. */
+
+ 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. */
+
+ /* 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 = 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_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"));
+
+ ret_code2 = omp_irc_success;
+ ptr2 = omp_get_interop_ptr (interop, 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"));
+
+ ret_code2 = omp_irc_success;
+ str2 = omp_get_interop_str (interop, 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"));
+
+ /* omp_get_num_interop_properties (), i.e > upper bound. */
+
+ ret_code2 = omp_irc_success;
+ ival2 = omp_get_interop_int (interop,
+ 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_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_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;
+}
diff --git a/libgomp/testsuite/libgomp.fortran/interop-routines-1.F90 b/libgomp/testsuite/libgomp.fortran/interop-routines-1.F90
new file mode 100644
index 00000000000..851bed10028
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/interop-routines-1.F90
@@ -0,0 +1,224 @@
+ 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.
+
+ 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.
+ 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
diff --git a/libgomp/testsuite/libgomp.fortran/interop-routines-2.F90 b/libgomp/testsuite/libgomp.fortran/interop-routines-2.F90
new file mode 100644
index 00000000000..d0a6752ff8e
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/interop-routines-2.F90
@@ -0,0 +1,3 @@
+! { dg-additional-options "-DUSE_OMP_HEADER=1" }
+
+#include "interop-routines-1.F90"
diff --git a/libgomp/testsuite/libgomp.fortran/interop-routines-3.F b/libgomp/testsuite/libgomp.fortran/interop-routines-3.F
new file mode 100644
index 00000000000..a8d23d7b2d6
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/interop-routines-3.F
@@ -0,0 +1,2 @@
+! Use fixed form
+#include "interop-routines-1.F90"
diff --git a/libgomp/testsuite/libgomp.fortran/interop-routines-4.F b/libgomp/testsuite/libgomp.fortran/interop-routines-4.F
new file mode 100644
index 00000000000..bbc245f8e8f
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/interop-routines-4.F
@@ -0,0 +1,4 @@
+! { dg-additional-options "-DUSE_OMP_HEADER=1" }
+! Use fixed form
+
+#include "interop-routines-1.F90"
diff --git a/libgomp/testsuite/libgomp.fortran/interop-routines-5.F b/libgomp/testsuite/libgomp.fortran/interop-routines-5.F
new file mode 100644
index 00000000000..b97bfcf30d1
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/interop-routines-5.F
@@ -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"
diff --git a/libgomp/testsuite/libgomp.fortran/interop-routines-6.F b/libgomp/testsuite/libgomp.fortran/interop-routines-6.F
new file mode 100644
index 00000000000..faea4853a85
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/interop-routines-6.F
@@ -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"
diff --git a/libgomp/testsuite/libgomp.fortran/interop-routines-7.F90 b/libgomp/testsuite/libgomp.fortran/interop-routines-7.F90
new file mode 100644
index 00000000000..a615d4b03ca
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/interop-routines-7.F90
@@ -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
