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
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
|
! { dg-additional-options "-fdump-tree-omplower" }
! For the 4 vars in omp_parallel, 4 in omp_target and 2 in no_alloc2_func.
! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 10 "omplower" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 10 "omplower" } }
module m
use iso_c_binding
use omp_lib
implicit none (type, external)
integer(c_intptr_t) :: intptr
contains
subroutine check_int (x, y)
integer :: x, y
value :: y
if (x /= y) &
stop 1
end
subroutine check_ptr (x, y)
type(c_ptr) :: x
integer(c_intptr_t), value :: y
if (transfer(x,intptr) /= y) &
stop 2
end
integer function no_alloc_func () result(res)
! There is no __builtin_GOMP_alloc / __builtin_GOMP_free as
! allocator == omp_default_mem_alloc (known at compile time.
integer :: no_alloc
!$omp allocate(no_alloc) allocator(omp_default_mem_alloc)
no_alloc = 7
res = no_alloc
end
integer function no_alloc2_func() result(res)
! If no_alloc2 were TREE_UNUSED, there would be no
! __builtin_GOMP_alloc / __builtin_GOMP_free
! However, as the parser already marks no_alloc2
! and is_alloc2 as used, the tree is generated for both vars.
integer :: no_alloc2, is_alloc2
!$omp allocate(no_alloc2, is_alloc2)
is_alloc2 = 7
res = is_alloc2
end
subroutine omp_parallel ()
integer :: i, n, iii, jjj(5)
type(c_ptr) :: ptr
!$omp allocate(iii, jjj, ptr)
n = 6
iii = 5
ptr = transfer (int(z'1234', c_intptr_t), ptr)
block
integer :: kkk(n)
!$omp allocate(kkk)
do i = 1, 5
jjj(i) = 3*i
end do
do i = 1, 6
kkk(i) = 7*i
end do
!$omp parallel default(none) firstprivate(iii, jjj, kkk, ptr) if(.false.)
if (iii /= 5) &
stop 3
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 4
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 5
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 6
ptr = transfer (int(z'abcd', c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 7
call check_ptr (ptr, int(z'abcd', c_intptr_t))
!$omp end parallel
if (iii /= 5) &
stop 8
call check_int (iii, 5)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 9
call check_int (jjj(i), 3*i)
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 10
call check_int (kkk(i), 7*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 11
call check_ptr (ptr, int(z'1234', c_intptr_t))
!$omp parallel default(firstprivate) if(.false.)
if (iii /= 5) &
stop 12
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 13
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 14
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 15
ptr = transfer (int (z'abcd', c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 16
call check_ptr (ptr, int (z'abcd', c_intptr_t))
!$omp end parallel
if (iii /= 5) &
stop 17
call check_int (iii, 5)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 18
call check_int (jjj(i), 3*i)
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 19
call check_int (kkk(i), 7*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 20
call check_ptr (ptr, int (z'1234', c_intptr_t))
end block
end
subroutine omp_target ()
integer :: i, n, iii, jjj(5)
type(c_ptr) :: ptr
!$omp allocate(iii, jjj, ptr)
n = 6
iii = 5
ptr = transfer (int (z'1234', c_intptr_t), ptr)
block
integer :: kkk(n)
!$omp allocate(kkk)
do i = 1, 5
jjj(i) = 3*i
end do
do i = 1, 6
kkk(i) = 7*i
end do
!$omp target defaultmap(none) firstprivate(iii, jjj, kkk, ptr) private(i)
if (iii /= 5) &
stop 21
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 22
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 23
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 24
ptr = transfer (int (z'abcd', c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 25
call check_ptr (ptr, int (z'abcd', c_intptr_t))
!$omp end target
if (iii /= 5) &
stop 26
call check_int (iii, 5)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 27
call check_int (jjj(i), 3*i)
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 28
call check_int (kkk(i), 7*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 29
call check_ptr (ptr, int (z'1234', c_intptr_t))
!$omp target defaultmap(firstprivate)
if (iii /= 5) &
stop 30
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 31
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 32
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 33
ptr = transfer (int (z'abcd', c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 34
call check_ptr (ptr, int (z'abcd', c_intptr_t))
!$omp end target
if (iii /= 5) &
stop 35
call check_int (iii, 5)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 36
call check_int (jjj(i), 3*i)
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 37
call check_int (kkk(i), 7*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 38
call check_ptr (ptr, int (z'1234', c_intptr_t))
!$omp target defaultmap(tofrom)
if (iii /= 5) &
stop 39
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 40
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 41
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 42
ptr = transfer (int(z'abcd',c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 43
call check_ptr (ptr, int (z'abcd', c_intptr_t))
!$omp end target
if (iii /= 7) &
stop 44
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 4*i) &
stop 45
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
if (kkk(i) /= 8*i) &
stop 46
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 47
call check_ptr (ptr, int (z'abcd', c_intptr_t))
end block
end
end module
use m
call omp_parallel ()
call omp_target ()
end
|
