1 /*
2 * Copyright (c) 1995-2018, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /* clang-format off */
19
20 /* pack/unpack intrinsics */
21
22 #include "stdioInterf.h"
23 #include "fioMacros.h"
24
25 extern void (*__fort_scalar_copy[__NTYPES])(void *rp, void *sp, int len);
26
I8(next_index)27 static int I8(next_index)(__INT_T *index, F90_Desc *s)
28 {
29 __INT_T i;
30
31 for (i = 0; i < F90_RANK_G(s); i++) {
32 index[i]++;
33 if (index[i] <= DIM_UBOUND_G(s, i))
34 return 1; /* keep going */
35 index[i] = F90_DIM_LBOUND_G(s, i);
36 }
37 return 0; /* finished */
38 }
39
40 /* pack, optional vector arg present. pack masked elements of array
41 into result and fill remainder of result with corresponding
42 elements of vector */
43
ENTFTN(PACK,pack)44 void ENTFTN(PACK, pack)(void *rb, /* result base */
45 void *ab, /* array base */
46 void *mb, /* mask base */
47 void *vb, /* vector base */
48 F90_Desc *result, /* result descriptor */
49 F90_Desc *array, /* array descriptor */
50 F90_Desc *mask, /* mask descriptor */
51 F90_Desc *vector) /* vector descriptor */
52 {
53 char *la, *rf, *vf;
54 __INT_T rindex;
55 __INT_T vindex;
56 __INT_T aindex[MAXDIMS];
57 __INT_T mindex[MAXDIMS];
58 __BIGREAL_T tmp[4];
59 __INT_T mlen;
60 __INT_T i, mask_is_array, more_array, more_vector, mval;
61
62 if (result == NULL || F90_TAG_G(result) != __DESC)
63 __fort_abort("PACK: invalid result descriptor");
64
65 if (vector == NULL || F90_TAG_G(vector) != __DESC)
66 __fort_abort("PACK: invalid vector descriptor");
67
68 if (F90_GSIZE_G(result) == 0 || F90_GSIZE_G(vector) == 0)
69 return;
70
71 rf = (char *)rb + DIST_SCOFF_G(result) * F90_LEN_G(result);
72 vf = (char *)vb + DIST_SCOFF_G(vector) * F90_LEN_G(vector);
73
74 rindex = F90_DIM_LBOUND_G(result, 0);
75 vindex = F90_DIM_LBOUND_G(vector, 0);
76 for (i = F90_RANK_G(array); --i >= 0;) {
77 aindex[i] = F90_DIM_LBOUND_G(array, i);
78 }
79
80 if (ISSCALAR(mask)) {
81 mlen = GET_DIST_SIZE_OF(TYPEKIND(mask));
82 mval = I8(__fort_varying_log)(mb, &mlen);
83 if (!mval)
84 return;
85 mask_is_array = 0;
86 } else if (F90_TAG_G(mask) == __DESC) {
87 for (i = F90_RANK_G(mask); --i >= 0;)
88 mindex[i] = F90_DIM_LBOUND_G(mask, i);
89 mask_is_array = 1;
90 } else
91 __fort_abort("PACK: invalid mask descriptor");
92
93 more_array = more_vector = 1;
94 while (more_array & more_vector) {
95
96 /* get mask value */
97
98 if (mask_is_array) {
99 I8(__fort_get_scalar)(tmp, mb, mask, mindex);
100 switch (F90_KIND_G(mask)) {
101 case __LOG1:
102 mval = (*(__LOG1_T *)tmp & GET_DIST_MASK_LOG1) != 0;
103 break;
104 case __LOG2:
105 mval = (*(__LOG2_T *)tmp & GET_DIST_MASK_LOG2) != 0;
106 break;
107 case __LOG4:
108 mval = (*(__LOG4_T *)tmp & GET_DIST_MASK_LOG4) != 0;
109 break;
110 case __LOG8:
111 mval = (*(__LOG8_T *)tmp & GET_DIST_MASK_LOG8) != 0;
112 break;
113 case __INT1:
114 mval = (*(__INT1_T *)tmp & GET_DIST_MASK_INT1) != 0;
115 break;
116 case __INT2:
117 mval = (*(__INT2_T *)tmp & GET_DIST_MASK_INT2) != 0;
118 break;
119 case __INT4:
120 mval = (*(__INT4_T *)tmp & GET_DIST_MASK_INT4) != 0;
121 break;
122 case __INT8:
123 mval = (*(__INT8_T *)tmp & GET_DIST_MASK_INT8) != 0;
124 break;
125 default:
126 __fort_abort("PACK: unknown mask type");
127 }
128 more_array &= I8(next_index)(mindex, mask);
129 }
130
131 /* if mask is true, store the corresponding array element into
132 the next result element and also advance to the next vector
133 element. */
134
135 if (mval) {
136 la = I8(__fort_local_address)(rf, result, &rindex);
137 if (la == NULL)
138 la = (char *)tmp;
139 I8(__fort_get_scalar)(la, ab, array, aindex);
140 more_vector &= I8(next_index)(&rindex, result);
141 more_vector &= I8(next_index)(&vindex, vector);
142 }
143 more_array &= I8(next_index)(aindex, array);
144 }
145
146 /* if there are fewer masked elements than result elements, fill
147 the remainder of the result with the corresponding vector
148 elements. */
149
150 while (more_vector) {
151 la = I8(__fort_local_address)(rf, result, &rindex);
152 if (la == NULL)
153 la = (char *)tmp;
154 I8(__fort_get_scalar)(la, vf, vector, &vindex);
155 more_vector &= I8(next_index)(&rindex, result);
156 more_vector &= I8(next_index)(&vindex, vector);
157 }
158 }
159
ENTFTN(PACKCA,packca)160 void ENTFTN(PACKCA, packca)(DCHAR(rb), /* result char base */
161 DCHAR(ab), /* array char base */
162 void *mb, /* mask base */
163 DCHAR(vb), /* vector char base */
164 F90_Desc *result, /* result descriptor */
165 F90_Desc *array, /* array descriptor */
166 F90_Desc *mask, /* mask descriptor */
167 F90_Desc *vector /* vector descriptor */
168 DCLEN64(rb) /* result char len */
169 DCLEN64(ab) /* array char len */
170 DCLEN64(vb)) /* vector char len */
171 {
172 ENTFTN(PACK,pack)(CADR(rb), CADR(ab), mb, CADR(vb),
173 result, array, mask, vector);
174 }
175 /* 32 bit CLEN version */
ENTFTN(PACKC,packc)176 void ENTFTN(PACKC, packc)(DCHAR(rb), /* result char base */
177 DCHAR(ab), /* array char base */
178 void *mb, /* mask base */
179 DCHAR(vb), /* vector char base */
180 F90_Desc *result, /* result descriptor */
181 F90_Desc *array, /* array descriptor */
182 F90_Desc *mask, /* mask descriptor */
183 F90_Desc *vector /* vector descriptor */
184 DCLEN(rb) /* result char len */
185 DCLEN(ab) /* array char len */
186 DCLEN(vb)) /* vector char len */
187 {
188 ENTFTN(PACKCA, packca)(CADR(rb), CADR(ab), mb, CADR(vb), result, array, mask,
189 vector, (__CLEN_T)CLEN(rb), (__CLEN_T)CLEN(ab), (__CLEN_T)CLEN(vb));
190 }
191
192 /* pack, optional vector arg absent. pack masked elements of array
193 into result. */
194
ENTFTN(PACKZ,packz)195 void ENTFTN(PACKZ, packz)(void *rb, /* result base */
196 void *ab, /* array base */
197 void *mb, /* mask base */
198 F90_Desc *result, /* result descriptor */
199 F90_Desc *array, /* array descriptor */
200 F90_Desc *mask) /* mask descriptor */
201 {
202 char *la, *rf;
203 __INT_T rindex;
204 __INT_T aindex[MAXDIMS];
205 __INT_T mindex[MAXDIMS];
206 __BIGREAL_T tmp[4];
207 __INT_T mlen;
208 __INT_T i, mask_is_array, more, mval;
209
210 if (result == NULL || F90_TAG_G(result) != __DESC)
211 __fort_abort("PACK: invalid result descriptor");
212
213 if (F90_GSIZE_G(result) == 0)
214 return;
215
216 rf = (char *)rb + DIST_SCOFF_G(result) * F90_LEN_G(result);
217
218 rindex = F90_DIM_LBOUND_G(result, 0);
219
220 for (i = F90_RANK_G(array); --i >= 0;)
221 aindex[i] = F90_DIM_LBOUND_G(array, i);
222
223 if (ISSCALAR(mask)) {
224 mlen = GET_DIST_SIZE_OF(TYPEKIND(mask));
225 mval = I8(__fort_varying_log)(mb, &mlen);
226 if (!mval)
227 return;
228 mask_is_array = 0;
229 } else if (F90_TAG_G(mask) == __DESC) {
230 for (i = F90_RANK_G(mask); --i >= 0;)
231 mindex[i] = F90_DIM_LBOUND_G(mask, i);
232 mask_is_array = 1;
233 } else
234 __fort_abort("PACK: invalid mask descriptor");
235
236 more = 1;
237 while (more) {
238
239 /* get mask value */
240
241 if (mask_is_array) {
242 I8(__fort_get_scalar)(tmp, mb, mask, mindex);
243 switch (F90_KIND_G(mask)) {
244 case __LOG1:
245 mval = (*(__LOG1_T *)tmp & GET_DIST_MASK_LOG1) != 0;
246 break;
247 case __LOG2:
248 mval = (*(__LOG2_T *)tmp & GET_DIST_MASK_LOG2) != 0;
249 break;
250 case __LOG4:
251 mval = (*(__LOG4_T *)tmp & GET_DIST_MASK_LOG4) != 0;
252 break;
253 case __LOG8:
254 mval = (*(__LOG8_T *)tmp & GET_DIST_MASK_LOG8) != 0;
255 break;
256 case __INT1:
257 mval = (*(__INT1_T *)tmp & GET_DIST_MASK_INT1) != 0;
258 break;
259 case __INT2:
260 mval = (*(__INT2_T *)tmp & GET_DIST_MASK_INT2) != 0;
261 break;
262 case __INT4:
263 mval = (*(__INT4_T *)tmp & GET_DIST_MASK_INT4) != 0;
264 break;
265 case __INT8:
266 mval = (*(__INT8_T *)tmp & GET_DIST_MASK_INT8) != 0;
267 break;
268 default:
269 __fort_abort("PACK: unknown mask type");
270 }
271 more &= I8(next_index)(mindex, mask);
272 }
273
274 /* if mask is true, store the corresponding array element into
275 the next result element. */
276
277 if (mval) {
278 la = I8(__fort_local_address)(rf, result, &rindex);
279 if (la == NULL)
280 la = (char *)tmp;
281 I8(__fort_get_scalar)(la, ab, array, aindex);
282 more &= I8(next_index)(&rindex, result);
283 }
284 more &= I8(next_index)(aindex, array);
285 }
286 }
287
ENTFTN(PACKZCA,packzca)288 void ENTFTN(PACKZCA, packzca)(DCHAR(rb), /* result char base */
289 DCHAR(ab), /* array char base */
290 void *mb, /* mask base */
291 F90_Desc *result, /* result descriptor */
292 F90_Desc *array, /* array descriptor */
293 F90_Desc *mask, /* mask descriptor */
294 F90_Desc *vector /* vector descriptor */
295 DCLEN64(rb) /* result char len */
296 DCLEN64(ab)) /* array char len */
297 {
298 ENTFTN(PACKZ, packz)(CADR(rb), CADR(ab), mb, result, array, mask);
299 }
300 /* 32 bit CLEN version */
ENTFTN(PACKZC,packzc)301 void ENTFTN(PACKZC, packzc)(DCHAR(rb), /* result char base */
302 DCHAR(ab), /* array char base */
303 void *mb, /* mask base */
304 F90_Desc *result, /* result descriptor */
305 F90_Desc *array, /* array descriptor */
306 F90_Desc *mask, /* mask descriptor */
307 F90_Desc *vector /* vector descriptor */
308 DCLEN(rb) /* result char len */
309 DCLEN(ab)) /* array char len */
310 {
311 ENTFTN(PACKZCA, packzca)(CADR(rb), CADR(ab), mb, result, array, mask,
312 vector, (__CLEN_T)CLEN(rb), (__CLEN_T)CLEN(ab));
313 }
314
315 /* unpack */
316
ENTFTN(UNPACK,unpack)317 void ENTFTN(UNPACK, unpack)(void *rb, /* result base */
318 void *vb, /* vector base */
319 void *mb, /* mask base */
320 void *fb, /* field base */
321 F90_Desc *result, /* result descriptor */
322 F90_Desc *vector, /* vector descriptor */
323 F90_Desc *mask, /* mask descriptor */
324 F90_Desc *field) /* field descriptor */
325 {
326 char *la, *rf;
327 __INT_T rindex[MAXDIMS];
328 __INT_T vindex;
329 __INT_T findex[MAXDIMS];
330 __INT_T mindex[MAXDIMS];
331 __BIGREAL_T tmp[4];
332 __INT_T field_is_array, i, more, mval;
333
334 if (result == NULL || F90_TAG_G(result) != __DESC)
335 __fort_abort("UNPACK: invalid result descriptor");
336
337 if (F90_GSIZE_G(result) == 0 || F90_GSIZE_G(mask) == 0)
338 return;
339
340 rf = (char *)rb + DIST_SCOFF_G(result) * F90_LEN_G(result);
341
342 for (i = F90_RANK_G(result); --i >= 0;)
343 rindex[i] = F90_DIM_LBOUND_G(result, i);
344
345 if (mask == NULL || F90_TAG_G(mask) != __DESC)
346 __fort_abort("UNPACK: invalid mask descriptor");
347
348 for (i = F90_RANK_G(mask); --i >= 0;)
349 mindex[i] = F90_DIM_LBOUND_G(mask, i);
350
351 vindex = F90_DIM_LBOUND_G(vector, 0);
352
353 if (ISSCALAR(field)) {
354 field_is_array = 0;
355 } else if (F90_TAG_G(field) == __DESC) {
356 for (i = F90_RANK_G(field); --i >= 0;)
357 findex[i] = F90_DIM_LBOUND_G(field, i);
358 field_is_array = 1;
359 } else
360 __fort_abort("UNPACK: invalid field descriptor");
361
362 more = 1;
363 while (more) {
364
365 /* get mask value */
366
367 I8(__fort_get_scalar)(tmp, mb, mask, mindex);
368 switch (F90_KIND_G(mask)) {
369 case __LOG1:
370 mval = (*(__LOG1_T *)tmp & GET_DIST_MASK_LOG1) != 0;
371 break;
372 case __LOG2:
373 mval = (*(__LOG2_T *)tmp & GET_DIST_MASK_LOG2) != 0;
374 break;
375 case __LOG4:
376 mval = (*(__LOG4_T *)tmp & GET_DIST_MASK_LOG4) != 0;
377 break;
378 case __LOG8:
379 mval = (*(__LOG8_T *)tmp & GET_DIST_MASK_LOG8) != 0;
380 break;
381 case __INT1:
382 mval = (*(__INT1_T *)tmp & GET_DIST_MASK_INT1) != 0;
383 break;
384 case __INT2:
385 mval = (*(__INT2_T *)tmp & GET_DIST_MASK_INT2) != 0;
386 break;
387 case __INT4:
388 mval = (*(__INT4_T *)tmp & GET_DIST_MASK_INT4) != 0;
389 break;
390 case __INT8:
391 mval = (*(__INT8_T *)tmp & GET_DIST_MASK_INT8) != 0;
392 break;
393 default:
394 __fort_abort("UNPACK: unknown mask type");
395 }
396
397 /* if the mask is true, move the next vector element to the
398 result element corresponding to the mask. Otherwise, copy
399 the field element corresponding to the mask to the result
400 element. */
401
402 la = I8(__fort_local_address)(rf, result, rindex);
403 if (la == NULL)
404 la = (char *)tmp;
405 if (mval) {
406 I8(__fort_get_scalar)(la, vb, vector, &vindex);
407 I8(next_index)(&vindex, vector);
408 } else if (field_is_array)
409 I8(__fort_get_scalar)(la, fb, field, findex);
410 else
411 __fort_scalar_copy[F90_KIND_G(result)](la, fb, F90_LEN_G(result));
412
413 more &= I8(next_index)(rindex, result);
414 more &= I8(next_index)(mindex, mask);
415 if (field_is_array)
416 more &= I8(next_index)(findex, field);
417 }
418 }
419
ENTFTN(UNPACKCA,unpackca)420 void ENTFTN(UNPACKCA, unpackca)(DCHAR(rb), /* result char base */
421 DCHAR(vb), /* vector char base */
422 void *mb, /* mask base */
423 DCHAR(fb), /* field char base */
424 F90_Desc *result, /* result descriptor */
425 F90_Desc *vector, /* vector descriptor */
426 F90_Desc *mask, /* mask descriptor */
427 F90_Desc *field /* field descriptor */
428 DCLEN64(rb) /* result char len */
429 DCLEN64(vb) /* vector char len */
430 DCLEN64(fb)) /* field char len */
431 {
432 ENTFTN(UNPACK,unpack)(CADR(rb), CADR(vb), mb, CADR(fb),
433 result, vector, mask, field);
434 }
435 /* 32 bit CLEN version */
ENTFTN(UNPACKC,unpackc)436 void ENTFTN(UNPACKC, unpackc)(DCHAR(rb), /* result char base */
437 DCHAR(vb), /* vector char base */
438 void *mb, /* mask base */
439 DCHAR(fb), /* field char base */
440 F90_Desc *result, /* result descriptor */
441 F90_Desc *vector, /* vector descriptor */
442 F90_Desc *mask, /* mask descriptor */
443 F90_Desc *field /* field descriptor */
444 DCLEN(rb) /* result char len */
445 DCLEN(vb) /* vector char len */
446 DCLEN(fb)) /* field char len */
447 {
448 ENTFTN(UNPACKC, unpackc)(CADR(rb), CADR(vb), mb, CADR(fb), result, vector,
449 mask, field, (__CLEN_T)CLEN(rb), (__CLEN_T)CLEN(vb), (__CLEN_T)CLEN(fb));
450 }
451