(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)
(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)
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
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
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;
omp_pause_hard = 2
} omp_pause_resource_t;
+typedef __INTPTR_TYPE__ omp_intptr_t;
typedef __UINTPTR_TYPE__ omp_uintptr_t;
#if __cplusplus >= 201103L
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;
__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__ *,
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;
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
--- /dev/null
+/* { 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;
+}
--- /dev/null
+/* { 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;
+}
--- /dev/null
+ 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
--- /dev/null
+! { dg-additional-options "-DUSE_OMP_HEADER=1" }
+
+#include "interop-routines-1.F90"
--- /dev/null
+! Use fixed form
+#include "interop-routines-1.F90"
--- /dev/null
+! { dg-additional-options "-DUSE_OMP_HEADER=1" }
+! Use fixed form
+
+#include "interop-routines-1.F90"
--- /dev/null
+! { dg-additional-options "-ffixed-line-length-80" }
+! Use fixed form - but with 80 columns instead of 72
+
+#include "interop-routines-1.F90"
--- /dev/null
+! { 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"
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
