1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
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
|
