[Openmp-commits] [openmp] [OpenMP] Example Fortran API implementation (PR #191504)
Hansang Bae via Openmp-commits
openmp-commits at lists.llvm.org
Fri Apr 10 12:49:00 PDT 2026
https://github.com/hansangbae created https://github.com/llvm/llvm-project/pull/191504
This change shows how Fortran API routines can be implemented in the omp_lib module, and it is not intended to be merged.
It only contains the source code change, but the following processes are expected when building libomp.
- The Fortran build compiler compiles omp_lib.F90 and produces omp_lib.mod and omp_lib.o.
- The object file (omp_lib.o) is linked into the host OpenMP runtime.
- The introduced dependency while including omp_lib.o needs to be resolved somehow.
The purpose of this example is to share one possible approach to implementing the listed new API routines, so we can ignore this change if someone suggests a better approach.
>From b7502b5c7a3c26feabd3621da3c64a6520a134c7 Mon Sep 17 00:00:00 2001
From: Hansang Bae <hansang.bae at intel.com>
Date: Fri, 10 Apr 2026 13:20:10 -0500
Subject: [PATCH] [OpenMP] Example Fortran API implementation
This change shows how Fortran API routines can be implemented in the
omp_lib module, and it is not intended to be merged.
It only contains the source code change, but the following processes
are expected when building libomp.
- The Fortran build compiler compiles omp_lib.F90 and produces
omp_lib.mod and omp_lib.o.
- The object file (omp_lib.o) is linked into the host OpenMP runtime.
- The introduced dependency while including omp_lib.o needs to be
resolved somehow.
The purpose of this example is to share one possible approach to
implementing the listed new API routines, so we can ignore this
change if someone suggests a better approach.
---
openmp/module/omp_lib.F90.var | 184 ++++++++++++++++++++++++++++
openmp/runtime/src/kmp_csupport.cpp | 55 +++++++++
2 files changed, 239 insertions(+)
diff --git a/openmp/module/omp_lib.F90.var b/openmp/module/omp_lib.F90.var
index 90d7e49ebf549..59f7d01f41fa4 100644
--- a/openmp/module/omp_lib.F90.var
+++ b/openmp/module/omp_lib.F90.var
@@ -40,6 +40,8 @@
integer, parameter, public :: omp_alloctrait_val_kind = c_intptr_t
integer, parameter, public :: omp_interop_kind = c_intptr_t
integer, parameter, public :: omp_interop_fr_kind = omp_integer_kind
+ integer, parameter, public :: omp_interop_property_kind = omp_integer_kind
+ integer, parameter, public :: omp_interop_rc_kind = omp_integer_kind
type omp_alloctrait
integer(kind=omp_alloctrait_key_kind) key
@@ -84,6 +86,8 @@
public :: omp_alloctrait_val_kind
public :: omp_interop_kind
public :: omp_interop_fr_kind
+ public :: omp_interop_property_kind
+ public :: omp_interop_rc_kind
public :: omp_alloctrait
public :: omp_pause_resource_kind
public :: omp_depend_kind
@@ -213,6 +217,26 @@
integer (kind=omp_interop_fr_kind), parameter, public :: omp_ifr_level_zero = 6
integer (kind=omp_interop_fr_kind), parameter, public :: omp_ifr_last = 7
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_fr_id = -1
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_fr_name = -2
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_vendor = -3
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_vendor_name = -4
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_device_num = -5
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_platform = -6
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_device = -7
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_device_context = -8
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_targetsync = -9
+ integer (kind=omp_interop_property_kind), parameter, public :: omp_ipr_first = -9
+
+ integer (kind=omp_interop_rc_kind), parameter, public :: omp_irc_no_value = 1
+ integer (kind=omp_interop_rc_kind), parameter, public :: omp_irc_success = 0
+ integer (kind=omp_interop_rc_kind), parameter, public :: omp_irc_empty = -1
+ integer (kind=omp_interop_rc_kind), parameter, public :: omp_irc_out_of_range = -2
+ integer (kind=omp_interop_rc_kind), parameter, public :: omp_irc_type_int = -3
+ integer (kind=omp_interop_rc_kind), parameter, public :: omp_irc_type_ptr = -4
+ integer (kind=omp_interop_rc_kind), parameter, public :: omp_irc_type_str = -5
+ integer (kind=omp_interop_rc_kind), parameter, public :: omp_irc_other = -6
+
integer (kind=omp_interop_kind), parameter, public :: omp_interop_none = 0
interface
@@ -1058,6 +1082,63 @@
logical (kind=omp_logical_kind) kmp_get_cancellation_status
end function kmp_get_cancellation_status
+ !
+ ! Interface used internally to support Fortran API implementation
+ !
+
+ integer(c_int) function kmp_strlen(charptr) bind(c, name="strlen")
+ use, intrinsic :: iso_c_binding, only : c_int, c_ptr
+ type(c_ptr), value :: charptr
+ end function kmp_strlen
+
+ type(c_ptr) function kmp_get_uid_from_device(device_num) &
+ bind(c, name="__kmpc_get_uid_from_device")
+ use, intrinsic :: iso_c_binding, only : c_ptr
+ integer, value :: device_num
+ end function kmp_get_uid_from_device
+
+ function kmp_get_interop_ptr(interop, property_id, ret_code) &
+ bind(c, name="__kmpc_get_interop_ptr")
+ use, intrinsic :: iso_c_binding, only : c_int, c_intptr_t, c_ptr
+ type(c_ptr) :: kmp_get_interop_ptr
+ integer(c_intptr_t), value :: interop
+ integer(c_int), value :: property_id
+ integer(c_int) :: ret_code
+ end function kmp_get_interop_ptr
+
+ function kmp_get_interop_str(interop, property_id, ret_code) &
+ bind(c, name="__kmpc_get_interop_str")
+ use, intrinsic :: iso_c_binding, only : c_int, c_intptr_t, c_ptr
+ type(c_ptr) :: kmp_get_interop_str
+ integer(c_intptr_t), value :: interop
+ integer(c_int), value :: property_id
+ integer(c_int) :: ret_code
+ end function kmp_get_interop_str
+
+ function kmp_get_interop_name(interop, property_id) &
+ bind(c, name="__kmpc_get_interop_name")
+ use, intrinsic :: iso_c_binding, only : c_int, c_intptr_t, c_ptr
+ type(c_ptr) :: kmp_get_interop_name
+ integer(c_intptr_t), value :: interop
+ integer(c_int), value :: property_id
+ end function kmp_get_interop_name
+
+ function kmp_get_interop_type_desc(interop, property_id) &
+ bind(c, name="__kmpc_get_interop_type_desc")
+ use, intrinsic :: iso_c_binding, only : c_int, c_intptr_t, c_ptr
+ type(c_ptr) :: kmp_get_interop_type_desc
+ integer(c_intptr_t), value :: interop
+ integer(c_int), value :: property_id
+ end function kmp_get_interop_type_desc
+
+ function kmp_get_interop_rc_desc(interop, ret_code) &
+ bind(c, name="__kmpc_get_interop_rc_desc")
+ use, intrinsic :: iso_c_binding, only : c_int, c_intptr_t, c_ptr
+ type(c_ptr) :: kmp_get_interop_rc_desc
+ integer(c_intptr_t), value :: interop
+ integer(c_int), value :: ret_code
+ end function kmp_get_interop_rc_desc
+
end interface
! make the above routine definitions public
@@ -1179,5 +1260,108 @@
public :: kmp_set_warnings_on
public :: kmp_set_warnings_off
public :: kmp_get_cancellation_status
+ contains
+
+! *
+! * Routines implemented in Fortran
+! *
+
+! This routine is implemented in Fortran since it returns assumed-size
+! character array which requires a dope vector.
+
+ character(:) function omp_get_uid_from_device(device_num)
+ use, intrinsic :: iso_c_binding
+ pointer :: omp_get_uid_from_device
+ integer, intent(in) :: device_num
+ integer(c_int) :: length
+ type(c_ptr) :: charptr_c
+
+ charptr_c = kmp_get_uid_from_device(device_num)
+ if (.not. c_associated(charptr_c)) then
+ nullify (omp_get_uid_from_device)
+ else
+ length = kmp_strlen(charptr_c)
+ call c_f_strpointer(charptr_c, omp_get_uid_from_device, length)
+ endif
+ end function omp_get_uid_from_device
+
+ function omp_get_interop_ptr(interop, property_id, ret_code)
+ use, intrinsic :: iso_c_binding
+ type (c_ptr) :: omp_get_interop_ptr
+ integer (kind=omp_interop_kind), intent(in) :: interop
+ integer (kind=omp_interop_property_kind) property_id
+ integer (kind=omp_interop_rc_kind), intent(out), optional :: ret_code
+
+ omp_get_interop_ptr = kmp_get_interop_ptr(interop, property_id, ret_code)
+ end function omp_get_interop_ptr
+
+ character(:) function omp_get_interop_str(interop, property_id, ret_code)
+ use, intrinsic :: iso_c_binding
+ pointer :: omp_get_interop_str
+ integer (kind=omp_interop_kind), intent(in) :: interop
+ integer (kind=omp_interop_property_kind) property_id
+ integer (kind=omp_interop_rc_kind), intent(out), optional :: ret_code
+ integer (kind=c_int) :: length
+ type(c_ptr) :: cstr
+
+ cstr = kmp_get_interop_str(interop, property_id, ret_code)
+ if (c_associated(cstr)) then
+ length = kmp_strlen(cstr)
+ call c_f_strpointer(cstr, omp_get_interop_str, length)
+ else
+ nullify (omp_get_interop_str)
+ endif
+ end function omp_get_interop_str
+
+ character(:) function omp_get_interop_name(interop, property_id)
+ use, intrinsic :: iso_c_binding
+ pointer :: omp_get_interop_name
+ integer (kind=omp_interop_kind), intent(in) :: interop
+ integer (kind=omp_interop_property_kind) property_id
+ integer (kind=c_int) :: length
+ type(c_ptr) :: cstr
+
+ cstr = kmp_get_interop_name(interop, property_id)
+ if (c_associated(cstr)) then
+ length = kmp_strlen(cstr)
+ call c_f_strpointer(cstr, omp_get_interop_name, length)
+ else
+ nullify (omp_get_interop_name)
+ endif
+ end function omp_get_interop_name
+
+ character(:) function omp_get_interop_type_desc(interop, property_id)
+ use, intrinsic :: iso_c_binding
+ pointer :: omp_get_interop_type_desc
+ integer (kind=omp_interop_kind), intent(in) :: interop
+ integer (kind=omp_interop_property_kind) property_id
+ integer (kind=c_int) :: length
+ type(c_ptr) :: cstr
+
+ cstr = kmp_get_interop_type_desc(interop, property_id)
+ if (c_associated(cstr)) then
+ length = kmp_strlen(cstr)
+ call c_f_strpointer(cstr, omp_get_interop_type_desc, length)
+ else
+ nullify (omp_get_interop_type_desc)
+ endif
+ end function omp_get_interop_type_desc
+
+ character(:) function omp_get_interop_rc_desc(interop, ret_code)
+ use, intrinsic :: iso_c_binding
+ pointer :: omp_get_interop_rc_desc
+ integer (kind=omp_interop_kind), intent(in) :: interop
+ integer (kind=omp_interop_rc_kind) ret_code
+ integer (kind=c_int) :: length
+ type(c_ptr) :: cstr
+
+ cstr = kmp_get_interop_rc_desc(interop, ret_code)
+ if (c_associated(cstr)) then
+ length = kmp_strlen(cstr)
+ call c_f_strpointer(cstr, omp_get_interop_rc_desc, length)
+ else
+ nullify (omp_get_interop_rc_desc)
+ endif
+ end function omp_get_interop_rc_desc
end module omp_lib
diff --git a/openmp/runtime/src/kmp_csupport.cpp b/openmp/runtime/src/kmp_csupport.cpp
index 8aa9a9caa924b..8e91616e696fe 100644
--- a/openmp/runtime/src/kmp_csupport.cpp
+++ b/openmp/runtime/src/kmp_csupport.cpp
@@ -4607,6 +4607,61 @@ void __kmpc_end_scope(ident_t *loc, kmp_int32 gtid, void *reserved) {
#endif // OMPT_SUPPORT && OMPT_OPTIONAL
}
+const char *__kmpc_get_uid_from_device(int device_num) {
+#ifndef KMP_STUB
+ const char *(*fn)(int);
+ if ((*(void **)(&fn) = KMP_DLSYM("omp_get_uid_from_device")))
+ return (*fn)(device_num);
+#endif
+ return NULL;
+}
+
+void *__kmpc_get_interop_ptr(void *interop, int property_id, int *ret_code) {
+#ifndef KMP_STUB
+ void *(*fn)(void *, int, int *);
+ if ((*(void **)(&fn) = KMP_DLSYM("omp_get_interop_ptr")))
+ return (*fn)(interop, property_id, ret_code);
+#endif
+ return NULL;
+}
+
+const char *__kmpc_get_interop_str(void *interop, int property_id,
+ int *ret_code) {
+#ifndef KMP_STUB
+ const char *(*fn)(void *, int, int *);
+ if ((*(void **)(&fn) = KMP_DLSYM("omp_get_interop_str")))
+ return (*fn)(interop, property_id, ret_code);
+#endif
+ return NULL;
+}
+
+const char *__kmpc_get_interop_name(void *interop, int property_id) {
+#ifndef KMP_STUB
+ const char *(*fn)(void *, int);
+ if ((*(void **)(&fn) = KMP_DLSYM("omp_get_interop_name")))
+ return (*fn)(interop, property_id);
+#endif
+ return NULL;
+}
+
+const char *__kmpc_get_interop_type_desc(void *interop, int property_id) {
+#ifndef KMP_STUB
+ const char *(*fn)(void *, int);
+ if ((*(void **)(&fn) = KMP_DLSYM("omp_get_interop_type_desc")))
+ return (*fn)(interop, property_id);
+#endif
+ return NULL;
+}
+
+const char *__kmpc_get_interop_rc_desc(void *interop, int ret_code) {
+#ifndef KMP_STUB
+ const char *(*fn)(void *, int);
+ if ((*(void **)(&fn) = KMP_DLSYM("omp_get_interop_rc_desc")))
+ return (*fn)(interop, ret_code);
+#endif
+ return NULL;
+}
+
#ifdef KMP_USE_VERSION_SYMBOLS
// For GOMP compatibility there are two versions of each omp_* API.
// One is the plain C symbol and one is the Fortran symbol with an appended
More information about the Openmp-commits
mailing list