1 /*
2 * Copyright (c) 1993-2019, 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 /** \file
19 * \brief Fortran-specific expander routines
20 */
21
22 #include "exp_ftn.h"
23 #include "exputil.h"
24 #include "exp_rte.h"
25 #include "expreg.h"
26 #include "expatomics.h"
27 #include "dtypeutl.h"
28 #include "regutil.h"
29 #include "machreg.h"
30 #include "ilm.h"
31 #include "fih.h"
32 #include "ilmtp.h"
33 #include "ili.h"
34 #define EXPANDER_DECLARE_INTERNAL
35 #include "expand.h"
36 #include "machar.h"
37 #include "llassem.h"
38 #define RTE_C
39 #include "rte.h"
40 #undef RTE_C
41 #include "x86.h"
42 #include "pragma.h"
43 #include "rtlRtns.h"
44 #include "upper.h"
45 #include "mth.h"
46 #if DEBUG
47 #include "mwd.h"
48 #endif
49 #include "ccffinfo.h"
50 #include "symfun.h"
51
52 #ifdef __cplusplus
53 /* clang-format off */
GetAD_ZBASE(ADSC * p)54 inline SPTR GetAD_ZBASE(ADSC *p) {
55 return static_cast<SPTR>(AD_ZBASE(p));
56 }
57 #undef AD_ZBASE
58 #define AD_ZBASE GetAD_ZBASE
Get_expb_logcjmp()59 inline ILI_OP Get_expb_logcjmp() {
60 return static_cast<ILI_OP>(expb.logcjmp);
61 }
62 /* clang-format on */
63 #else
64 #define Get_expb_logcjmp() expb.logcjmp
65 #endif
66
67 static void begin_entry(SPTR); /* interface to exp_header */
68 static void store_aret(int);
69
70 static void create_array_subscr(int nmex, SPTR sym, DTYPE dtype, int nsubs,
71 int *subs, int ilix);
72 static int add_ptr_subscript(int, int, int, int, int, int, ADSC *, int, int);
73
74 /* ----- */
75
76 static int vf_addr; /* addr of temp environ for var.fmt. funcs */
77 static int entry_sptr; /* entry (primary or secondary) sptr processed
78 * by begin_entry() -- IM_ENLAB needs the
79 * sptr.
80 */
81 static int arglist = 0;
82 static int accreduct_op;
83
84 #define mk_prototype mk_prototype_llvm
85
86 bool ishft = false;
87
88 static int
forceK(int ili)89 forceK(int ili)
90 {
91 int ilix;
92
93 ilix = ili;
94 if (XBIT(124, 0x400)) {
95 ilix = ikmove(ilix);
96 }
97 return ilix;
98 }
99
100 static int
double_is_small_int(int ilix)101 double_is_small_int(int ilix)
102 {
103 int sptr;
104 int i;
105 double d;
106 INT con[2];
107 int ret_ili = 0; /* false */
108
109 assert(ILI_OPC(ilix) == IL_DCON, "double_is_small_int expects dcon", ilix,
110 ERR_Severe);
111
112 sptr = ILI_OPND(ilix, 1);
113 if (sptr == stb.dbl2) {
114 ret_ili = ad_icon(2);
115 } else {
116 /* probably a better way to do this */
117 for (i = 3; i < 7; i++) {
118 d = (double)i;
119 xmdtod(d, con);
120 if (con[0] == CONVAL1G(sptr) && con[1] == CONVAL2G(sptr)) {
121 ret_ili = ad_icon(i);
122 break;
123 }
124 }
125 }
126 return ret_ili;
127 }
128
129 /**
130 * \brief check special case for ISHFT(int8)
131 */
132 static bool
is_ishft(int curilm)133 is_ishft(int curilm)
134 {
135 ILM *ilmp;
136 ILM_OP opc;
137 int len, bsize, ilmx;
138 len = 0;
139 bsize = ilmb.ilm_base[BOS_SIZE - 1];
140 ilmx = 0;
141 do {
142 ilmx += len;
143 ilmp = (ILM *)(ilmb.ilm_base + curilm + ilmx);
144 opc = ILM_OPC(ilmp);
145 len = ilms[opc].oprs + 1;
146 if (IM_VAR(opc))
147 len += ILM_OPND(ilmp, 1);
148 if (opc == IM_JISHFT && (ILM_OPND(ilmp, 1) == curilm)) {
149 return true;
150 }
151 } while (curilm + ilmx + len < bsize);
152 return false;
153 }
154
155 void
exp_ac(ILM_OP opc,ILM * ilmp,int curilm)156 exp_ac(ILM_OP opc, ILM *ilmp, int curilm)
157 {
158 ILI_OP opcx;
159 ILM *ilmpx;
160 int ilmx;
161 int tmp;
162 int nme;
163 SPTR nmsym;
164 INT val[2];
165 int ilix, ilixi, ilixr;
166 int op1, op2, op3;
167 /*
168 * the ILMs here are special cased so we can perform some special
169 * transformations, modify the calling sequence, or pass back
170 * a names entry.
171 */
172 nme = 0;
173 switch (opc) {
174 default:
175 interr("exp_ac:ilm not cased", opc, ERR_Severe);
176 return;
177 case IM_LNOT:
178 op1 = ILI_OF(ILM_OPND(ilmp, 1));
179 if (XBIT(125, 0x8))
180 ilix = ad2ili(IL_XOR, op1, ad_icon(1)); /* 1 => true */
181 else
182 ilix = ad1ili(IL_NOT, op1); /* -1 => true */
183 ILM_RESULT(curilm) = ilix;
184 return;
185 case IM_LEQV:
186 op1 = ILI_OF(ILM_OPND(ilmp, 1));
187 op2 = ILI_OF(ILM_OPND(ilmp, 2));
188 if (XBIT(125, 0x8))
189 /* -Munixlogical */
190 ilix = ad3ili(IL_ICMP, op1, op2, CC_EQ);
191 else {
192 ilix = ad2ili(IL_LEQV, op1, op2);
193 }
194 ILM_RESULT(curilm) = ilix;
195 return;
196 case IM_LNOT8:
197 op1 = ILI_OF(ILM_OPND(ilmp, 1));
198 if (XBIT(124, 0x400)) {
199 if (XBIT(125, 0x8)) {
200 val[0] = 0;
201 val[1] = 1;
202 ilix = ad1ili(IL_KCON, getcon(val, DT_INT8));
203 ilix = ad2ili(IL_KXOR, op1, ilix); /* 1 => true */
204 } else
205 ilix = ad1ili(IL_KNOT, op1); /* -1 => true */
206 } else if (XBIT(125, 0x8))
207 ilix = ad2ili(IL_XOR, op1, ad_icon(1)); /* 1 => true */
208 else
209 ilix = ad1ili(IL_NOT, op1); /* -1 => true */
210 ILM_RESULT(curilm) = ilix;
211 return;
212 case IM_LNOP8:
213 ilix = ILI_OF(ILM_OPND(ilmp, 1));
214 /* next line is never used, so I have commented it out */
215 /* tmp = ad2ili(IL_MVKR, op1, KR_RETVAL); */
216 /* fix tpr 1510. If the LNOP8 points to a nonK result,
217 * need to insert an IKMV.
218 */
219 ILM_RESULT(curilm) = forceK(ilix);
220 return;
221 case IM_KADD:
222 op1 = ILI_OF(ILM_OPND(ilmp, 1));
223 op2 = ILI_OF(ILM_OPND(ilmp, 2));
224 if (XBIT(124, 0x400))
225 ilix = ad2ili(IL_KADD, op1, op2);
226 else {
227 op1 = kimove(op1);
228 op2 = kimove(op2);
229 ilix = ad2ili(IL_IADD, op1, op2);
230 }
231 ILM_RESULT(curilm) = ilix;
232 return;
233 case IM_KSUB:
234 op1 = ILI_OF(ILM_OPND(ilmp, 1));
235 op2 = ILI_OF(ILM_OPND(ilmp, 2));
236 if (XBIT(124, 0x400))
237 ilix = ad2ili(IL_KSUB, op1, op2);
238 else {
239 op1 = kimove(op1);
240 op2 = kimove(op2);
241 ilix = ad2ili(IL_ISUB, op1, op2);
242 }
243 ILM_RESULT(curilm) = ilix;
244 return;
245 case IM_KMUL:
246 op1 = ILI_OF(ILM_OPND(ilmp, 1));
247 op2 = ILI_OF(ILM_OPND(ilmp, 2));
248 if (XBIT(124, 0x400))
249 ilix = ad2ili(IL_KMUL, op1, op2);
250 else {
251 op1 = kimove(op1);
252 op2 = kimove(op2);
253 ilix = ad2ili(IL_IMUL, op1, op2);
254 }
255 ILM_RESULT(curilm) = ilix;
256 return;
257 case IM_KDIV:
258 op1 = ILI_OF(ILM_OPND(ilmp, 1));
259 op2 = ILI_OF(ILM_OPND(ilmp, 2));
260 if (XBIT(124, 0x400))
261 ilix = ad2ili(IL_KDIV, op1, op2);
262 else {
263 op1 = kimove(op1);
264 op2 = kimove(op2);
265 ilix = ad2ili(IL_IDIV, op1, op2);
266 }
267 ILM_RESULT(curilm) = ilix;
268 return;
269 case IM_KPOPCNT:
270 op1 = ILI_OF(ILM_OPND(ilmp, 1));
271 if (XBIT(124, 0x400))
272 ilix = ad1ili(IL_KPOPCNT, op1);
273 else {
274 op1 = kimove(op1);
275 ilix = ad1ili(IL_IPOPCNT, op1);
276 }
277 ILM_RESULT(curilm) = ilix;
278 return;
279 case IM_KLEADZ:
280 op1 = ILI_OF(ILM_OPND(ilmp, 1));
281 if (XBIT(124, 0x400))
282 ilix = ad1ili(IL_KLEADZ, op1);
283 else {
284 op1 = kimove(op1);
285 ilix = ad1ili(IL_ILEADZ, op1);
286 }
287 ILM_RESULT(curilm) = ilix;
288 return;
289 case IM_KPOPPAR:
290 op1 = ILI_OF(ILM_OPND(ilmp, 1));
291 if (XBIT(124, 0x400))
292 ilix = ad1ili(IL_KPOPPAR, op1);
293 else {
294 op1 = kimove(op1);
295 ilix = ad1ili(IL_IPOPPAR, op1);
296 }
297 ILM_RESULT(curilm) = ilix;
298 return;
299 case IM_RDIV:
300 tmp = exp_mac(IM_RDIV, ilmp, curilm);
301 return;
302 case IM_DDIV:
303 tmp = exp_mac(IM_DDIV, ilmp, curilm);
304 return;
305
306 case IM_REAL:
307 if (XBIT(70, 0x40000000)) {
308 op1 = ILI_OF(ILM_OPND(ilmp, 1));
309 ilix = ad1ili(IL_SCMPLX2REAL, op1);
310 ILM_RESULT(curilm) = ilix;
311 return;
312 }
313 tmp = exp_mac(opc, ilmp, curilm);
314 return;
315 case IM_IMAG:
316 if (XBIT(70, 0x40000000)) {
317 op1 = ILI_OF(ILM_OPND(ilmp, 1));
318 ilix = ad1ili(IL_SCMPLX2IMAG, op1);
319 ILM_RESULT(curilm) = ilix;
320 return;
321 }
322 tmp = exp_mac(opc, ilmp, curilm);
323 return;
324 case IM_DREAL:
325 if (XBIT(70, 0x40000000)) {
326 op1 = ILI_OF(ILM_OPND(ilmp, 1));
327 ilix = ad1ili(IL_DCMPLX2REAL, op1);
328 ILM_RESULT(curilm) = ilix;
329 return;
330 }
331 tmp = exp_mac(opc, ilmp, curilm);
332 return;
333 case IM_DIMAG:
334 if (XBIT(70, 0x40000000)) {
335 op1 = ILI_OF(ILM_OPND(ilmp, 1));
336 ilix = ad1ili(IL_DCMPLX2IMAG, op1);
337 ILM_RESULT(curilm) = ilix;
338 return;
339 }
340 tmp = exp_mac(opc, ilmp, curilm);
341 return;
342 case IM_CMPLX:
343 ilixr = ILI_OF(ILM_OPND(ilmp, 1)); /* real part */
344 ilixi = ILI_OF(ILM_OPND(ilmp, 2)); /* imag part */
345 /***********************************************************
346 * scn (03 Oct 2014): -0.0 is not considered to be 0.0 here
347 * and below
348 ***********************************************************/
349 if (XBIT(70, 0x40000000)) {
350 if (ILI_OPC(ilixi) == IL_FCON && ILI_OPND(ilixi, 1) == stb.flt0)
351 ilix = ad1ili(IL_SPSP2SCMPLXI0, ilixr);
352 else
353 ilix = ad2ili(IL_SPSP2SCMPLX, ilixr, ilixi);
354 ILM_RESULT(curilm) = ilix;
355 } else {
356 ILM_RRESULT(curilm) = ilixr;
357 ILM_IRESULT(curilm) = ilixi;
358 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
359 }
360 return;
361 case IM_DCMPLX:
362 ilixr = ILI_OF(ILM_OPND(ilmp, 1)); /* real part */
363 ilixi = ILI_OF(ILM_OPND(ilmp, 2)); /* imag part */
364 if (XBIT(70, 0x40000000)) {
365 if (ILI_OPC(ilixi) == IL_DCON && ILI_OPND(ilixi, 1) == stb.dbl0)
366 ilix = ad1ili(IL_DPDP2DCMPLXI0, ilixr);
367 else
368 ilix = ad2ili(IL_DPDP2DCMPLX, ilixr, ilixi);
369 ILM_RESULT(curilm) = ilix;
370 } else {
371 ILM_RRESULT(curilm) = ilixr;
372 ILM_IRESULT(curilm) = ilixi;
373 ILM_RESTYPE(curilm) = ILM_ISDCMPLX;
374 }
375 return;
376 case IM_ITOSC:
377 val[1] = size_of(DT_BINT);
378 goto sconv_shared;
379 case IM_ITOS:
380 val[1] = size_of(DT_SINT);
381 sconv_shared:
382 op1 = ILI_OF(ILM_OPND(ilmp, 1)); /* ili to be converted */
383 /*
384 * if truncation is requested when narrowing to a smaller signed type,
385 * generate "code" to left shift, then arithmetically right shift (addili
386 * will take care of constants). another condition to handle is a constant
387 * operand of an intrinsic (earlier processing does not catch this case -
388 * tpr555)
389 */
390 if (XBIT(124, 1) || (ILI_OPC(op1) == IL_ICON)) {
391 val[1] = size_of(DT_INT) - val[1]; /* difference in bytes */
392 val[1] <<= 3; /* difference in bits */
393 op2 = ad_icon(val[1]);
394 tmp = ad2ili(IL_LSHIFT, op1, op2);
395 if (is_ishft(curilm)) {
396 /* Special case for ishft(int8) */
397 ishft = true;
398 op1 = ad2ili(IL_URSHIFT, tmp, op2);
399 ishft = false;
400 } else {
401 op1 = ad2ili(IL_ARSHIFT, tmp, op2);
402 }
403 }
404 ILM_RESULT(curilm) = op1;
405 return;
406
407 /* complex arithmetics/intinsics */
408 case IM_CABS:
409 if (XBIT(70, 0x40000000)) {
410 int r = ILM_RESULT(ILM_OPND(ilmp, 1));
411 op1 = ad1ili(IL_DBLE, ad1ili(IL_SCMPLX2IMAG, r));
412 op2 = ad1ili(IL_DBLE, ad1ili(IL_SCMPLX2REAL, r));
413 op1 = ad2ili(IL_DMUL, op1, op1);
414 op2 = ad2ili(IL_DMUL, op2, op2);
415 tmp = ad2ili(IL_DADD, op1, op2);
416 tmp = ad1ili(IL_DSQRT, tmp);
417 tmp = ad1ili(IL_SNGL, tmp);
418 ILM_RESULT(curilm) = tmp;
419 } else
420 tmp = exp_mac(IM_CABS, ilmp, curilm);
421 return;
422 case IM_CDABS:
423 if (XBIT(70, 0x40000000)) {
424 int r = ILM_RESULT(ILM_OPND(ilmp, 1));
425 op1 = ad1ili(IL_DCMPLX2IMAG, r);
426 op2 = ad1ili(IL_DCMPLX2REAL, r);
427 tmp = ad1ili(IL_NULL, 0);
428 tmp = ad3ili(IL_DADP, op1, DP(0), tmp);
429 tmp = ad3ili(IL_DADP, op2, DP(1), tmp);
430 op3 = mk_prototype("__mth_i_cdabs", "pure", DT_DBLE, 2, DT_DBLE, DT_DBLE);
431 tmp = ad2ili(IL_QJSR, op3, tmp);
432 ILM_RESULT(curilm) = ad2ili(IL_DFRDP, tmp, DP_RETVAL);
433 } else
434 tmp = exp_mac(IM_CDABS, ilmp, curilm);
435 return;
436 /*
437 * For the old calling sequence, all arithmetic/intrinsic QJSRs which
438 * return complex are turned into regular complex function calls where the
439 * result of the function is returned via a pointer passed as an extra arg.
440 *
441 * Currently, the C ABI for complex is only used for native -- enabling for
442 * LLVM targets will occur when the new complex ILI is fully supported.
443 */
444 case IM_CTOI:
445 if (XBIT(70, 0x40000000) && XBIT_NEW_MATH_NAMES_CMPLX) {
446 op1 = ILI_OF(ILM_OPND(ilmp, 1));
447 op2 = ILI_OF(ILM_OPND(ilmp, 2));
448 ilix = ad2ili(IL_SCMPLXPOWI, op1, op2);
449 ILM_RESULT(curilm) = ilix;
450 return;
451 }
452 exp_qjsr("__mth_i_cpowi", DT_CMPLX, ilmp, curilm);
453 return;
454 case IM_CDTOI:
455 if (XBIT(70, 0x40000000) && XBIT_NEW_MATH_NAMES_CMPLX) {
456 op1 = ILI_OF(ILM_OPND(ilmp, 1));
457 op2 = ILI_OF(ILM_OPND(ilmp, 2));
458 ilix = ad2ili(IL_DCMPLXPOWI, op1, op2);
459 ILM_RESULT(curilm) = ilix;
460 return;
461 }
462 exp_qjsr("__mth_i_cdpowi", DT_DCMPLX, ilmp, curilm);
463 return;
464 case IM_CTOC:
465 if (XBIT(70, 0x40000000) && XBIT_NEW_MATH_NAMES_CMPLX) {
466 op1 = ILI_OF(ILM_OPND(ilmp, 1));
467 op2 = ILI_OF(ILM_OPND(ilmp, 2));
468 ilix = ad2ili(IL_SCMPLXPOW, op1, op2);
469 ILM_RESULT(curilm) = ilix;
470 return;
471 }
472 exp_qjsr("__mth_i_cpowc", DT_CMPLX, ilmp, curilm);
473 return;
474 case IM_CDTOCD:
475 if (XBIT(70, 0x40000000) && XBIT_NEW_MATH_NAMES_CMPLX) {
476 op1 = ILI_OF(ILM_OPND(ilmp, 1));
477 op2 = ILI_OF(ILM_OPND(ilmp, 2));
478 ilix = ad2ili(IL_DCMPLXPOW, op1, op2);
479 ILM_RESULT(curilm) = ilix;
480 return;
481 }
482 exp_qjsr("__mth_i_cdpowcd", DT_DCMPLX, ilmp, curilm);
483 return;
484 case IM_CSQRT:
485 exp_qjsr("__mth_i_csqrt", DT_CMPLX, ilmp, curilm);
486 return;
487 case IM_CDSQRT:
488 exp_qjsr("__mth_i_cdsqrt", DT_DCMPLX, ilmp, curilm);
489 return;
490 case IM_CEXP:
491 /*
492 * exp(cmplx(0.0, a)) -> cmplx(cos(a), sin(a))
493 */
494 ilixr = ILM_RESULT(ILM_OPND(ilmp, 1)); /* real part */
495 if (ILI_OPC(ilixr) == IL_FCON && is_flt0(ILI_SymOPND(ilixr, 1))) {
496 ilixi = ILM_IRESULT(ILM_OPND(ilmp, 1)); /* imag part */
497 ilixr = ad1ili(IL_FCOS, ilixi);
498 ilixi = ad1ili(IL_FSIN, ilixi);
499 ILM_RRESULT(curilm) = ilixr;
500 ILM_IRESULT(curilm) = ilixi;
501 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
502 return;
503 } else if (XBIT(70, 0x40000000)) {
504 if (ILI_OPC(ilixr) == IL_SCMPLXCON) {
505 SPTR tmps = ILI_SymOPND(ilixr, 1);
506 tmp = tmps;
507 if (is_creal_flt0(tmps)) {
508 val[0] = 0;
509 val[1] = CONVAL2G(tmps);
510 ilixi = ad1ili(IL_FCON, getcon(val, DT_FLOAT));
511 ilixr = ad1ili(IL_FCOS, ilixi);
512 ilixi = ad1ili(IL_FSIN, ilixi);
513 ilix = ad2ili(IL_SPSP2SCMPLX, ilixr, ilixi);
514 ILM_RESULT(curilm) = ilix;
515 return;
516 }
517 } else if (ILI_OPC(ilixr) == IL_SPSP2SCMPLX) {
518 ilixi = ILI_OPND(ilixr, 2);
519 ilixr = ILI_OPND(ilixr, 1);
520 if (ILI_OPC(ilixr) == IL_FCON && is_flt0((SPTR)ILI_OPND(ilixr, 1))) {
521 ilixr = ad1ili(IL_FCOS, ilixi);
522 ilixi = ad1ili(IL_FSIN, ilixi);
523 ilix = ad2ili(IL_SPSP2SCMPLX, ilixr, ilixi);
524 ILM_RESULT(curilm) = ilix;
525 return;
526 }
527 }
528 }
529 exp_qjsr("__mth_i_cexp", DT_CMPLX, ilmp, curilm);
530 return;
531 case IM_CDEXP:
532 /*
533 * exp(cmplx(0.0, a)) -> cmplx(cos(a), sin(a))
534 */
535 ilixr = ILM_RESULT(ILM_OPND(ilmp, 1)); /* real part */
536 if (ILI_OPC(ilixr) == IL_DCON &&
537 is_dbl0(ILI_SymOPND(ilixr, 1))) {
538 ilixi = ILM_IRESULT(ILM_OPND(ilmp, 1)); /* imag part */
539 ilixr = ad1ili(IL_DCOS, ilixi);
540 ilixi = ad1ili(IL_DSIN, ilixi);
541 ILM_RRESULT(curilm) = ilixr;
542 ILM_IRESULT(curilm) = ilixi;
543 ILM_RESTYPE(curilm) = ILM_ISDCMPLX;
544 return;
545 } else if (XBIT(70, 0x40000000)) {
546 if (ILI_OPC(ilixr) == IL_DCMPLXCON) {
547 SPTR stmp = ILI_SymOPND(ilixr, 1);
548 tmp = stmp;
549 if (is_dbl0(SymConval1(stmp))) {
550 ilixi = ad1ili(IL_DCON, CONVAL2G(stmp));
551 ilixr = ad1ili(IL_DCOS, ilixi);
552 ilixi = ad1ili(IL_DSIN, ilixi);
553 ilix = ad2ili(IL_DPDP2DCMPLX, ilixr, ilixi);
554 ILM_RESULT(curilm) = ilix;
555 return;
556 }
557 } else if (ILI_OPC(ilixr) == IL_DPDP2DCMPLX) {
558 ilixi = ILI_OPND(ilixr, 2);
559 ilixr = ILI_OPND(ilixr, 1);
560 if (ILI_OPC(ilixr) == IL_DCON &&
561 is_dbl0(ILI_SymOPND(ilixr, 1))) {
562 ilixr = ad1ili(IL_DCOS, ilixi);
563 ilixi = ad1ili(IL_DSIN, ilixi);
564 ilix = ad2ili(IL_DPDP2DCMPLX, ilixr, ilixi);
565 ILM_RESULT(curilm) = ilix;
566 return;
567 }
568 }
569 }
570 #if defined(TARGET_X8664)
571 exp_qjsr(relaxed_math("exp", 's', 'z', "__mth_i_cdexp"), DT_DCMPLX, ilmp,
572 curilm);
573 #else
574 exp_qjsr("__mth_i_cdexp", DT_DCMPLX, ilmp, curilm);
575 #endif
576 return;
577 case IM_CLOG:
578 exp_qjsr("__mth_i_clog", DT_CMPLX, ilmp, curilm);
579 return;
580 case IM_CDLOG:
581 exp_qjsr("__mth_i_cdlog", DT_DCMPLX, ilmp, curilm);
582 return;
583 case IM_CSIN:
584 exp_qjsr("__mth_i_csin", DT_CMPLX, ilmp, curilm);
585 return;
586 case IM_CDSIN:
587 exp_qjsr("__mth_i_cdsin", DT_DCMPLX, ilmp, curilm);
588 return;
589 case IM_CCOS:
590 exp_qjsr("__mth_i_ccos", DT_CMPLX, ilmp, curilm);
591 return;
592 case IM_CDCOS:
593 exp_qjsr("__mth_i_cdcos", DT_DCMPLX, ilmp, curilm);
594 return;
595 case IM_CASIN:
596 exp_qjsr("__mth_i_casin", DT_CMPLX, ilmp, curilm);
597 return;
598 case IM_CDASIN:
599 exp_qjsr("__mth_i_cdasin", DT_DCMPLX, ilmp, curilm);
600 return;
601 case IM_CACOS:
602 exp_qjsr("__mth_i_cacos", DT_CMPLX, ilmp, curilm);
603 return;
604 case IM_CDACOS:
605 exp_qjsr("__mth_i_cdacos", DT_DCMPLX, ilmp, curilm);
606 return;
607 case IM_CATAN:
608 exp_qjsr("__mth_i_catan", DT_CMPLX, ilmp, curilm);
609 return;
610 case IM_CDATAN:
611 exp_qjsr("__mth_i_cdatan", DT_DCMPLX, ilmp, curilm);
612 return;
613 case IM_CCOSH:
614 exp_qjsr("__mth_i_ccosh", DT_CMPLX, ilmp, curilm);
615 return;
616 case IM_CDCOSH:
617 exp_qjsr("__mth_i_cdcosh", DT_DCMPLX, ilmp, curilm);
618 return;
619 case IM_CSINH:
620 exp_qjsr("__mth_i_csinh", DT_CMPLX, ilmp, curilm);
621 return;
622 case IM_CDSINH:
623 exp_qjsr("__mth_i_cdsinh", DT_DCMPLX, ilmp, curilm);
624 return;
625 case IM_CTANH:
626 exp_qjsr("__mth_i_ctanh", DT_CMPLX, ilmp, curilm);
627 return;
628 case IM_CDTANH:
629 exp_qjsr("__mth_i_cdtanh", DT_DCMPLX, ilmp, curilm);
630 return;
631 case IM_CTAN:
632 exp_qjsr("__mth_i_ctan", DT_CMPLX, ilmp, curilm);
633 return;
634 case IM_CDTAN:
635 exp_qjsr("__mth_i_cdtan", DT_DCMPLX, ilmp, curilm);
636 return;
637 case IM_CDIV:
638 {
639 if (XBIT(70, 0x40000000)) {
640 exp_qjsr("__mth_i_cdiv", DT_CMPLX, ilmp, curilm);
641 return;
642 } else {
643 tmp = ILM_OPND(ilmp, 2);
644 ilix = ILM_IRESULT(tmp);
645 if (!flg.ieee && !XBIT(70, 0x40000000) && (ILI_OPC(ilix) == IL_FCON) &&
646 is_flt0(ILI_SymOPND(ilix, 1)) && (ILM_RRESULT(tmp) != ilix)) {
647 SetILM_OPC(ilmp, IM_CDIVR);
648 ILM_RESULT(tmp) = ILM_RRESULT(tmp);
649 ILM_RESTYPE(tmp) = 0; /* real result */
650 tmp = exp_mac(ILM_OPC(ilmp), ilmp, curilm);
651 return;
652 }
653 exp_qjsr("__mth_i_cdiv", DT_CMPLX, ilmp, curilm);
654 }
655 }
656 return;
657 case IM_CDDIV:
658 {
659 if (XBIT(70, 0x40000000)) {
660 exp_qjsr("__mth_i_cddiv", DT_DCMPLX, ilmp, curilm);
661 return;
662 } else {
663 tmp = ILM_OPND(ilmp, 2);
664 ilix = ILM_IRESULT(tmp);
665 if (!flg.ieee && !XBIT(70, 0x40000000) && ILI_OPC(ilix) == IL_DCON &&
666 is_dbl0(ILI_SymOPND(ilix, 1)) && (ILM_RRESULT(tmp) != ilix)) {
667 SetILM_OPC(ilmp, IM_CDDIVD);
668 ILM_RESULT(tmp) = ILM_RRESULT(tmp);
669 ILM_RESTYPE(tmp) = 0; /* double result */
670 tmp = exp_mac(ILM_OPC(ilmp), ilmp, curilm);
671 return;
672 }
673 exp_qjsr("__mth_i_cddiv", DT_DCMPLX, ilmp, curilm);
674 }
675 }
676 return;
677 case IM_CADD:
678 if (XBIT(70, 0x40000000)) {
679 op1 = ILI_OF(ILM_OPND(ilmp, 1));
680 op2 = ILI_OF(ILM_OPND(ilmp, 2));
681 ilix = ad2ili(IL_SCMPLXADD, op1, op2);
682 ILM_RESULT(curilm) = ilix;
683 } else {
684 tmp = exp_mac(IM_CADD, ilmp, curilm);
685 }
686 return;
687 case IM_CDADD:
688 if (XBIT(70, 0x40000000)) {
689 op1 = ILI_OF(ILM_OPND(ilmp, 1));
690 op2 = ILI_OF(ILM_OPND(ilmp, 2));
691 ilix = ad2ili(IL_DCMPLXADD, op1, op2);
692 ILM_RESULT(curilm) = ilix;
693 } else {
694 tmp = exp_mac(IM_CDADD, ilmp, curilm);
695 }
696 return;
697 case IM_CSUB:
698 if (XBIT(70, 0x40000000)) {
699 op1 = ILI_OF(ILM_OPND(ilmp, 1));
700 op2 = ILI_OF(ILM_OPND(ilmp, 2));
701 ilix = ad2ili(IL_SCMPLXSUB, op1, op2);
702 ILM_RESULT(curilm) = ilix;
703 } else {
704 tmp = exp_mac(IM_CSUB, ilmp, curilm);
705 }
706 return;
707 case IM_CDSUB:
708 if (XBIT(70, 0x40000000)) {
709 op1 = ILI_OF(ILM_OPND(ilmp, 1));
710 op2 = ILI_OF(ILM_OPND(ilmp, 2));
711 ilix = ad2ili(IL_DCMPLXSUB, op1, op2);
712 ILM_RESULT(curilm) = ilix;
713 } else {
714 tmp = exp_mac(IM_CDSUB, ilmp, curilm);
715 }
716 return;
717 case IM_CMUL:
718 if (XBIT(70, 0x40000000)) {
719 op1 = ILI_OF(ILM_OPND(ilmp, 1));
720 op2 = ILI_OF(ILM_OPND(ilmp, 2));
721 ilix = ad2ili(IL_SCMPLXMUL, op1, op2);
722 ILM_RESULT(curilm) = ilix;
723 } else {
724 tmp = exp_mac(IM_CMUL, ilmp, curilm);
725 }
726 return;
727 case IM_CDMUL:
728 if (XBIT(70, 0x40000000)) {
729 op1 = ILI_OF(ILM_OPND(ilmp, 1));
730 op2 = ILI_OF(ILM_OPND(ilmp, 2));
731 ilix = ad2ili(IL_DCMPLXMUL, op1, op2);
732 ILM_RESULT(curilm) = ilix;
733 } else {
734 tmp = exp_mac(IM_CDMUL, ilmp, curilm);
735 }
736 return;
737 case IM_CNEG:
738 if (XBIT(70, 0x40000000)) {
739 op1 = ILI_OF(ILM_OPND(ilmp, 1));
740 op2 = ILI_OF(ILM_OPND(ilmp, 2));
741 ilix = ad1ili(IL_SCMPLXNEG, op1);
742 ILM_RESULT(curilm) = ilix;
743 } else {
744 tmp = exp_mac(opc, ilmp, curilm);
745 }
746 return;
747 case IM_CDNEG:
748 if (XBIT(70, 0x40000000)) {
749 op1 = ILI_OF(ILM_OPND(ilmp, 1));
750 op2 = ILI_OF(ILM_OPND(ilmp, 2));
751 ilix = ad1ili(IL_DCMPLXNEG, op1);
752 ILM_RESULT(curilm) = ilix;
753 } else {
754 tmp = exp_mac(opc, ilmp, curilm);
755 }
756 return;
757 case IM_CONJG:
758 if (XBIT(70, 0x40000000)) {
759 /* convert to xorps signbit*/
760 op1 = ILI_OF(ILM_OPND(ilmp, 1));
761 ilix = ad1ili(IL_SCMPLXCONJG, op1);
762 ILM_RESULT(curilm) = ilix;
763 } else {
764 tmp = exp_mac(opc, ilmp, curilm);
765 }
766 return;
767 case IM_DCONJG:
768 if (XBIT(70, 0x40000000)) {
769 op1 = ILI_OF(ILM_OPND(ilmp, 1));
770 ilix = ad1ili(IL_DCMPLXCONJG, op1);
771 ILM_RESULT(curilm) = ilix;
772 } else {
773 tmp = exp_mac(opc, ilmp, curilm);
774 }
775 return;
776
777 /* special handling of 64 bit precision integer ilms */
778 /* -- type -- arithmetic */
779
780 case IM_KNEG:
781 op1 = ILI_OF(ILM_OPND(ilmp, 1));
782 ILM_RESULT(curilm) = ad1ili(IL_KNEG, op1);
783 return;
784 case IM_KABS:
785 op1 = ILI_OF(ILM_OPND(ilmp, 1));
786 tmp = ad1ili(IL_NULL, 0);
787 tmp = ad2ili(IL_ARGKR, op1, tmp);
788 op3 = mk_prototype("ftn_i_kabs", "pure", DT_INT8, 1, DT_INT8);
789 tmp = ad2ili(IL_QJSR, op3, tmp);
790 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
791 return;
792 case IM_KFIX:
793 op1 = ILI_OF(ILM_OPND(ilmp, 1));
794 tmp = ad1ili(IL_NULL, 0);
795 tmp = ad2ili(IL_ARGSP, op1, tmp);
796 op3 = mk_prototype(MTH_I_FIXK, "pure", DT_INT8, 1, DT_REAL);
797 tmp = ad2ili(IL_QJSR, op3, tmp);
798 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
799 return;
800 case IM_KDFIX:
801 op1 = ILI_OF(ILM_OPND(ilmp, 1));
802 ILM_RESULT(curilm) = ad1ili(IL_DFIXK, op1);
803 return;
804 case IM_ITOI8:
805 op1 = ILI_OF(ILM_OPND(ilmp, 1));
806 ILM_RESULT(curilm) = ad1ili(IL_IKMV, op1);
807 return;
808 case IM_I8TOI:
809 if (XBIT(124, 0x400)) {
810 op1 = ILI_OF(ILM_OPND(ilmp, 1));
811 ILM_RESULT(curilm) = ad1ili(IL_KIMV, op1);
812 return;
813 }
814 tmp = exp_mac(IM_I8TOI, ilmp, curilm);
815 return;
816 case IM_KMAX:
817 op1 = ILI_OF(ILM_OPND(ilmp, 1));
818 op2 = ILI_OF(ILM_OPND(ilmp, 2));
819 ILM_RESULT(curilm) = ad2ili(IL_KMAX, op1, op2);
820 return;
821 case IM_KMIN:
822 op1 = ILI_OF(ILM_OPND(ilmp, 1));
823 op2 = ILI_OF(ILM_OPND(ilmp, 2));
824 ILM_RESULT(curilm) = ad2ili(IL_KMIN, op1, op2);
825 return;
826 case IM_KMOD:
827 op1 = ILI_OF(ILM_OPND(ilmp, 1));
828 op2 = ILI_OF(ILM_OPND(ilmp, 2));
829 ILM_RESULT(curilm) = ad2ili(IL_KMOD, op1, op2);
830 return;
831 #ifdef IM_KMERGE
832 case IM_KMERGE:
833 op1 = ILI_OF(ILM_OPND(ilmp, 1));
834 op2 = ILI_OF(ILM_OPND(ilmp, 2));
835 op3 = ILI_OF(ILM_OPND(ilmp, 3));
836 tmp = ad1ili(IL_NULL, 0);
837 tmp = ad2ili(IL_ARGIR, op3, tmp);
838 tmp = ad2ili(IL_ARGKR, op2, tmp);
839 tmp = ad2ili(IL_ARGKR, op1, tmp);
840 tmp = ad2ili(IL_QJSR, mkfunc("ftn_i_kmerge"), tmp);
841 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
842 return;
843 #endif
844 case IM_KSIGN:
845 op1 = ILI_OF(ILM_OPND(ilmp, 1));
846 op2 = ILI_OF(ILM_OPND(ilmp, 2));
847 ILM_RESULT(curilm) = ad2func_kint(IL_QJSR, "ftn_i_kisign", op1, op2);
848 return;
849 case IM_KAND:
850 case IM_LAND8:
851 op1 = ILI_OF(ILM_OPND(ilmp, 1));
852 op2 = ILI_OF(ILM_OPND(ilmp, 2));
853 ILM_RESULT(curilm) = ad2ili(IL_KAND, op1, op2);
854 return;
855 case IM_KOR:
856 case IM_LOR8:
857 op1 = ILI_OF(ILM_OPND(ilmp, 1));
858 op2 = ILI_OF(ILM_OPND(ilmp, 2));
859 ILM_RESULT(curilm) = ad2ili(IL_KOR, op1, op2);
860 return;
861 case IM_KXOR:
862 op1 = ILI_OF(ILM_OPND(ilmp, 1));
863 op2 = ILI_OF(ILM_OPND(ilmp, 2));
864 ILM_RESULT(curilm) = ad2ili(IL_KXOR, op1, op2);
865 return;
866 case IM_KNOT:
867 op1 = ILI_OF(ILM_OPND(ilmp, 1));
868 ILM_RESULT(curilm) = ad1ili(IL_KNOT, op1);
869 return;
870 case IM_KBITS:
871 op1 = ILI_OF(ILM_OPND(ilmp, 1));
872 op2 = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
873 op3 = kimove(ILI_OF(ILM_OPND(ilmp, 3)));
874 tmp = ad1ili(IL_NULL, 0);
875 tmp = ad2ili(IL_ARGIR, op3, tmp);
876 tmp = ad2ili(IL_ARGIR, op2, tmp);
877 tmp = ad2ili(IL_ARGKR, op1, tmp);
878 op3 = mk_prototype(MTH_I_KBITS, "pure", DT_INT8, 3, DT_INT8, DT_INT8,
879 DT_INT8);
880 tmp = ad2ili(IL_QJSR, op3, tmp);
881 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
882 return;
883 case IM_KBSET:
884 op1 = ILI_OF(ILM_OPND(ilmp, 1));
885 op2 = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
886 tmp = ad1ili(IL_NULL, 0);
887 tmp = ad2ili(IL_ARGIR, op2, tmp);
888 tmp = ad2ili(IL_ARGKR, op1, tmp);
889 op3 = mk_prototype(MTH_I_KBSET, "pure", DT_INT8, 2, DT_INT8, DT_INT8);
890 tmp = ad2ili(IL_QJSR, op3, tmp);
891 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
892 return;
893 case IM_KBTEST:
894 op1 = ILI_OF(ILM_OPND(ilmp, 1));
895 op2 = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
896 tmp = ad1ili(IL_NULL, 0);
897 tmp = ad2ili(IL_ARGIR, op2, tmp);
898 tmp = ad2ili(IL_ARGKR, op1, tmp);
899 op3 = mk_prototype(MTH_I_KBTEST, "pure", DT_INT8, 2, DT_INT8, DT_INT8);
900 tmp = ad2ili(IL_QJSR, op3, tmp);
901 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
902 return;
903 case IM_KBCLR:
904 op1 = ILI_OF(ILM_OPND(ilmp, 1));
905 op2 = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
906 tmp = ad1ili(IL_NULL, 0);
907 tmp = ad2ili(IL_ARGIR, op2, tmp);
908 tmp = ad2ili(IL_ARGKR, op1, tmp);
909 op3 = mk_prototype(MTH_I_KBCLR, "pure", DT_INT8, 2, DT_INT8, DT_INT8);
910 tmp = ad2ili(IL_QJSR, op3, tmp);
911 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
912 return;
913 case IM_KURSHIFT:
914 op1 = ILI_OF(ILM_OPND(ilmp, 1));
915 op2 = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
916 op2 = ad1ili(IL_INEG, op2);
917 tmp = ad1ili(IL_NULL, 0);
918 tmp = ad2ili(IL_ARGIR, op2, tmp);
919 tmp = ad2ili(IL_ARGKR, op1, tmp);
920 op3 = mkfunc("ftn_i_kishft");
921 tmp = ad2ili(IL_QJSR, op3, tmp);
922 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
923 return;
924 case IM_KULSHIFT:
925 op1 = ILI_OF(ILM_OPND(ilmp, 1));
926 op2 = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
927 tmp = ad1ili(IL_NULL, 0);
928 tmp = ad2ili(IL_ARGIR, op2, tmp);
929 tmp = ad2ili(IL_ARGKR, op1, tmp);
930 op3 = mkfunc("ftn_i_kishft");
931 tmp = ad2ili(IL_QJSR, op3, tmp);
932 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
933 return;
934 case IM_KEQV:
935 op1 = ILI_OF(ILM_OPND(ilmp, 1));
936 op2 = ILI_OF(ILM_OPND(ilmp, 2));
937 ILM_RESULT(curilm) =
938 ad2func_kint(IL_QJSR, "ftn_i_xnori64", forceK(op1), forceK(op2));
939 return;
940 case IM_LEQV8:
941 op1 = ILI_OF(ILM_OPND(ilmp, 1));
942 op2 = ILI_OF(ILM_OPND(ilmp, 2));
943 tmp = ad3ili(IL_KCMP, op1, op2, CC_EQ);
944 ILM_RESULT(curilm) = ad1ili(IL_IKMV, tmp);
945 return;
946 case IM_LNEQV8:
947 op1 = ILI_OF(ILM_OPND(ilmp, 1));
948 op2 = ILI_OF(ILM_OPND(ilmp, 2));
949 ILM_RESULT(curilm) =
950 ad2func_kint(IL_QJSR, "ftn_i_xori64", forceK(op1), forceK(op2));
951 return;
952 case IM_FLOATK:
953 op1 = ILI_OF(ILM_OPND(ilmp, 1));
954 tmp = ad1ili(IL_NULL, 0);
955 op2 = mk_prototype(MTH_I_FLOATK, "pure", DT_REAL, 1, DT_INT8);
956 tmp = ad2ili(IL_ARGKR, op1, tmp);
957 tmp = ad2ili(IL_QJSR, op2, tmp);
958 ILM_RESULT(curilm) = ad2ili(IL_DFRSP, tmp, SP(0));
959 return;
960 case IM_DFLOATK:
961 op1 = ILI_OF(ILM_OPND(ilmp, 1));
962 tmp = ad1ili(IL_NULL, 0);
963 op2 = mk_prototype(MTH_I_DFLOATK, "pure", DT_DBLE, 1, DT_INT8);
964 tmp = ad2ili(IL_ARGKR, op1, tmp);
965 tmp = ad2ili(IL_QJSR, op2, tmp);
966 ILM_RESULT(curilm) = ad2ili(IL_DFRDP, tmp, DP(0));
967 return;
968 case IM_D2K:
969 op1 = ILI_OF(ILM_OPND(ilmp, 1));
970 ILM_RESULT(curilm) = ad1ili(IL_DP2KR, op1);
971 return;
972 case IM_R2K:
973 op1 = ILI_OF(ILM_OPND(ilmp, 1));
974 ILM_RESULT(curilm) = ad1ili(IL_SP2KR, op1);
975 return;
976 case IM_I2K:
977 op1 = ILI_OF(ILM_OPND(ilmp, 1));
978 ILM_RESULT(curilm) = ad1ili(IL_IKMV, op1);
979 return;
980 case IM_UI2K:
981 op1 = ILI_OF(ILM_OPND(ilmp, 1));
982 ILM_RESULT(curilm) = ad1ili(IL_UIKMV, op1);
983 return;
984 /* -- type -- intrinsic */
985 case IM_KTOI:
986 op1 = ILI_OF(ILM_OPND(ilmp, 1));
987 op2 = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
988 tmp = ad1ili(IL_NULL, 0);
989 tmp = ad2ili(IL_ARGIR, op2, tmp);
990 tmp = ad2ili(IL_ARGKR, op1, tmp);
991 tmp = ad2ili(IL_QJSR, mkfunc("__mth_i_kpowi"), tmp);
992 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
993 return;
994 case IM_KTOK:
995 op1 = ILI_OF(ILM_OPND(ilmp, 1));
996 op2 = ILI_OF(ILM_OPND(ilmp, 2));
997 tmp = ad1ili(IL_NULL, 0);
998 tmp = ad2ili(IL_ARGKR, op2, tmp);
999 tmp = ad2ili(IL_ARGKR, op1, tmp);
1000 tmp = ad2ili(IL_QJSR, mkfunc("__mth_i_kpowk"), tmp);
1001 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
1002 return;
1003 case IM_RTOK:
1004 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1005 op2 = ILI_OF(ILM_OPND(ilmp, 2));
1006 tmp = ad1ili(IL_NULL, 0);
1007 tmp = ad2ili(IL_ARGKR, op2, tmp);
1008 tmp = ad2ili(IL_ARGSP, op1, tmp);
1009 tmp = ad2ili(IL_QJSR, mkfunc("__mth_i_rpowk"), tmp);
1010 ILM_RESULT(curilm) = ad2ili(IL_DFRSP, tmp, SP(0));
1011 return;
1012 case IM_DTOK:
1013 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1014 op2 = ILI_OF(ILM_OPND(ilmp, 2));
1015 tmp = ad1ili(IL_NULL, 0);
1016 tmp = ad2ili(IL_ARGKR, op2, tmp);
1017 tmp = ad2ili(IL_ARGDP, op1, tmp);
1018 tmp = ad2ili(IL_QJSR, mkfunc("__mth_i_dpowk"), tmp);
1019 ILM_RESULT(curilm) = ad2ili(IL_DFRDP, tmp, DP(0));
1020 return;
1021 case IM_CTOK:
1022 if (XBIT(70, 0x40000000) && XBIT_NEW_MATH_NAMES_CMPLX) {
1023 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1024 op2 = ILI_OF(ILM_OPND(ilmp, 2));
1025 ilix = ad2ili(IL_SCMPLXPOWK, op1, op2);
1026 ILM_RESULT(curilm) = ilix;
1027 return;
1028 }
1029 exp_qjsr("__mth_i_cpowk", DT_CMPLX, ilmp, curilm);
1030 return;
1031 case IM_CDTOK:
1032 if (XBIT(70, 0x40000000) && XBIT_NEW_MATH_NAMES_CMPLX) {
1033 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1034 op2 = ILI_OF(ILM_OPND(ilmp, 2));
1035 ilix = ad2ili(IL_DCMPLXPOWK, op1, op2);
1036 ILM_RESULT(curilm) = ilix;
1037 return;
1038 }
1039 exp_qjsr("__mth_i_cdpowk", DT_DCMPLX, ilmp, curilm);
1040 return;
1041 case IM_KDIM:
1042 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1043 op2 = ILI_OF(ILM_OPND(ilmp, 2));
1044 ILM_RESULT(curilm) = ad2func_kint(IL_QJSR, "ftn_i_kidim", op1, op2);
1045 return;
1046 case IM_KNINT:
1047 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1048 tmp = ad1ili(IL_NULL, 0);
1049 tmp = ad3ili(IL_DASP, op1, SP(0), tmp);
1050 (void)mk_prototype("__mth_i_knint", "pure", DT_INT8, 1, DT_FLOAT);
1051 tmp = ad2ili(IL_QJSR, mkfunc("__mth_i_knint"), tmp);
1052 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
1053 return;
1054 case IM_KDNINT:
1055 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1056 tmp = ad1ili(IL_NULL, 0);
1057 tmp = ad3ili(IL_DADP, op1, DP(0), tmp);
1058 (void)mk_prototype("__mth_i_kidnnt", "pure", DT_INT8, 1, DT_DBLE);
1059 tmp = ad2ili(IL_QJSR, mkfunc("__mth_i_kidnnt"), tmp);
1060 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
1061 return;
1062 case IM_KISHFT:
1063 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1064 op2 = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
1065 tmp = ad1ili(IL_NULL, 0);
1066 tmp = ad2ili(IL_ARGIR, op2, tmp);
1067 tmp = ad2ili(IL_ARGKR, op1, tmp);
1068 op3 = mkfunc("ftn_i_kishft");
1069 tmp = ad2ili(IL_QJSR, op3, tmp);
1070 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
1071 return;
1072 case IM_KSHFTC:
1073 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1074 op2 = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
1075 op3 = kimove(ILI_OF(ILM_OPND(ilmp, 3)));
1076 tmp = ad1ili(IL_NULL, 0);
1077 tmp = ad2ili(IL_ARGIR, op3, tmp);
1078 tmp = ad2ili(IL_ARGIR, op2, tmp);
1079 tmp = ad2ili(IL_ARGKR, op1, tmp);
1080 tmp = ad2ili(IL_QJSR, mkfunc("ftn_i_kishftc"), tmp);
1081 ILM_RESULT(curilm) = ad2ili(IL_DFRKR, tmp, KR_RETVAL);
1082 return;
1083 /* -- type -- constant */
1084 case IM_KCON:
1085 tmp = ILM_OPND(ilmp, 1);
1086 if (XBIT(124, 0x400)) {
1087 ILM_RESULT(curilm) = ad1ili(IL_KCON, tmp);
1088 rcandb.kr = 1;
1089 } else {
1090 val[0] = 0;
1091 val[1] = CONVAL2G(tmp);
1092 ILM_RESULT(curilm) = ad1ili(IL_ICON, getcon(val, DT_INT));
1093 }
1094 break;
1095
1096 case IM_CCON:
1097 if (XBIT(70, 0x40000000)) {
1098 tmp = ILM_OPND(ilmp, 1);
1099 ILM_RESULT(curilm) = ad1ili(IL_SCMPLXCON, tmp);
1100 } else {
1101 /* complex constant; create 2 rcons */
1102 val[0] = 0;
1103 val[1] = CONVAL1G(tmp = ILM_OPND(ilmp, 1));
1104 ILM_RRESULT(curilm) = ad1ili(IL_FCON, getcon(val, DT_REAL));
1105 val[1] = CONVAL2G(tmp);
1106 ILM_IRESULT(curilm) = ad1ili(IL_FCON, getcon(val, DT_REAL));
1107 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
1108 }
1109 break;
1110 case IM_CDCON:
1111 if (XBIT(70, 0x40000000)) {
1112 tmp = ILM_OPND(ilmp, 1);
1113 ILM_RESULT(curilm) = ad1ili(IL_DCMPLXCON, tmp);
1114 } else {
1115 /* complex double constant; create 2 dcons */
1116 tmp = ILM_OPND(ilmp, 1);
1117 val[0] = CONVAL1G(CONVAL1G(tmp));
1118 val[1] = CONVAL2G(CONVAL1G(tmp));
1119 ILM_RRESULT(curilm) = ad1ili(IL_DCON, getcon(val, DT_DBLE));
1120 val[0] = CONVAL1G(CONVAL2G(tmp));
1121 val[1] = CONVAL2G(CONVAL2G(tmp));
1122 ILM_IRESULT(curilm) = ad1ili(IL_DCON, getcon(val, DT_DBLE));
1123 ILM_RESTYPE(curilm) = ILM_ISDCMPLX;
1124 }
1125 break;
1126
1127 case IM_LOC:
1128 /* merely copy up results, move from AR to DR */
1129 tmp = ILM_OPND(ilmp, 1);
1130 ilmpx = (ILM *)(ilmb.ilm_base + tmp);
1131 nme = NME_OF(tmp);
1132 ilix = ILI_OF(tmp);
1133
1134 ILM_RESULT(curilm) = ad1ili(IL_AKMV, ilix);
1135 loc_of(nme);
1136 {
1137 int sptr = basesym_of(nme);
1138 LOCARGP(sptr, 1);
1139 }
1140 break;
1141 case IM_ACON:
1142 nmsym = ILM_SymOPND(ilmp, 1);
1143 if (STYPEG(nmsym) == ST_LABEL) {
1144 SPTR stmp = FMTPTG(nmsym);
1145 tmp = stmp;
1146 if (stmp != SPTR_NULL) {
1147 /* format statement label */
1148 nmsym = get_acon(stmp, 0);
1149 ILM_RESULT(curilm) = ad1ili(IL_ACON, nmsym);
1150 nme = NME_UNK;
1151 } else {
1152 /*
1153 * executable statement label; add nmsym to list of
1154 * executable statement labels appearing in assignment
1155 * statements.
1156 */
1157 if (SYMLKG(nmsym) == 0) {
1158 SYMLKP(nmsym, gbl.asgnlbls);
1159 gbl.asgnlbls = nmsym;
1160 }
1161 nmsym = get_acon(nmsym, 0);
1162 ILM_RESULT(curilm) = ad2ili(IL_ACEXT, nmsym, 0);
1163 nme = NME_UNK;
1164 }
1165 break;
1166 }
1167 /* not a label */
1168 ILM_RESULT(curilm) = ad1ili(IL_ACON, nmsym);
1169 nme = NME_UNK;
1170 break;
1171 /*
1172 * For the compare ILMs, no code is generated at this time. Pass up
1173 * the equivalent ILI opcode to the relational or conditional branch
1174 * ILM using the compare.
1175 */
1176 case IM_KCMP:
1177 if (XBIT(124, 0x400))
1178 ILM_NME(curilm) = IL_KCMP;
1179 else
1180 ILM_NME(curilm) = IL_ICMP;
1181 return;
1182 case IM_ICMP:
1183 ILM_NME(curilm) = IL_ICMP;
1184 return;
1185 case IM_RCMP:
1186 ILM_NME(curilm) = IL_FCMP;
1187 return;
1188 case IM_DCMP:
1189 ILM_NME(curilm) = IL_DCMP;
1190 return;
1191 case IM_UICMP:
1192 ILM_NME(curilm) = IL_UICMP;
1193 return;
1194 case IM_UDICMP:
1195 interr("exp_ac: no IL_UDICMP ??", curilm, ERR_Severe);
1196 ILM_NME(curilm) = IL_ICMP;
1197 return;
1198 case IM_PCMP:
1199 ILM_NME(curilm) = IL_ACMP;
1200 op2 = ILI_OF(ILM_OPND(ilmp, 2));
1201 if (IL_RES(ILI_OPC(op2)) == ILIA_IR) {
1202 op2 = ad1ili(IL_IAMV, op2);
1203 ILM_RESULT(ILM_OPND(ilmp, 2)) = op2;
1204 } else if (IL_RES(ILI_OPC(op2)) == ILIA_KR) {
1205 op2 = ad1ili(IL_KAMV, op2);
1206 ILM_RESULT(ILM_OPND(ilmp, 2)) = op2;
1207 }
1208 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1209 if (IL_RES(ILI_OPC(op1)) != ILIA_AR) {
1210 /*
1211 * Inlining can create a situation where an actual argument
1212 * is now used in a pointer comparison, e.g.,
1213 * call foo(1)
1214 * ...
1215 * foo(i):
1216 * if (present(i)) ...
1217 *
1218 * Recover if the 2nd operand is 'null' by creating a
1219 * suitable non-null value for the 1st operand.
1220 */
1221 if (ILI_OPC(op2) == IL_ACON) {
1222 int s;
1223 s = ILI_OPND(op2, 1);
1224 if (CONVAL1G(s) == 0 && CONVAL2G(s) == 0) {
1225 op1 = ad_aconi(17);
1226 ILM_RESULT(ILM_OPND(ilmp, 1)) = op1;
1227 }
1228 }
1229 }
1230 return;
1231 /*
1232 * Mark complex compares so that the relational will generate
1233 * the compares of the real and imaginary parts. The relational
1234 * will need to know which ILI to use and the fact that it's
1235 * complex. NOTE that even for a complex double compare, the
1236 * type passed up is single complex; this is done so that the
1237 * relational can combine the handling of both types.
1238 */
1239 case IM_CCMP:
1240 if (XBIT(70, 0x40000000)) {
1241 ILM_NME(curilm) = IL_FCMP;
1242 return;
1243 }
1244 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
1245 ILM_NME(curilm) = IL_FCMP;
1246 return;
1247 case IM_CDCMP:
1248 if (XBIT(70, 0x40000000)) {
1249 ILM_NME(curilm) = IL_DCMP;
1250 return;
1251 }
1252 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
1253 ILM_NME(curilm) = IL_DCMP;
1254 return;
1255
1256 /*
1257 * For a relational, pick up the ILI opcode to be used from the names
1258 * entry of its operand (a compare). Also, the operands of this ILI
1259 * are the ILIs created for the operands of the compare ILM and an
1260 * immediate value denoting the relation.
1261 */
1262 case IM_EQ8:
1263 case IM_NE8:
1264 case IM_LT8:
1265 case IM_GE8:
1266 case IM_LE8:
1267 case IM_GT8:
1268 tmp = opc - IM_EQ8 + 1;
1269 goto relational_shared;
1270 case IM_EQ:
1271 case IM_NE:
1272 case IM_LT:
1273 case IM_GE:
1274 case IM_LE:
1275 case IM_GT:
1276 tmp = opc - IM_EQ + 1;
1277 relational_shared:
1278 ilmx = ILM_OPND(ilmp, 1); /* locate compare ILM */
1279 ilmpx = (ILM *)(ilmb.ilm_base + ilmx);
1280 #if DEBUG
1281 assert(ILM_OPC(ilmpx) >= IM_ICMP && ILM_OPC(ilmpx) <= IM_NSCMP ||
1282 ILM_OPC(ilmpx) == IM_KCMP || ILM_OPC(ilmpx) == IM_PCMP ||
1283 ILM_OPC(ilmpx) == IM_HFCMP,
1284 "expand:compare not operand of rel.", curilm, ERR_Severe);
1285 #endif
1286 if (ILM_RESTYPE(ilmx) == ILM_ISCHAR) {
1287 /* a string compare may be handled by the external function, ftn_strcmp.
1288 * The value of the function is -1 if '<', 0 if '=', * and 1 if '>'; its
1289 * value is compared with integer 0. If the ili of the SCMP ilm is ICMP,
1290 * then the compare was optimized.
1291 */
1292 #if DEBUG
1293 assert(ILM_OPC(ilmpx) == IM_SCMP || ILM_OPC(ilmpx) == IM_NSCMP,
1294 "expand:nme of compare zero, SCMP expected", curilm, ERR_Severe);
1295 #endif
1296 ilix = ILI_OF(ilmx);
1297 if (ILI_OPC(ilix) == IL_ICMP)
1298 ILM_RESULT(curilm) = ad3ili(IL_ICMP, ILI_OPND(ilix, 1),
1299 ILI_OPND(ilix, 2), tmp);
1300 else
1301 ILM_RESULT(curilm) = ad3ili(IL_ICMP, ilix, ad_icon(0), tmp);
1302 return;
1303 }
1304 if (ILM_RESTYPE(ilmx) == ILM_ISCMPLX) {
1305 int il1, il2;
1306 int ilm1 = ILM_OPND(ilmpx, 1); // ILM index of first operand of compare
1307 int ilm2 = ILM_OPND(ilmpx, 2); // ILM index of second operand
1308 opcx = (ILI_OP) NME_OF(ilmx);
1309 il1 = ad3ili(opcx, ILM_RRESULT(ilm1), ILM_RRESULT(ilm2), tmp);
1310 il2 = ad3ili(opcx, ILM_IRESULT(ilm1), ILM_IRESULT(ilm2), tmp);
1311 ILM_RESULT(curilm) = (opc == IM_EQ || opc == IM_EQ8)
1312 ? ad2ili(IL_AND, il1, il2)
1313 : ad2ili(IL_OR, il1, il2);
1314 if (XBIT(124, 0x400) && opc >= IM_EQ8 && opc <= IM_GT8)
1315 ILM_RESULT(curilm) = ad1ili(IL_IKMV, ILM_RESULT(curilm));
1316 return;
1317 } else if ((ILM_OPC(ilmpx) == IM_CCMP || ILM_OPC(ilmpx) == IM_CDCMP) &&
1318 XBIT(70, 0x40000000)) {
1319 int il1, il2;
1320 ILI_OP opci, opcr;
1321 int ilm1 = ILM_OPND(ilmpx, 1); // ILM index of first operand of compare
1322 int ilm2 = ILM_OPND(ilmpx, 2); // ILM index of second operand
1323 opcx = (ILI_OP) NME_OF(ilmx);
1324 if (ILM_OPC(ilmpx) == IM_CCMP) {
1325 opcr = IL_SCMPLX2REAL;
1326 opci = IL_SCMPLX2IMAG;
1327 } else {
1328 opcr = IL_DCMPLX2REAL;
1329 opci = IL_DCMPLX2IMAG;
1330 }
1331 il1 = ad3ili(opcx, ad1ili(opcr, ILM_RESULT(ilm1)),
1332 ad1ili(opcr, ILM_RESULT(ilm2)), tmp);
1333 il2 = ad3ili(opcx, ad1ili(opci, ILM_RESULT(ilm1)),
1334 ad1ili(opci, ILM_RESULT(ilm2)), tmp);
1335 ILM_RESULT(curilm) = (opc == IM_EQ || opc == IM_EQ8)
1336 ? ad2ili(IL_AND, il1, il2)
1337 : ad2ili(IL_OR, il1, il2);
1338 if (XBIT(124, 0x400) && opc >= IM_EQ8 && opc <= IM_GT8)
1339 ILM_RESULT(curilm) = ad1ili(IL_IKMV, ILM_RESULT(curilm));
1340 return;
1341 }
1342 opcx = (ILI_OP) NME_OF(ilmx);
1343 /*
1344 * If the compare is an unsigned compare for equality or
1345 * non-equality, use the signed integer compare.
1346 */
1347 if (opcx == IL_UICMP && tmp <= 2)
1348 opcx = IL_ICMP;
1349 op1 = ILI_OF(ILM_OPND(ilmpx, 1));
1350 op2 = ILI_OF(ILM_OPND(ilmpx, 2));
1351 if (opcx == IL_ICMP) {
1352 op1 = kimove(op1);
1353 op2 = kimove(op2);
1354 }
1355 ILM_RESULT(curilm) = ad3ili(opcx, op1, op2, tmp);
1356 if (XBIT(124, 0x400) && opc >= IM_EQ8 && opc <= IM_GT8)
1357 ILM_RESULT(curilm) = ad1ili(IL_IKMV, ILM_RESULT(curilm));
1358 return;
1359 #ifdef IM_ALLOCA
1360 case IM_ALLOCA:
1361 if (!bihb.parfg && !bihb.taskfg && ILM_OPND(ilmp, 4) != 1) {
1362 /*
1363 fprintf(stderr, "ALLOCA %s\n", SYMNAME(ILM_OPND(ilmp,3)));
1364 */
1365 ilix = exp_alloca(ilmp);
1366 } else {
1367 int arg;
1368 int sym;
1369 /*
1370 * 64-bit:
1371 * void *RTE_auto_allocv(I64 n, int sz)
1372 * 32-bit
1373 * void *RTE_auto_allocv(int n, int sz)
1374 */
1375 sym = mkfunc(mkRteRtnNm(RTE_auto_allocv));
1376 DTYPEP(sym, DT_CPTR); /* else defaults to 'int' return type */
1377 op1 = ILI_OF(ILM_OPND(ilmp, 1));
1378 op2 = ILI_OF(ILM_OPND(ilmp, 2));
1379 arg = ad1ili(IL_NULL, 0);
1380 arg = ad2ili(IL_ARGKR, op2, arg);
1381 arg = ad2ili(IL_ARGKR, op1, arg);
1382 ilix = ad2ili(IL_JSR, sym, arg);
1383 ilix = ad2ili(IL_DFRAR, ilix, AR_RETVAL);
1384 }
1385 ILM_RESULT(curilm) = ilix;
1386 break;
1387 #endif
1388 }
1389 ILM_NME(curilm) = nme; /* save NME entry */
1390 }
1391
1392 /***************************************************************/
1393
1394 static int
genload(SPTR sym,bool bigobj)1395 genload(SPTR sym, bool bigobj)
1396 {
1397 int acon;
1398 if (STYPEG(sym) == ST_CONST) {
1399 if (bigobj)
1400 return ad1ili(IL_KCON, sym);
1401 return ad1ili(IL_ICON, sym);
1402 }
1403 /* generate load of sym */
1404 if (flg.smp || XBIT(34, 0x200)) {
1405 if (SCG(sym) == SC_STATIC)
1406 sym_is_refd(sym);
1407 }
1408 acon = compute_address(sym);
1409 if (bigobj)
1410 return ad3ili(IL_LDKR, acon, addnme(NT_VAR, sym, 0, (INT)0), MSZ_I8);
1411 return ad3ili(IL_LD, acon, addnme(NT_VAR, sym, 0, (INT)0), MSZ_WORD);
1412 } /* genload */
1413
1414 /*
1415 * components of a subscripted reference, computed by compute_subscr() and
1416 * inlarr(), and possibly modified by inlarr().
1417 * NOTE that the ili expressions for the zero base offset and subscript
1418 * offset do not have the element size factored in.
1419 */
1420 static struct {
1421 int base; /* base ili (type ar) of the array */
1422 int basenm; /* base nme of subscripted ref */
1423 int zbase; /* final zero base offset (ili, type ir ) */
1424 int offset; /* ili expr of subscripts with consts factored out */
1425 int scale; /* scaling factor to be applied to any offsets */
1426 int elmscz; /* ili of element size (to be scaled, type ir) */
1427 int elmsz; /* ili of actual element size (type ir) */
1428 DTYPE eldt; /* data type of element */
1429 int nsubs; /* number of subscripts */
1430 int sub[7]; /* ili for each (actual) subscript */
1431 int osub[7]; /* ili for original subscript (before expanding to 64-bit) */
1432 int finalnme; /* final NME */
1433 } subscr;
1434
1435 static void
compute_subscr(ILM * ilmp,bool bigobj)1436 compute_subscr(ILM *ilmp, bool bigobj)
1437 {
1438 ADSC *adp; /* array descriptor */
1439 DTYPE dtype; /* array data type */
1440 int arrilm; /* ilm for array */
1441 int zbase; /* zbase sym/ili ptr */
1442 int i;
1443 SPTR sym;
1444 ILM *ilmp1;
1445 int sub;
1446 int mplyr;
1447 int offset;
1448 int ili2;
1449 ISZ_T coffset;
1450 int sub_1;
1451 int subs[7];
1452
1453 subscr.nsubs = ILM_OPND(ilmp, 1);
1454 #if DEBUG
1455 assert(subscr.nsubs <= (sizeof(subscr.sub) / sizeof(int)),
1456 "compute_subscr:nsubs exceeded", subscr.nsubs, ERR_Severe);
1457 #endif
1458 arrilm = ILM_OPND(ilmp, 2);
1459 dtype = ILM_DTyOPND(ilmp, 3);
1460 ilmp1 = (ILM *)(ilmb.ilm_base + arrilm);
1461 if (ILM_OPC(ilmp1) == IM_PLD) {
1462 /* rewritten arguments */
1463 sym = ILM_SymOPND(ilmp1, 2);
1464 if (ORIGDUMMYG(sym)) {
1465 sym = ORIGDUMMYG(sym);
1466 }
1467 } else {
1468 sym = (SPTR) ILM_OPND(ilmp1, 1); /* symbol pointer */
1469 }
1470 for (i = 0; i < subscr.nsubs; ++i) {
1471 subs[i] = ILI_OF(ILM_OPND(ilmp, 4 + i)); /* subscript ili */
1472 }
1473 create_array_subscr(NME_OF(arrilm), sym, dtype, ILM_OPND(ilmp, 1), subs,
1474 ILI_OF(arrilm));
1475 }
1476
1477 /**
1478 * \brief: return double character length, since kanji char is 2 bytes long
1479 */
1480 static int
kanji_bytes(int ilix)1481 kanji_bytes(int ilix)
1482 {
1483 if (IL_RES(ILI_OPC(ilix)) == ILIA_KR) {
1484 ilix = ad2ili(IL_KMUL, ilix, ad_kcon(0, 2));
1485 } else {
1486 ilix = ad2ili(IL_IMUL, ilix, ad_icon(2L));
1487 }
1488 return ilix;
1489 }
1490
1491 /**
1492 * \brief: return kanji char string length from byte count, divide by 2
1493 */
1494 static int
kanji_divide(int ilix)1495 kanji_divide(int ilix)
1496 {
1497 if (IL_RES(ILI_OPC(ilix)) == ILIA_KR) {
1498 ilix = ad2ili(IL_KDIV, ilix, ad_kcon(0, 2));
1499 } else {
1500 ilix = ad2ili(IL_IDIV, ilix, ad_icon(2L));
1501 }
1502 return ilix;
1503 }
1504
1505 static int
compute_nme(SPTR sptr,int constant,int basenm)1506 compute_nme(SPTR sptr, int constant, int basenm)
1507 {
1508 /* build up the array nme from the sdsc - should be
1509 * exactly a 1-dimensional array (since it's the sdsc).
1510 */
1511 int i, nme, sub;
1512 bool inl_flg = false;
1513 if (STYPEG(sptr) == ST_MEMBER)
1514 nme = addnme(NT_MEM, sptr, basenm, 0);
1515 else
1516 nme = addnme(NT_VAR, sptr, 0, 0);
1517
1518 /* ORIGDIM field not set for inlined variables
1519 assert(ORIGDIMG(sptr) == 1,"compute_nme: not 1-D",ORIGDIMG(sptr),3);
1520 */
1521
1522 /* maybe if we have an INLELEM we need inl flg ? */
1523 sub = ad_icon(constant);
1524 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, constant, sub, inl_flg);
1525 return nme;
1526 }
1527
1528 /*
1529 * compute subscript expressions using descriptors
1530 * only for PGF90
1531 */
1532
1533 static void
compute_sdsc_subscr(ILM * ilmp,bool bigobj)1534 compute_sdsc_subscr(ILM *ilmp, bool bigobj)
1535 {
1536 int i, fi;
1537 SPTR sdsc;
1538 int nme, ili1, ili2, ili3, ili4;
1539 int base = 0;
1540 int basenm = 0, basesym;
1541 DTYPE dtype; /* array data type */
1542 ADSC *adp; /* array descriptor */
1543 int arrilm; /* ilm for array */
1544 SPTR sym = SPTR_NULL;
1545 int sub;
1546 ILM *basep, *ilmp1;
1547 int any_kr;
1548 int ptrexpand = 0;
1549 int sub_1;
1550 int offset;
1551 ISZ_T coffset;
1552 int zoffset;
1553 int oldnme;
1554
1555 dtype = ILM_DTyOPND(ilmp, 3);
1556 adp = AD_DPTR(dtype);
1557
1558 /* useful information re: the storage class of sptr:
1559 * assumed shape => SC_LOCAL, pointer => SC_BASED,
1560 * allocatable => SC_BASED , automatic => SC_DUMMY
1561 */
1562
1563 sdsc = AD_SDSC(adp);
1564 assert(sdsc != 0, "compute_sdsc_subscr: sdsc is zero", sdsc, ERR_Severe);
1565 PTRSAFEP(sdsc, 1);
1566
1567 /* this code duplicates much of what is done in compute_subscr(),
1568 * filling in the the subscr fields, except for subscr.zbase and
1569 * subscr.offset, which are different here due to the late
1570 * linearization of assumed shape and pointer arrays.
1571 */
1572
1573 subscr.nsubs = ILM_OPND(ilmp, 1);
1574 subscr.zbase = 0;
1575 #if DEBUG
1576 assert(subscr.nsubs <= (sizeof(subscr.sub) / sizeof(int)),
1577 "compute_sdsc_subscr:nsubs exceeded", subscr.nsubs, ERR_Severe);
1578 #endif
1579 arrilm = ILM_OPND(ilmp, 2);
1580 subscr.eldt = DTySeqTyElement(dtype); /* element data type */
1581
1582 if (subscr.eldt != DT_ASSCHAR && subscr.eldt != DT_ASSNCHAR &&
1583 subscr.eldt != DT_DEFERCHAR && subscr.eldt != DT_DEFERNCHAR) {
1584 if (bigobj) {
1585 ISZ_T val;
1586 subscr.elmsz = ad_kconi(size_of(subscr.eldt));
1587 subscr.scale = Scale_Of(subscr.eldt, &val);
1588 subscr.elmscz = ad_kconi(val);
1589 } else {
1590 INT val;
1591 subscr.elmsz = ad_icon(size_of(subscr.eldt));
1592 subscr.scale = scale_of(subscr.eldt, &val);
1593 subscr.elmscz = ad_icon(val);
1594 }
1595 } else if (subscr.eldt == DT_DEFERCHAR || subscr.eldt == DT_DEFERNCHAR) {
1596 /* deferred-size character; size is in symtab */
1597 int bytes;
1598
1599 ilmp1 = (ILM *)(ilmb.ilm_base + arrilm);
1600 if (ILM_OPC(ilmp1) == IM_PLD) {
1601 /* rewritten arguments */
1602 sym = ILM_SymOPND(ilmp1, 2);
1603 if (ORIGDUMMYG(sym) && !XBIT(57, 0x80000)) {
1604 /* still using pghpf_ptr_in/out */
1605 sym = ORIGDUMMYG(sym);
1606 }
1607 } else {
1608 #if DEBUG
1609 assert(ILM_OPC(ilmp1) == IM_BASE,
1610 "compute_sdsc_subscr: DEFERCH array not base", arrilm, ERR_Severe);
1611 #endif
1612 sym = (SPTR) ILM_OPND(ilmp1, 1); /* symbol pointer */
1613 }
1614 #if DEBUG
1615 assert((STYPEG(sym) == ST_ARRAY ||
1616 (STYPEG(sym) == ST_MEMBER &&
1617 (subscr.eldt == DT_DEFERCHAR || subscr.eldt == DT_DEFERNCHAR))),
1618 "compute_sdsc_subscr: ASSCH/DEFERCH sym not array", sym, ERR_Severe);
1619 #endif
1620 /* generate load of elem size */
1621 if (STYPEG(sym) == ST_MEMBER) {
1622 /* Could member be called in this function ever? */
1623 int base;
1624 ILM *basep;
1625 basep = (ILM *)(ilmb.ilm_base + ILM_OPND(ilmp1, 1));
1626 base = ILM_OPND(basep, 1);
1627 bytes = exp_get_sdsc_len(sym, ILI_OF(base), NME_OF(base));
1628 } else
1629 bytes = exp_get_sdsc_len(sym, 0, 0);
1630 if (subscr.eldt == DT_DEFERNCHAR) /* assumed size kanji dummy */
1631 bytes = kanji_bytes(bytes);
1632 subscr.elmscz = subscr.elmsz = bytes;
1633 subscr.scale = 0;
1634 } else {
1635 /* assumed-size character; size is in symtab */
1636 int bytes;
1637
1638 ilmp1 = (ILM *)(ilmb.ilm_base + arrilm);
1639 if (ILM_OPC(ilmp1) == IM_PLD) {
1640 /* rewritten arguments */
1641 sym = ILM_SymOPND(ilmp1, 2);
1642 if (ORIGDUMMYG(sym) && !XBIT(57, 0x80000)) {
1643 /* still using pghpf_ptr_in/out */
1644 sym = ORIGDUMMYG(sym);
1645 }
1646 } else {
1647 #if DEBUG
1648 assert(ILM_OPC(ilmp1) == IM_BASE,
1649 "compute_sdsc_subscr: ASSCH/DEFERCH array not base", arrilm, ERR_Severe);
1650 #endif
1651 sym = ILM_SymOPND(ilmp1, 1); /* symbol pointer */
1652 }
1653 #if DEBUG
1654 assert(STYPEG(sym) == ST_ARRAY,
1655 "compute_sdsc_subscr: ASSCH/DEFERCH sym not array", sym, ERR_Severe);
1656 #endif
1657 /* generate load of elem size */
1658 bytes = charlen(sym);
1659 if (subscr.eldt == DT_ASSNCHAR) /* assumed size kanji dummy */
1660 bytes = kanji_bytes(bytes);
1661 subscr.elmscz = subscr.elmsz = bytes;
1662 subscr.scale = 0;
1663 }
1664
1665 subscr.basenm = NME_OF(arrilm);
1666 basesym = 0;
1667 oldnme = subscr.basenm;
1668
1669 /*
1670 * when XBIT(183,0x80000) is set, expand.c:update_local_nme() is called
1671 * and may produce an NT_IND
1672 */
1673 if (XBIT(183, 0x80000) && NME_TYPE(subscr.basenm) == NT_IND) {
1674 /* unsure if this code ever sees NT_IND of NT_IND of NT_VAR; if so
1675 * tmpsym is invalid -- revisit and perhaps add an assert of NT_VAR.
1676 */
1677 int tmpnme = NME_NM(subscr.basenm);
1678 int tmpsym = NME_SYM(tmpnme);
1679 if ((gbl.outlined || ISTASKDUPG(GBL_CURRFUNC)) && tmpsym > 0 &&
1680 PARREFG(tmpsym) && !is_llvm_local_private(tmpsym))
1681 oldnme = tmpnme;
1682 }
1683 if (oldnme && NME_TYPE(oldnme) == NT_VAR) {
1684 basesym = NME_SYM(oldnme);
1685 /*
1686 * -Mcray=pointer could be in effect at this point; however,
1687 * if the pointee is a POINTER, the extra calculations are
1688 * still needed for
1689 * real,target :: arr(100)
1690 * real, pointer :: p(:)
1691 * p => arr(11:20)
1692 * With -Mcray=pointer, still need to check to see if ptrexpand
1693 * must be set.
1694 * Note that checks are similar to the PLD case, with the addition
1695 * of the NOCONFLICT check performed in expand.c (for facerec).
1696 */
1697 if (!XBIT(125, 0x400) && basesym && XBIT(58, 0x8000000) &&
1698 POINTERG(basesym) && !NOCONFLICTG(basesym))
1699 ptrexpand = 1;
1700 } else {
1701 basep = (ILM *)(ilmb.ilm_base + ILM_OPND(ilmp, 2));
1702 if (ILM_OPC(basep) == IM_PLD) {
1703 /* get corresponding symbol */
1704 basesym = ILM_OPND(basep, 2);
1705 }
1706 if (basesym && XBIT(58, 0x8000000) && POINTERG(basesym))
1707 ptrexpand = 1;
1708 }
1709
1710 /* record subscripts in subscr.sub[i] */
1711 any_kr = 0;
1712 if (XBIT(125, 0x20000))
1713 any_kr = 1;
1714 for (i = 0; i < subscr.nsubs; ++i) {
1715 sub = ILI_OF(ILM_OPND(ilmp, 4 + i)); /* subscript ili */
1716 subscr.sub[i] = subscr.osub[i] = sub;
1717 if (IL_RES(ILI_OPC(sub)) == ILIA_KR)
1718 any_kr = 1;
1719 }
1720 if (any_kr || bigobj) {
1721 for (i = 0; i < subscr.nsubs; ++i) {
1722 subscr.sub[i] = ikmove(subscr.sub[i]);
1723 }
1724 }
1725 sub_1 = subscr.sub[0];
1726
1727 subscr.base = ILI_OF(arrilm);
1728
1729 /* is the sdsc of type ST_MEMBER? */
1730 if (STYPEG(sdsc) == ST_MEMBER) {
1731 /* find the base ILM and NME */
1732 basep = (ILM *)(ilmb.ilm_base + ILM_OPND(ilmp, 2));
1733 assert(ILM_OPC(basep) == IM_PLD, "compute_sdsc_subscr: not PLD",
1734 ILM_OPND(ilmp, 2), ERR_Severe);
1735 basep = (ILM *)(ilmb.ilm_base + ILM_OPND(basep, 1));
1736 assert(ILM_OPC(basep) == IM_MEMBER, "compute_sdsc_subscr: not MEMBER",
1737 ILM_OPND(ilmp, 2), ERR_Severe);
1738 base = ILM_OPND(basep, 1);
1739 basenm = NME_OF(base);
1740 base = ILI_OF(base);
1741 assert(base, "compute_sdsc_subscr: base is NULL", base, ERR_Severe);
1742 }
1743
1744 /* compute the static descriptor linearized version of this
1745 * array reference.
1746 */
1747 fi = 0;
1748 if (!any_kr)
1749 offset = ad_icon(0);
1750 else
1751 offset = ad1ili(IL_KCON, stb.k0);
1752 if (!SDSCS1G(sdsc) && !CONTIGATTRG(basesym)) {
1753 ili1 = offset;
1754 } else {
1755 ili1 = subscr.sub[0];
1756 fi = 1;
1757 }
1758 coffset = 0;
1759 zoffset = 0;
1760 if (fi == 1) {
1761 /*
1762 * given a subscripted non-pointer array (assumed-shape),
1763 * if the first/left-most subscript is a constant, the initial value
1764 * of the constant offset is the subscript's value and the first
1765 * subscript must be set to 0.
1766 */
1767 if (!XBIT(125, 0x4000) && IL_TYPE(ILI_OPC(sub_1)) == ILTY_CONS) {
1768 coffset = get_isz_cval(ILI_OPND(sub_1, 1));
1769 ili1 = subscr.sub[0] = subscr.osub[0] = offset; /* the zero */
1770 } else if ((ILI_OPC(sub_1) == IL_IADD) &&
1771 ILI_OPC(ili2 = ILI_OPND(sub_1, 2)) == IL_ICON) {
1772 /*
1773 * subcript is of the form i + c, where c is a constant.
1774 */
1775 coffset = CONVAL2G(ILI_OPND(ili2, 1));
1776 ili1 = ILI_OPND(sub_1, 1);
1777 } else if ((ILI_OPC(sub_1) == IL_ISUB) &&
1778 ILI_OPC(ili2 = ILI_OPND(sub_1, 2)) == IL_ICON) {
1779 /*
1780 * subscript is of the form i - c, where c is a constant.
1781 */
1782 coffset = -CONVAL2G(ILI_OPND(ili2, 1));
1783 ili1 = ILI_OPND(sub_1, 1);
1784 } else if ((ILI_OPC(sub_1) == IL_KADD) &&
1785 ILI_OPC(ili2 = ILI_OPND(sub_1, 2)) == IL_KCON) {
1786 /*
1787 * subcript is of the form i + c, where c is a constant.
1788 */
1789 coffset = get_isz_cval(ILI_OPND(ili2, 1));
1790 ili1 = ILI_OPND(sub_1, 1);
1791 } else if ((ILI_OPC(sub_1) == IL_KSUB) &&
1792 ILI_OPC(ili2 = ILI_OPND(sub_1, 2)) == IL_KCON) {
1793 /*
1794 * subscript is of the form i - c, where c is a constant.
1795 */
1796 coffset = -get_isz_cval(ILI_OPND(ili2, 1));
1797 ili1 = ILI_OPND(sub_1, 1);
1798 }
1799 }
1800 for (i = fi; i < subscr.nsubs; ++i) {
1801 /* let DIM_x(i) be DESC_HDR_LEN + i*DESC_DIM_LEN + DESC_DIM_x
1802 * subscript term = subscr.sub[i] * sd[DIM_LMULT(i)]
1803 * if ptrexpand is set, the term is more complex:
1804 * subscript term =
1805 * (subscr.sub[i] * sd[DIM_SSTRIDE(i)] + sd[DIM_SOFFSET(i)]) *
1806 * sd[DIM_LMULT(i)]
1807 */
1808 ili1 = add_ptr_subscript(i, subscr.sub[i], ili1, base, basesym, basenm, adp,
1809 ptrexpand, any_kr);
1810 }
1811 /* offset is in ili1 */
1812 if (XBIT(57, 0x10000) && basesym &&
1813 ((SCG(basesym) == SC_DUMMY && !POINTERG(basesym) &&
1814 (!XBIT(58, 0x400000) || !ASSUMSHPG(basesym) || !TARGETG(basesym)))
1815 #ifdef INLNARRG
1816 || (INLNARRG(basesym))
1817 #endif
1818 )) {
1819 SPTR zbase;
1820 int nme;
1821 if (any_kr) {
1822 ili1 = ikmove(ili1);
1823 }
1824 /* the front end has folded the offset computation
1825 * for assumed-shape dummies into the ZBASE field */
1826 zbase = AD_ZBASE(adp);
1827 ili3 = mk_address(zbase);
1828 nme = addnme(NT_VAR, zbase, 0, 0);
1829 if (DTYPEG(zbase) == DT_INT8)
1830 ili3 = ad3ili(IL_LDKR, ili3, nme, MSZ_I8);
1831 else {
1832 ili3 = ad3ili(IL_LD, ili3, nme, MSZ_WORD);
1833 if (any_kr)
1834 ili3 = ad1ili(IL_IKMV, ili3);
1835 }
1836 if (!any_kr) {
1837 ili1 = ad2ili(IL_IADD, ili1, ili3);
1838 } else {
1839 ili1 = ad2ili(IL_KADD, ili1, ili3);
1840 }
1841 subscr.offset = ili1;
1842 } else {
1843 /* add the lower bound - local base index offset folds in
1844 * amount so that zero-based references work. It's
1845 * located at $sd(DESC_HDR_LBASE).
1846 */
1847 ili3 = get_sdsc_element(sdsc, DESC_HDR_LBASE, base, basenm);
1848 if (!any_kr)
1849 subscr.offset = ad2ili(IL_IADD, ili1, ili3);
1850 else {
1851 ili3 = ikmove(ili3);
1852 subscr.offset = ad2ili(IL_KADD, ili1, ili3);
1853 }
1854 }
1855 if (!SDSCS1G(sdsc) && !CONTIGATTRG(basesym) && !XBIT(28, 0x20)) {
1856 /*
1857 * A pointer array may not be contiguous, so using the 'element'
1858 * size as the final multiplier is insufficient.
1859 * Define the multiplier to be the 'byte length' as stored in the
1860 * descriptor; this is the length between elements of the array
1861 * and is located at $sd(DESC_HDR_BYTE_LEN).
1862 */
1863 #ifdef SDSCCONTIGG
1864 if (!SDSCCONTIGG(sdsc))
1865 #endif
1866 {
1867 subscr.scale = 0;
1868 subscr.elmscz =
1869 kimove(get_sdsc_element(sdsc, DESC_HDR_BYTE_LEN, base, basenm));
1870 }
1871 if (subscr.zbase == 0) {
1872 if (any_kr)
1873 subscr.zbase = ad_kconi(1);
1874 else
1875 subscr.zbase = ad_icon(1);
1876 }
1877 } else if (subscr.zbase == 0) {
1878 if (any_kr)
1879 subscr.zbase = ad_kconi(1);
1880 else
1881 subscr.zbase = ad_icon(1);
1882 } else {
1883 subscr.zbase = ad2ili(IL_IADD, subscr.zbase, ad_icon(1));
1884 if (any_kr) {
1885 subscr.zbase = ad1ili(IL_IKMV, subscr.zbase);
1886 }
1887 }
1888 subscr.sub[0] = subscr.osub[0] = sub_1;
1889 if (coffset) {
1890 if (any_kr)
1891 subscr.zbase = ad2ili(IL_KSUB, subscr.zbase, ad_kconi(coffset));
1892 else
1893 subscr.zbase = ad2ili(IL_ISUB, subscr.zbase, ad_icon(coffset));
1894 }
1895
1896 if (zoffset) {
1897 /*
1898 * Moving zoffset into the base will ultimately yield adding
1899 * an IAMV/KAMV to both operands of an AADD. iliutil.c:addarth()
1900 * will combine the operands of the IAMV/KAMV, so need to ensure
1901 * that XBIT(15,0x100) is default or temporarily set.
1902 * NOTE -- unless the code above which sets zoffset to the first
1903 * subscript if constant is enabled, zoffset is always zero.
1904 */
1905 if (any_kr) {
1906 ili2 = ikmove(subscr.elmscz);
1907 if (ILI_OPC(zoffset) == IL_KMUL) {
1908 /*
1909 * zoffset <-- <stride> * cnst; form
1910 * zoffset <-- (<stride> * <elmscz>) * cnst
1911 */
1912 ili2 = ad2ili(IL_KMUL, ILI_OPND(zoffset, 1), ili2);
1913 ili2 = ad2ili(IL_KMUL, ili2, ILI_OPND(zoffset, 2));
1914 } else {
1915 /*
1916 * zoffset <-- <stride>; form
1917 * zoffset <-- <stride> * <elmscz>)
1918 */
1919 /**** zoffset <-- <<<sdsc_stride>>> ****/
1920 ili2 = ad2ili(IL_KMUL, zoffset, ili2);
1921 }
1922 ili2 = ad1ili(IL_KAMV, ili2);
1923 } else {
1924 if (ILI_OPC(zoffset) == IL_IMUL) {
1925 /*
1926 * zoffset <-- <stride> * cnst; form
1927 * zoffset <-- (<stride> * <elmscz>) * cnst
1928 */
1929 ili2 = ad2ili(IL_IMUL, ILI_OPND(zoffset, 1), subscr.elmscz);
1930 ili2 = ad2ili(IL_IMUL, ili2, ILI_OPND(zoffset, 2));
1931 } else {
1932 /*
1933 * zoffset <-- <stride>; form
1934 * zoffset <-- <stride> * <elmscz>)
1935 */
1936 ili2 = ad2ili(IL_IMUL, zoffset, subscr.elmscz);
1937 }
1938 ili2 = ad1ili(IL_IAMV, ili2);
1939 }
1940 subscr.base = ad3ili(IL_AADD, subscr.base, ili2, 0);
1941 }
1942 }
1943
1944 static int
add_ptr_subscript(int i,int sub,int ili1,int base,int basesym,int basenm,ADSC * adp,int ptrexpand,int any_kr)1945 add_ptr_subscript(int i, int sub, int ili1, int base, int basesym, int basenm,
1946 ADSC *adp, int ptrexpand, int any_kr)
1947 {
1948 int ili2, ili3, ili4, ili5;
1949 int val;
1950 SPTR sdsc = AD_SDSC(adp);
1951 ili2 = sub;
1952 ili4 = 0;
1953 ili5 = 0;
1954 if (XBIT(57, 0x10000) && basesym &&
1955 ((SCG(basesym) == SC_DUMMY && !POINTERG(basesym) &&
1956 (!XBIT(54, 2) || !ASSUMSHPG(basesym)) &&
1957 (!XBIT(58, 0x400000) || !ASSUMSHPG(basesym) || !TARGETG(basesym)))
1958 #ifdef INLNARRG
1959 || (INLNARRG(basesym))
1960 #endif
1961 )) {
1962 int nme;
1963 SPTR m = AD_MLPYR(adp, i);
1964 ili3 = mk_address(m);
1965 nme = addnme(NT_VAR, m, 0, 0);
1966 if (DTYPEG(m) == DT_INT8)
1967 ili3 = ad3ili(IL_LDKR, ili3, nme, MSZ_I8);
1968 else
1969 ili3 = ad3ili(IL_LD, ili3, nme, MSZ_WORD);
1970 /* ### probably need to check this for ptrexpand, for inlined routines */
1971 } else {
1972 if (ptrexpand) {
1973 if (!XBIT(58, 0x40000000)) {
1974 /* with section stride/offset */
1975 val = DESC_HDR_LEN + i * DESC_DIM_LEN + DESC_DIM_SSTRIDE;
1976 ili4 = get_sdsc_element(sdsc, val, base, basenm);
1977 val = DESC_HDR_LEN + i * DESC_DIM_LEN + DESC_DIM_SOFFSET;
1978 ili5 = get_sdsc_element(sdsc, val, base, basenm);
1979 }
1980 }
1981 /* the (i+1)st dimension subscript ili is located at subscr.sub[i] */
1982 val = DESC_HDR_LEN + i * DESC_DIM_LEN + DESC_DIM_LMULT;
1983 ili3 = get_sdsc_element(sdsc, val, base, basenm);
1984 }
1985 if (!any_kr) {
1986 if (!XBIT(58, 0x40000000)) {
1987 /* with section stride/offset */
1988 if (ptrexpand && ili5) {
1989 ili2 = ad2ili(IL_IMUL, ili2, ili4);
1990 ili2 = ad2ili(IL_IADD, ili2, ili5);
1991 }
1992 ili2 = ad2ili(IL_IMUL, ili2, ili3);
1993 } else {
1994 /* no section stride/offset */
1995 ili2 = ad2ili(IL_IMUL, ili2, ili3);
1996 if (ptrexpand && ili5) {
1997 ili2 = ad2ili(IL_IADD, ili2, ili5);
1998 }
1999 }
2000 ili1 = ad2ili(IL_IADD, ili1, ili2);
2001 } else {
2002 if (DTYG(DTYPEG(sdsc)) == DT_INT) {
2003 ili3 = ad1ili(IL_IKMV, ili3);
2004 if (ptrexpand && ili5) {
2005 if (ili4)
2006 ili4 = ad1ili(IL_IKMV, ili4);
2007 ili5 = ad1ili(IL_IKMV, ili5);
2008 }
2009 }
2010 if (!XBIT(58, 0x40000000)) {
2011 /* with section stride/offset */
2012 if (ptrexpand && ili5) {
2013 ili2 = ad2ili(IL_KMUL, ili2, ili4);
2014 ili2 = ad2ili(IL_KADD, ili2, ili5);
2015 }
2016 ili2 = ad2ili(IL_KMUL, ili2, ili3);
2017 } else {
2018 /* no section stride/offset */
2019 ili2 = ad2ili(IL_KMUL, ili2, ili3);
2020 if (ptrexpand && ili5) {
2021 ili2 = ad2ili(IL_KADD, ili2, ili5);
2022 }
2023 }
2024 ili1 = ad2ili(IL_KADD, ili1, ili2);
2025 }
2026 return ili1;
2027 }
2028
2029 static bool
is_currsub_dummy(int sdsc)2030 is_currsub_dummy(int sdsc)
2031 {
2032
2033 #ifdef KEEP_ARG_IN_MEM
2034 return true;
2035 #endif
2036
2037 if (SCG(sdsc) != SC_DUMMY)
2038 return false;
2039 if (!flg.smp) {
2040 if (CONTAINEDG(gbl.currsub)) {
2041 if (INTERNREFG(sdsc)) {
2042 return false;
2043 }
2044 }
2045 return true;
2046 } else if (TASKDUPG(gbl.currsub)) {
2047 return false;
2048 } else if (!gbl.outlined) {
2049 if (CONTAINEDG(gbl.currsub)) {
2050 if (INTERNREFG(sdsc)) {
2051 return false;
2052 }
2053 } else
2054 return true;
2055 } else {
2056 return false;
2057 }
2058 return true;
2059 }
2060
2061 int
get_sdsc_element(SPTR sdsc,int indx,int membase,int membase_nme)2062 get_sdsc_element(SPTR sdsc, int indx, int membase, int membase_nme)
2063 {
2064 int acon, ili;
2065 int scale, elmsz;
2066 if (CLASSG(sdsc)) {
2067 /* Special case for type descriptors and -Mlarge_arrays
2068 * or -mcmodel=medium. We can't compute the descriptor element size
2069 * from the element dtype since we store the derived type dtype record
2070 * that's associated with this type descriptor in DTY(dtype+1). So,
2071 * we assume DT_INT (or stb.il) by default and DT_INT8 (or stb.k1) for
2072 * -Mlarge_arrays and -mcmodel=medium.
2073 */
2074 if (XBIT(68, 0x1))
2075 scale = scale_of(DTYPEG(stb.k1), &elmsz);
2076 else
2077 scale = scale_of(DTYPEG(stb.i1), &elmsz);
2078 } else
2079 scale = scale_of((DTYPE) DTYG(DTYPEG(sdsc)), // FIXME: bug
2080 &elmsz); /* element size of sdsc is integer */
2081
2082 if (membase) {
2083 acon = ad3ili(IL_AADD, membase,
2084 ad_aconi(ADDRESSG(sdsc) + elmsz * (indx - 1)), scale);
2085 } else {
2086 if (SCG(sdsc) == SC_CMBLK && IS_THREAD_TP(sdsc)) {
2087 /*
2088 * BASE is of a member which is in a threadprivate common.
2089 * generate an indirection using the threadprivate common's
2090 * vector and then add the offset of this member. The
2091 * indirection will be of the form:
2092 * vector[_mp_lcpu3()]
2093 */
2094 int nm;
2095 int adr;
2096 ref_threadprivate(sdsc, &adr, &nm);
2097 acon = adr;
2098 } else if (IS_THREAD_TP(sdsc)) {
2099 /*
2100 * BASE is a threadprivate variable; generate an indirection using
2101 * the threadprivate's vector. The indirection will be of the form:
2102 * vector[_mp_lcpu3()]
2103 */
2104 int nm;
2105 int adr;
2106 ref_threadprivate_var(sdsc, &adr, &nm, 0);
2107 acon = adr;
2108 } else if (SCG(sdsc) == SC_BASED) {
2109 int anme;
2110 if (!MIDNUMG(sdsc)) {
2111 interr("based section descriptor has no pointer", sdsc, ERR_Fatal);
2112 }
2113 acon = mk_address(MIDNUMG(sdsc));
2114 anme = addnme(NT_VAR, sdsc, 0, 0);
2115 acon = ad2ili(IL_LDA, acon, anme);
2116 } else {
2117 acon = mk_address(sdsc);
2118 if (SCG(sdsc) == SC_DUMMY
2119 && is_currsub_dummy(sdsc)
2120 ) {
2121 SPTR asym = mk_argasym(sdsc);
2122 int anme = addnme(NT_VAR, asym, 0, 0);
2123 acon = ad2ili(IL_LDA, acon, anme);
2124 ADDRCAND(acon, anme);
2125 }
2126 }
2127 acon = ad3ili(IL_AADD, acon, ad_aconi(elmsz * (indx - 1)), scale);
2128 }
2129 if (elmsz == 8)
2130 ili = ad3ili(IL_LDKR, acon, compute_nme((SPTR)sdsc, indx, membase_nme), MSZ_I8);
2131 else
2132 ili = ad3ili(IL_LD, acon, compute_nme((SPTR)sdsc, indx, membase_nme), MSZ_WORD);
2133 return ili;
2134 }
2135
2136 static void
create_sdsc_subscr(int nmex,SPTR sptr,int nsubs,int * subs,DTYPE dtype,int ilix,int sdscilix)2137 create_sdsc_subscr(int nmex, SPTR sptr, int nsubs, int *subs, DTYPE dtype,
2138 int ilix, int sdscilix)
2139 {
2140 int i, fi;
2141 SPTR sdsc;
2142 int nme, ili1, ili2, ili3, ili4, ili5;
2143 int base = 0;
2144 int basenm = 0, basesym;
2145 ADSC *adp; /* array descriptor */
2146 SPTR sym = SPTR_NULL;
2147 int sub;
2148 ILM *ilmp1;
2149 int any_kr;
2150 int ptrexpand = 0;
2151
2152 adp = AD_DPTR(dtype);
2153
2154 /* useful information re: the storage class of sptr:
2155 * assumed shape => SC_LOCAL, pointer => SC_BASED,
2156 * allocatable => SC_BASED , automatic => SC_DUMMY
2157 */
2158
2159 sdsc = AD_SDSC(adp);
2160 assert(sdsc != 0, "create_sdsc_subscr: sdsc is zero", sdsc, ERR_Severe);
2161 PTRSAFEP(sdsc, 1);
2162
2163 /* this code duplicates much of what is done in compute_subscr(),
2164 * filling in the the subscr fields, except for subscr.zbase and
2165 * subscr.offset, which are different here due to the late
2166 * linearization of assumed shape and pointer arrays.
2167 */
2168
2169 subscr.nsubs = nsubs;
2170 subscr.zbase = 0;
2171 #if DEBUG
2172 assert(subscr.nsubs <= (sizeof(subscr.sub) / sizeof(int)),
2173 "create_sdsc_subscr:nsubs exceeded", subscr.nsubs, ERR_Severe);
2174 #endif
2175 subscr.eldt = DTySeqTyElement(dtype); /* element data type */
2176
2177 if (subscr.eldt != DT_ASSCHAR && subscr.eldt != DT_ASSNCHAR &&
2178 subscr.eldt != DT_DEFERCHAR && subscr.eldt != DT_DEFERNCHAR) {
2179 INT val;
2180 subscr.elmsz = ad_icon(size_of(subscr.eldt));
2181 subscr.scale = scale_of(subscr.eldt, &val);
2182 subscr.elmscz = ad_icon(val);
2183 } else if (subscr.eldt == DT_DEFERCHAR || subscr.eldt == DT_DEFERNCHAR) {
2184 /* defered-size character; size is in symtab */
2185 int bytes;
2186
2187 sym = sptr;
2188 if (ORIGDUMMYG(sym) && !XBIT(57, 0x80000)) {
2189 /* still using pghpf_ptr_in/out */
2190 sym = ORIGDUMMYG(sym);
2191 }
2192 #if DEBUG
2193 assert(STYPEG(sym) == ST_ARRAY,
2194 "compute_sdsc_subscr: DEFERCH sym not array", sym, ERR_Severe);
2195 #endif
2196 /* generate load of elem size */
2197 if (STYPEG(sym) == ST_MEMBER) {
2198 bytes = exp_get_sdsc_len(sym, ilix, NME_NM(nmex));
2199 } else
2200 bytes = exp_get_sdsc_len(sym, 0, 0);
2201 if (subscr.eldt == DT_DEFERNCHAR) { /* assumed size kanji dummy */
2202 bytes = kanji_bytes(bytes);
2203 }
2204 subscr.elmscz = subscr.elmsz = bytes;
2205 subscr.scale = 0;
2206 } else {
2207 /* assumed-size character; size is in symtab */
2208 int bytes;
2209
2210 sym = sptr;
2211 if (ORIGDUMMYG(sym) && !XBIT(57, 0x80000)) {
2212 /* still using pghpf_ptr_in/out */
2213 sym = ORIGDUMMYG(sym);
2214 }
2215 #if DEBUG
2216 assert(STYPEG(sym) == ST_ARRAY, "compute_sdsc_subscr: ASSCH sym not array",
2217 sym, ERR_Severe);
2218 #endif
2219 /* generate load of elem size */
2220 bytes = charlen(sym);
2221 if (subscr.eldt == DT_ASSNCHAR) /* assumed size kanji dummy */
2222 bytes = kanji_bytes(bytes);
2223 subscr.elmscz = subscr.elmsz = bytes;
2224 subscr.scale = 0;
2225 }
2226
2227 subscr.basenm = nmex;
2228 basesym = 0;
2229 if (NME_TYPE(subscr.basenm) == NT_IND) {
2230 int tmpnme = NME_NM(subscr.basenm);
2231 int tmpsym = NME_SYM(tmpnme);
2232 if ((gbl.outlined || ISTASKDUPG(GBL_CURRFUNC)) && PARREFG(tmpsym) &&
2233 !is_llvm_local_private(tmpsym))
2234 subscr.basenm = tmpnme;
2235 }
2236 if (subscr.basenm && NME_TYPE(subscr.basenm) == NT_VAR) {
2237 basenm = nmex;
2238 basesym = NME_SYM(subscr.basenm);
2239 /*
2240 * -Mcray=pointer could be in effect at this point; however,
2241 * if the pointee is a POINTER, the extra calculations are
2242 * still needed for
2243 * real,target :: arr(100)
2244 * real, pointer :: p(:)
2245 * p => arr(11:20)
2246 * With -Mcray=pointer, still need to check to see if ptrexpand
2247 * must be set.
2248 * Note that checks are similar to the PLD case, with the addition
2249 * of the NOCONFLICT check performed in expand.c (for facerec).
2250 */
2251 if (!XBIT(125, 0x400) && basesym && XBIT(58, 0x8000000) &&
2252 POINTERG(basesym) && !NOCONFLICTG(basesym))
2253 ptrexpand = 1;
2254 } else {
2255 /* ### */
2256 if (basesym && XBIT(58, 0x8000000) && POINTERG(basesym))
2257 ptrexpand = 1;
2258 if (nmex && NME_TYPE(nmex) == NT_MEM) {
2259 basenm = NME_NM(nmex);
2260 }
2261 }
2262
2263 /* record subscripts in subscr.sub[i] */
2264 any_kr = 0;
2265 if (XBIT(125, 0x20000))
2266 any_kr = 1;
2267 for (i = 0; i < subscr.nsubs; ++i) {
2268 sub = subs[i];
2269 subscr.sub[i] = subscr.osub[i] = sub;
2270 if (IL_RES(ILI_OPC(sub)) == ILIA_KR)
2271 any_kr = 1;
2272 }
2273 if (any_kr) {
2274 for (i = 0; i < subscr.nsubs; ++i) {
2275 subscr.sub[i] = ikmove(subscr.sub[i]);
2276 }
2277 }
2278
2279 subscr.base = ilix;
2280 base = 0;
2281
2282 /* is the sdsc of type ST_MEMBER? */
2283 if (STYPEG(sdsc) == ST_MEMBER) {
2284 /* find the base ILM and NME */
2285 base = sdscilix;
2286 assert(base, "compute_sdsc_subscr: base is NULL", base, ERR_Severe);
2287 }
2288
2289 /* compute the static descriptor linearized version of this
2290 * array reference.
2291 */
2292 if (!SDSCS1G(sdsc)) {
2293 if (!any_kr)
2294 ili1 = ad_icon(0);
2295 else
2296 ili1 = ad1ili(IL_KCON, stb.k0);
2297 fi = 0;
2298 } else {
2299 ili1 = subscr.sub[0];
2300 fi = 1;
2301 }
2302 for (i = fi; i < subscr.nsubs; ++i) {
2303 /* let DIM_x(i) be DESC_HDR_LEN + i*DESC_DIM_LEN + DESC_DIM_x
2304 * subscript term = subscr.sub[i] * sd[DIM_LMULT(i)]
2305 * if ptrexpand is set, the term is more complex:
2306 * subscript term =
2307 * (subscr.sub[i] * sd[DIM_SSTRIDE(i)] + sd[DIM_SOFFSET(i)]) *
2308 * sd[DIM_LMULT(i)]
2309 */
2310 ili2 = subscr.sub[i];
2311 ili4 = 0;
2312 ili5 = 0;
2313 if (XBIT(57, 0x10000) && basesym &&
2314 ((SCG(basesym) == SC_DUMMY && !POINTERG(basesym))
2315 #ifdef INLNARRG
2316 || (INLNARRG(basesym))
2317 #endif
2318 )) {
2319 SPTR m;
2320 int nme;
2321 m = AD_MLPYR(adp, i);
2322 ili3 = mk_address(m);
2323 nme = addnme(NT_VAR, m, 0, 0);
2324 if (DTYPEG(m) == DT_INT8)
2325 ili3 = ad3ili(IL_LDKR, ili3, nme, MSZ_I8);
2326 else
2327 ili3 = ad3ili(IL_LD, ili3, nme, MSZ_WORD);
2328 /* ### probably need to check this for ptrexpand, for inlined routines */
2329 } else {
2330 int j;
2331 if (ptrexpand) {
2332 if (!XBIT(58, 0x40000000)) {
2333 /* with section stride/offset */
2334 j = DESC_HDR_LEN + i * DESC_DIM_LEN + DESC_DIM_SSTRIDE;
2335 ili4 = get_sdsc_element(sdsc, j, base, basenm);
2336 j = DESC_HDR_LEN + i * DESC_DIM_LEN + DESC_DIM_SOFFSET;
2337 ili5 = get_sdsc_element(sdsc, j, base, basenm);
2338 }
2339 }
2340 /* the (i+1)st dimension subscript ili is located at subscr.sub[i] */
2341 j = DESC_HDR_LEN + i * DESC_DIM_LEN + DESC_DIM_LMULT;
2342 ili3 = get_sdsc_element(sdsc, j, base, basenm);
2343 }
2344 if (!any_kr) {
2345 if (!XBIT(58, 0x40000000)) {
2346 /* with section stride/offset */
2347 if (ptrexpand && ili5) {
2348 ili2 = ad2ili(IL_IMUL, ili2, ili4);
2349 ili2 = ad2ili(IL_IADD, ili2, ili5);
2350 }
2351 ili2 = ad2ili(IL_IMUL, ili2, ili3);
2352 } else {
2353 /* no section stride/offset */
2354 ili2 = ad2ili(IL_IMUL, ili2, ili3);
2355 if (ptrexpand && ili5) {
2356 ili2 = ad2ili(IL_IADD, ili2, ili5);
2357 }
2358 }
2359 ili1 = ad2ili(IL_IADD, ili1, ili2);
2360 } else {
2361 ili3 = ikmove(ili3);
2362 if (ptrexpand && ili5) {
2363 if (ili4)
2364 ili4 = ikmove(ili4);
2365 ili5 = ikmove(ili5);
2366 }
2367 if (!XBIT(58, 0x40000000)) {
2368 /* with section stride/offset */
2369 if (ptrexpand && ili5) {
2370 ili2 = ad2ili(IL_KMUL, ili2, ili4);
2371 ili2 = ad2ili(IL_KADD, ili2, ili5);
2372 }
2373 ili2 = ad2ili(IL_KMUL, ili2, ili3);
2374 } else {
2375 /* no section stride/offset */
2376 ili2 = ad2ili(IL_KMUL, ili2, ili3);
2377 if (ptrexpand && ili5) {
2378 ili2 = ad2ili(IL_KADD, ili2, ili5);
2379 }
2380 }
2381 ili1 = ad2ili(IL_KADD, ili1, ili2);
2382 }
2383 }
2384 /* offset is in ili1 */
2385 if (XBIT(57, 0x10000) && basesym &&
2386 ((SCG(basesym) == SC_DUMMY && !POINTERG(basesym))
2387 #ifdef INLNARRG
2388 || (INLNARRG(basesym))
2389 #endif
2390 )) {
2391 SPTR zbase;
2392 int nme;
2393 if (any_kr)
2394 ili1 = ikmove(ili1);
2395 /* the front end has folded the offset computation
2396 * for assumed-shape dummies into the ZBASE field */
2397 zbase = AD_ZBASE(adp);
2398 ili3 = mk_address(zbase);
2399 nme = addnme(NT_VAR, zbase, 0, 0);
2400 if (DTYPEG(zbase) == DT_INT8)
2401 ili3 = ad3ili(IL_LDKR, ili3, nme, MSZ_I8);
2402 else {
2403 ili3 = ad3ili(IL_LD, ili3, nme, MSZ_WORD);
2404 if (any_kr)
2405 ili3 = ikmove(ili3);
2406 }
2407 if (!any_kr) {
2408 ili1 = ad2ili(IL_IADD, ili1, ili3);
2409 } else {
2410 ili1 = ad2ili(IL_KADD, ili1, ili3);
2411 }
2412 subscr.offset = ili1;
2413 } else {
2414 /* add the lower bound - local base index offset folds in
2415 * amount so that zero-based references work. It's
2416 * located at $sd(DESC_HDR_LBASE).
2417 */
2418 ili3 = get_sdsc_element(sdsc, DESC_HDR_LBASE, base, basenm);
2419 if (!any_kr)
2420 subscr.offset = ad2ili(IL_IADD, ili1, ili3);
2421 else {
2422 ili3 = ikmove(ili3);
2423 subscr.offset = ad2ili(IL_KADD, ili1, ili3);
2424 }
2425 }
2426 if (!SDSCS1G(sdsc) && !CONTIGATTRG(basesym) && !XBIT(28, 0x20)) {
2427 /*
2428 * A pointer array may not be contiguous, so using the 'element'
2429 * size as the final multiplier is insufficient.
2430 * Define the multiplier to be the 'byte length' as stored in the
2431 * descriptor; this is the length between elements of the array
2432 * and is located at $sd(DESC_HDR_BYTE_LEN).
2433 */
2434 #ifdef SDSCCONTIGG
2435 if (!SDSCCONTIGG(sdsc))
2436 #endif
2437 {
2438 subscr.scale = 0;
2439 subscr.elmscz = get_sdsc_element(sdsc, DESC_HDR_BYTE_LEN, base, basenm);
2440 if (any_kr)
2441 subscr.elmscz = ikmove(subscr.elmscz);
2442 }
2443 if (subscr.zbase == 0) {
2444 if (any_kr)
2445 subscr.zbase = ad_kconi(1);
2446 else
2447 subscr.zbase = ad_icon(1);
2448 }
2449 } else if (subscr.zbase == 0) {
2450 if (any_kr)
2451 subscr.zbase = ad_kconi(1);
2452 else
2453 subscr.zbase = ad_icon(1);
2454 } else {
2455 subscr.zbase = ad2ili(IL_IADD, subscr.zbase, ad_icon(1));
2456 if (any_kr)
2457 subscr.zbase = ikmove(subscr.zbase);
2458 }
2459 }
2460
2461 /**
2462 * the current ilm is an INLELEM which is generated for the subscripted
2463 * references of the dummy arrays of a subprogram which has been inlined.
2464 * This ilm is used for cases where the name of the actual array cannot
2465 * be substituted (e.g., the dimensions change). The goal of this ilm
2466 * is to generate a subscript expression where the subscripts used for the
2467 * dummy array are folded into the first subscript of the actual array;
2468 * doing this allows the name's entry of the actual to be used.
2469 * Note that it's assumed that the data types of the actual & dummy arrays
2470 * match.
2471 *
2472 * This routine is recursive, where the subscripts are evaluated beginning
2473 * with the base reference (ELEMENT, BASE, or MEMBER ilms). Because of
2474 * multi-level inlining, it's possible to have a "list" of INLELEM ilms
2475 * which ultimately locates the base.
2476 */
2477 static void
inlarr(int curilm,DTYPE odtype,bool bigobj)2478 inlarr(int curilm, DTYPE odtype, bool bigobj)
2479 {
2480 ILM *ilmp;
2481 int nsubs; /* # subscripts */
2482 ADSC *adp; /* array descriptor */
2483 DTYPE dtype; /* array data type */
2484 int zbase; /* zbase sym/ili ptr */
2485 int i;
2486 SPTR sym;
2487 int sub, sub_1;
2488 int mplyr;
2489 int offset;
2490 int ili2;
2491 ISZ_T coffset;
2492 int nme;
2493 int tmp;
2494 bool any_kr;
2495 SPTR sdsc;
2496 int base, basenm;
2497 #if DEBUG
2498 FILE *dbgfil;
2499 #endif
2500
2501 ilmp = (ILM *)(ilmb.ilm_base + curilm);
2502
2503 switch (ILM_OPC(ilmp)) {
2504
2505 case IM_INLELEM:
2506 dtype = ILM_DTyOPND(ilmp, 3);
2507 inlarr(ILM_OPND(ilmp, 2), dtype, bigobj); /* compute subscr struct */
2508 nsubs = ILM_OPND(ilmp, 1);
2509 adp = AD_DPTR(dtype);
2510 #if DEBUG
2511 if (DBGBIT(49, 0x4000)) {
2512 dbgfil = stderr;
2513 if (gbl.dbgfil)
2514 dbgfil = gbl.dbgfil;
2515 fprintf(dbgfil, "INLELEM, %d=dtype\n", dtype);
2516 dumpdtype(dtype);
2517 }
2518 #endif
2519
2520 /* fold together the zero-base offsets of the actual and dummy */
2521 zbase = genload(AD_ZBASE(adp), bigobj); /* ili for zero-based offset */
2522 zbase = ad2ili(bigobj ? IL_KADD : IL_IADD, zbase, subscr.zbase);
2523 #if DEBUG
2524 if (DBGBIT(49, 0x4000)) {
2525 fprintf(dbgfil, "INLELEM, %d=initial zbase\n", zbase);
2526 dilitre(zbase);
2527 }
2528 #endif
2529 /*
2530 * calculate offset; first subscript begins with the ili of the
2531 * first subscript in subscr
2532 */
2533 coffset = 0;
2534 any_kr = bigobj;
2535 if (XBIT(125, 0x20000))
2536 any_kr = true;
2537 /*
2538 * scan the subscripts of the dummy, record them and sum up the
2539 * products of the subscripts and their multipliers. All subscripts
2540 * of the inlined reference are folded into the first subscript as
2541 * just an offset expression: (sum of s * m) - zbase, where s is
2542 * the subscript, m is the multiplier, zbase is the zero-base offset.
2543 */
2544 for (i = 0; i < subscr.nsubs; ++i) {
2545 sub = ILI_OF(ILM_OPND(ilmp, 4 + i)); /* subscript ili */
2546 subscr.sub[i] = subscr.osub[i] = sub;
2547 if (IL_RES(ILI_OPC(sub)) == ILIA_KR)
2548 any_kr = 1;
2549 }
2550 if (any_kr) {
2551 for (i = 0; i < subscr.nsubs; ++i) {
2552 subscr.sub[i] = ikmove(subscr.sub[i]);
2553 }
2554 }
2555 offset = sel_icnst(0, any_kr);
2556
2557 /*
2558 * if the first/left-most subscript is a constant, the initial value
2559 * of the constant offset is the subscript's value and the first
2560 * subscript must be set to 0.
2561 */
2562 sub_1 = subscr.sub[0];
2563 if (!XBIT(125, 0x4000) && IL_TYPE(ILI_OPC(sub_1)) == ILTY_CONS) {
2564 coffset = get_isz_cval(ILI_OPND(sub_1, 1));
2565 subscr.sub[0] = subscr.osub[0] = offset; /* the zero */
2566 }
2567
2568 for (i = 0; i < nsubs; ++i) {
2569 sub = subscr.sub[i]; /* subscript ili */
2570 mplyr = genload(AD_MLPYR(adp, i), bigobj); /* ili for multiplier */
2571 if (any_kr)
2572 mplyr = ikmove(mplyr);
2573 tmp = ad2ili(any_kr ? IL_KMUL : IL_IMUL, sub, mplyr); /* sub * m */
2574 sub_1 = ad2ili(any_kr ? IL_KADD : IL_IADD, sub_1, tmp);
2575 /* offset += sub * mplyr */
2576 if (ILI_OPC(mplyr) == IL_ICON) {
2577 if ((ILI_OPC(sub) == IL_IADD) &&
2578 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_ICON) {
2579 /*
2580 * subcript is of the form i + c, where c is a constant. the
2581 * value c*mlpyr is accumulated and i becomes sub.
2582 */
2583 coffset += CONVAL2G(ILI_OPND(ili2, 1)) * CONVAL2G(ILI_OPND(mplyr, 1));
2584 sub = ILI_OPND(sub, 1);
2585 } else if ((ILI_OPC(sub) == IL_ISUB) &&
2586 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_ICON) {
2587 /*
2588 * subcript is of the form i - c, where c is a constant. the
2589 * value c*mlpyr is accumulated and i becomes sub.
2590 */
2591 coffset -= CONVAL2G(ILI_OPND(ili2, 1)) * CONVAL2G(ILI_OPND(mplyr, 1));
2592 sub = ILI_OPND(sub, 1);
2593 } else if ((ILI_OPC(sub) == IL_KADD) &&
2594 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_KCON) {
2595 /*
2596 * subcript is of the form i + c, where c is a constant. the
2597 * value c*mlpyr is accumulated and i becomes sub.
2598 */
2599 coffset +=
2600 get_isz_cval(ILI_OPND(ili2, 1)) * CONVAL2G(ILI_OPND(mplyr, 1));
2601 sub = ILI_OPND(sub, 1);
2602 } else if ((ILI_OPC(sub) == IL_KSUB) &&
2603 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_KCON) {
2604 /*
2605 * subcript is of the form i - c, where c is a constant. the
2606 * value c*mlpyr is accumulated and i becomes sub.
2607 */
2608 coffset -=
2609 get_isz_cval(ILI_OPND(ili2, 1)) * CONVAL2G(ILI_OPND(mplyr, 1));
2610 sub = ILI_OPND(sub, 1);
2611 }
2612 } else if (ILI_OPC(mplyr) == IL_KCON) {
2613 if ((ILI_OPC(sub) == IL_KADD) &&
2614 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_KCON) {
2615 /*
2616 * subcript is of the form i + c, where c is a constant. the
2617 * value c*mlpyr is accumulated and i becomes sub.
2618 */
2619 coffset +=
2620 ad_val_of(ILI_OPND(ili2, 1)) * ad_val_of(ILI_OPND(mplyr, 1));
2621 sub = ILI_OPND(sub, 1);
2622 } else if ((ILI_OPC(sub) == IL_KSUB) &&
2623 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_KCON) {
2624 /*
2625 * subcript is of the form i - c, where c is a constant. the
2626 * value c*mlpyr is accumulated and i becomes sub.
2627 */
2628 coffset -=
2629 ad_val_of(ILI_OPND(ili2, 1)) * ad_val_of(ILI_OPND(mplyr, 1));
2630 sub = ILI_OPND(sub, 1);
2631 }
2632 }
2633 ili2 = ad2ili(any_kr ? IL_KMUL : IL_IMUL, sub, mplyr);
2634 offset = ad2ili(any_kr ? IL_KADD : IL_IADD, offset, ili2);
2635 }
2636 #if DEBUG
2637 if (DBGBIT(49, 0x4000)) {
2638 fprintf(dbgfil, "INLELEM, %d=offset, %d=coffset, %d=sub_1\n", offset,
2639 (int)coffset, sub_1);
2640 dilitre(offset);
2641 dilitre(sub_1);
2642 }
2643 #endif
2644 /*
2645 * update the zero-based offset, the subscript-offset expression,
2646 * and the first subscript
2647 */
2648 if (coffset)
2649 zbase =
2650 ad2ili(any_kr ? IL_KSUB : IL_ISUB, zbase, sel_icnst(coffset, any_kr));
2651 subscr.zbase = zbase;
2652 subscr.offset = ad2ili(any_kr ? IL_KADD : IL_IADD, offset,
2653 sel_iconv(subscr.offset, any_kr));
2654 tmp = genload(AD_ZBASE(adp), any_kr); /* ili for zero-based offset */
2655 sub_1 = ad2ili(any_kr ? IL_KSUB : IL_ISUB, sub_1, sel_iconv(tmp, any_kr));
2656 subscr.sub[0] = subscr.osub[0] = sub_1;
2657 #if DEBUG
2658 if (DBGBIT(49, 0x4000)) {
2659 fprintf(dbgfil, "INLELEM, %d=final zbase, %d=final offset, %d=sub[1]\n",
2660 zbase, subscr.offset, sub_1);
2661 dilitre(zbase);
2662 dilitre(subscr.offset);
2663 dilitre(sub_1);
2664 }
2665 #endif
2666 break;
2667 case IM_ELEMENT:
2668 dtype = ILM_DTyOPND(ilmp, 3);
2669 adp = AD_DPTR(dtype);
2670 if (!XBIT(52, 4) && AD_SDSC(adp)) {
2671 /* Assumed shape and pointer arrays have not been previously
2672 * linearized in terms of their sdsc. Do that now if necessary.
2673 */
2674 compute_sdsc_subscr(ilmp, bigobj);
2675 } else
2676 compute_subscr(ilmp, bigobj);
2677 break;
2678 case IM_BASE:
2679 sym = ILM_SymOPND(ilmp, 1);
2680 goto base_sym;
2681 case IM_PLD:
2682 sym = ILM_SymOPND(ilmp, 2);
2683 goto base_sym;
2684 case IM_MEMBER:
2685 sym = ILM_SymOPND(ilmp, 2);
2686 base_sym:
2687 /*
2688 * for a symbol-based reference (i.e., not an ELEMENT), extract all
2689 * information from the symbol. Since we know subscripts are necessary,
2690 * create a subscripted reference whose subscripts are the lower bounds
2691 * of the dimensions.
2692 */
2693 dtype = DTYPEG(sym);
2694 #if DEBUG
2695 assert(DTY(dtype) == TY_ARRAY, "inlarr:BASE/MEMBER-not TY_ARRAY", sym,
2696 ERR_Severe);
2697 #endif
2698 adp = AD_DPTR(dtype);
2699 sdsc = AD_SDSC(adp);
2700 PTRSAFEP(sdsc, 1);
2701 base = basenm = 0;
2702 if (STYPEG(sdsc) == ST_MEMBER) {
2703 ILM *basep;
2704 /* find the base ILM and NME */
2705 basep = (ILM *)(ilmb.ilm_base + ILM_OPND(ilmp, 2));
2706 assert(ILM_OPC(basep) == IM_PLD, "inlarr: not PLD", ILM_OPND(ilmp, 2),
2707 ERR_Severe);
2708 basep = (ILM *)(ilmb.ilm_base + ILM_OPND(basep, 1));
2709 assert(ILM_OPC(basep) == IM_MEMBER, "inlarr: not MEMBER",
2710 ILM_OPND(ilmp, 1), ERR_Severe);
2711 base = ILM_OPND(basep, 1);
2712 basenm = NME_OF(base);
2713 base = ILI_OF(base);
2714 assert(base, "inlarr: base is NULL", base, ERR_Severe);
2715 }
2716 #if DEBUG
2717 if (DBGBIT(49, 0x4000)) {
2718 dbgfil = stderr;
2719 if (gbl.dbgfil)
2720 dbgfil = gbl.dbgfil;
2721 fprintf(dbgfil, "INLSYM, %d=dtype\n", dtype);
2722 dumpdtype(dtype);
2723 }
2724 #endif
2725 subscr.eldt = DTySeqTyElement(dtype);
2726 if (subscr.eldt != DT_ASSCHAR && subscr.eldt != DT_ASSNCHAR &&
2727 subscr.eldt != DT_DEFERCHAR && subscr.eldt != DT_DEFERNCHAR) {
2728 ISZ_T val;
2729 int so;
2730 so = size_of(subscr.eldt);
2731 subscr.elmsz = sel_icnst(so, bigobj);
2732 subscr.scale = Scale_Of(subscr.eldt, &val);
2733 subscr.elmscz = sel_icnst(val, bigobj);
2734 }
2735 else if (subscr.eldt == DT_DEFERCHAR || subscr.eldt == DT_DEFERNCHAR) {
2736 /* deferred-size character; size is in sym */
2737 /* generate load of elem size */
2738 i = exp_get_sdsc_len(sym, base, basenm);
2739 if (subscr.eldt == DT_DEFERNCHAR) /* kanji-convert to byte units */
2740 i = ad2ili(IL_IMUL, i, ad_icon(2L));
2741 subscr.elmscz = subscr.elmsz = i;
2742 subscr.scale = 0;
2743 }
2744 else {
2745 /* assumed-size character; size is in sym */
2746 /* generate load of elem size */
2747 i = charlen(sym);
2748 if (subscr.eldt == DT_ASSNCHAR) /* kanji - convert to byte units */
2749 i = kanji_bytes(i);
2750 subscr.elmscz = subscr.elmsz = i;
2751 subscr.scale = 0;
2752 }
2753 subscr.basenm = NME_OF(curilm);
2754 subscr.base = ILI_OF(curilm);
2755 subscr.nsubs = nsubs = AD_NUMDIM(adp);
2756 /* calculate offset */
2757 offset = sel_icnst(0, bigobj);
2758 if (!XBIT(52, 4) && sdsc) {
2759 if (!SDSCS1G(sdsc) && !XBIT(28, 0x20)) {
2760 subscr.zbase = sel_icnst(0, bigobj);
2761 } else {
2762 subscr.zbase = sel_icnst(0, bigobj);
2763 for (i = 0; i < nsubs; ++i) {
2764 int v;
2765 v = DESC_HDR_LEN + i * DESC_DIM_LEN + DESC_DIM_LOWER;
2766 sub = get_sdsc_element(sdsc, v, base, basenm);
2767 subscr.sub[i] = subscr.osub[i] = sub;
2768 }
2769 }
2770 offset = sel_icnst(0, bigobj);
2771 #if DEBUG
2772 if (DBGBIT(49, 0x4000)) {
2773 fprintf(dbgfil, "INLSYM, %d=sdsc offset\n", offset);
2774 dilitre(offset);
2775 }
2776 #endif
2777 } else if (CCSYMG(sym) && odtype) {
2778 ADSC *oadp; /* array descriptor */
2779 oadp = AD_DPTR(odtype);
2780 /* use the bounds from the original datatype */
2781 for (i = 0; i < nsubs; ++i) {
2782 sub = genload((SPTR)AD_LWBD(oadp, i), bigobj); /* lwb is subscript */
2783 subscr.sub[i] = subscr.osub[i] = sub;
2784 }
2785 subscr.zbase = sel_icnst(0, bigobj);
2786 offset = sel_icnst(0, bigobj);
2787 #if DEBUG
2788 if (DBGBIT(49, 0x4000)) {
2789 fprintf(dbgfil, "INLSYM, %d=ccsym zbase, %d=offset\n", subscr.zbase,
2790 offset);
2791 dilitre(subscr.zbase);
2792 dilitre(offset);
2793 }
2794 #endif
2795 } else
2796 {
2797 subscr.zbase = genload(AD_ZBASE(adp), bigobj);
2798 for (i = 0; i < nsubs; ++i) {
2799
2800 sub = genload((SPTR)AD_LWBD(adp, i), bigobj); /* lwb is subscript */
2801 subscr.sub[i] = subscr.osub[i] = sub;
2802 mplyr = genload((SPTR)AD_MLPYR(adp, i), bigobj); /* ili for multiplier */
2803 /* offset += sub * mplyr */
2804 offset = ad2ili(bigobj ? IL_KADD : IL_IADD, offset,
2805 ad2ili(bigobj ? IL_KMUL : IL_IMUL, sub, mplyr));
2806 }
2807 }
2808 subscr.offset = offset;
2809 break;
2810
2811 default:
2812 interr("inlarr:bad ilmopc", ILM_OPC(ilmp), ERR_Severe);
2813 }
2814 }
2815
2816 static int
finish_array(bool bigobj,bool inl_flg)2817 finish_array(bool bigobj, bool inl_flg)
2818 {
2819 int nme, i, sub, ili1, ili2, ili3, base;
2820 bool constant_zbase;
2821 int over_subscr;
2822 nme = subscr.basenm;
2823 over_subscr = 0;
2824 if (NME_TYPE(subscr.basenm) == NT_ARR) {
2825 /* over-subscripted; more subsripts than rank */
2826 over_subscr = 1;
2827 }
2828 NME_OVS(nme) = over_subscr;
2829 for (i = 0; i < subscr.nsubs; ++i) {
2830 sub = subscr.osub[i];
2831 if (IL_TYPE(ILI_OPC(sub)) == ILTY_CONS)
2832 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, ad_val_of(ILI_OPND(sub, 1)), sub, inl_flg);
2833 else
2834 nme = add_arrnme(NT_ARR, NME_NULL, nme, (INT)0, sub, inl_flg);
2835 NME_OVS(nme) = over_subscr;
2836 }
2837 constant_zbase = false;
2838 if (XBIT(70, 0x4000000) || (IL_TYPE(ILI_OPC(subscr.zbase)) == ILTY_CONS &&
2839 IL_TYPE(ILI_OPC(subscr.elmscz)) == ILTY_CONS))
2840 constant_zbase = true;
2841 if (constant_zbase) {
2842 /* base = (array_base - (zbase - coffset) * size) <scaled by> scale */
2843 ili1 = ikmove(subscr.zbase);
2844 ili2 = ikmove(subscr.elmscz);
2845 ili2 = ad2ili(IL_KMUL, ili1, ili2);
2846 ili2 = ad1ili(IL_KAMV, ili2);
2847 base = ad3ili(IL_ASUB, subscr.base, ili2, subscr.scale);
2848 } else if (IL_TYPE(ILI_OPC(subscr.elmscz)) == ILTY_CONS) {
2849 if ((ILI_OPC(subscr.zbase) == IL_IADD) &&
2850 ILI_OPC(ili2 = ILI_OPND(subscr.zbase, 2)) == IL_ICON) {
2851 /*
2852 * zbase is of the form i + c, where c is a constant.
2853 * Restructure so that:
2854 * zbase <- i
2855 * base <= base - c*elmsz
2856 * ....
2857 */
2858 subscr.zbase = ILI_OPND(subscr.zbase, 1);
2859 ili2 = ad2ili(IL_IMUL, ili2, subscr.elmscz);
2860 ili2 = ad1ili(IL_IAMV, ili2);
2861 base = ad3ili(IL_ASUB, subscr.base, ili2, subscr.scale);
2862 } else if ((ILI_OPC(subscr.zbase) == IL_ISUB) &&
2863 ILI_OPC(ili2 = ILI_OPND(subscr.zbase, 2)) == IL_ICON) {
2864 /*
2865 * zbase is of the form i - c, where c is a constant.
2866 * Restructure so that:
2867 * zbase <- i
2868 * base <= base + c*elmsz
2869 * ....
2870 */
2871 subscr.zbase = ILI_OPND(subscr.zbase, 1);
2872 ili2 = ad2ili(IL_IMUL, ili2, subscr.elmscz);
2873 ili2 = ad1ili(IL_IAMV, ili2);
2874 base = ad3ili(IL_AADD, subscr.base, ili2, subscr.scale);
2875 } else if ((ILI_OPC(subscr.zbase) == IL_KADD) &&
2876 ILI_OPC(ili2 = ILI_OPND(subscr.zbase, 2)) == IL_KCON) {
2877 /*
2878 * zbase is of the form i + c, where c is a constant.
2879 * Restructure so that:
2880 * zbase <- i
2881 * base <= base - c*elmsz
2882 * ....
2883 */
2884 subscr.zbase = ILI_OPND(subscr.zbase, 1);
2885 ili2 = ad2ili(IL_KMUL, ili2, subscr.elmscz);
2886 ili2 = ad1ili(IL_KAMV, ili2);
2887 base = ad3ili(IL_ASUB, subscr.base, ili2, subscr.scale);
2888 } else if ((ILI_OPC(subscr.zbase) == IL_KSUB) &&
2889 ILI_OPC(ili2 = ILI_OPND(subscr.zbase, 2)) == IL_KCON) {
2890 /*
2891 * zbase is of the form i - c, where c is a constant.
2892 * Restructure so that:
2893 * zbase <- i
2894 * base <= base + c*elmsz
2895 * ....
2896 */
2897 subscr.zbase = ILI_OPND(subscr.zbase, 1);
2898 ili2 = ad2ili(IL_KMUL, ili2, subscr.elmscz);
2899 ili2 = ad1ili(IL_KAMV, ili2);
2900 base = ad3ili(IL_AADD, subscr.base, ili2, subscr.scale);
2901 } else {
2902 base = subscr.base;
2903 }
2904 } else {
2905 base = subscr.base;
2906 }
2907
2908 /*-
2909 * compute the final address of the reference. Generate:
2910 * (0) isub offset zbase !constant_zbase
2911 * (1) imul offset size(ili1)
2912 * (2) damv (1)
2913 * (3) aadd base (2) scale
2914 */
2915 if (IL_RES(ILI_OPC(subscr.offset)) == ILIA_KR || bigobj) {
2916 ili2 = ikmove(subscr.elmscz);
2917 if (constant_zbase) {
2918 ili1 = ikmove(subscr.offset);
2919 } else {
2920 ili1 = ad2ili(IL_KSUB, ikmove(subscr.offset), ikmove(subscr.zbase));
2921 }
2922 ili2 = ad2ili(IL_KMUL, ili1, ili2);
2923 ili2 = ad1ili(IL_KAMV, ili2);
2924 } else {
2925 if (constant_zbase) {
2926 ili1 = subscr.offset;
2927 } else {
2928 ili1 = kimove(subscr.zbase);
2929 ili1 = ad2ili(IL_ISUB, subscr.offset, ili1);
2930 }
2931 ili2 = ad2ili(IL_IMUL, ili1, subscr.elmscz);
2932 ili2 = ad1ili(IL_IAMV, ili2);
2933 }
2934
2935 ili3 = ad3ili(IL_AADD, base, ili2, subscr.scale);
2936 subscr.finalnme = nme;
2937 return ili3;
2938 } /* finish_array */
2939
2940 void
exp_array(ILM_OP opc,ILM * ilmp,int curilm)2941 exp_array(ILM_OP opc, ILM *ilmp, int curilm)
2942 {
2943 int ili1;
2944 int ili3;
2945 int nme;
2946 bool inl_flg, bigobj;
2947 DTYPE dtype;
2948 ADSC *adp;
2949
2950 #if DEBUG
2951 assert(opc == IM_ELEMENT || opc == IM_INLELEM, "exp_array: opc not ELEMENT",
2952 opc, ERR_Severe);
2953 #endif
2954
2955 if (XBIT(125, 0x10000)) {
2956 int subs[7], i;
2957 int arrilm;
2958 DTYPE dtype;
2959 SPTR sym;
2960 ILM *ilma;
2961 arrilm = ILM_OPND(ilmp, 2);
2962 dtype = ILM_DTyOPND(ilmp, 3);
2963 ilma = (ILM *)(ilmb.ilm_base + arrilm);
2964 if (ILM_OPC(ilma) == IM_PLD) {
2965 /* rewritten arguments */
2966 sym = ILM_SymOPND(ilma, 2);
2967 if (ORIGDUMMYG(sym)) {
2968 sym = ORIGDUMMYG(sym);
2969 }
2970 } else {
2971 #if DEBUG
2972 assert(ILM_OPC(ilma) == IM_BASE || ILM_OPC(ilma) == IM_ELEMENT,
2973 "exp_array: ASSCH/DEFERCH array not base", arrilm, ERR_Severe);
2974 #endif
2975 sym = ILM_SymOPND(ilma, 1); /* symbol pointer */
2976 }
2977 subscr.nsubs = ILM_OPND(ilmp, 1);
2978 for (i = 0; i < subscr.nsubs; ++i) {
2979 subs[i] = ILI_OF(ILM_OPND(ilmp, 4 + i)); /* subscript ili */
2980 }
2981 if (opc == IM_ELEMENT) {
2982 inl_flg = false;
2983 } else {
2984 inl_flg = true;
2985 }
2986 ILI_OF(curilm) = create_array_ref(NME_OF(arrilm), sym, dtype, subscr.nsubs,
2987 subs, ILI_OF(arrilm), 0, inl_flg, &nme);
2988 NME_OF(curilm) = nme;
2989 if (DTY(subscr.eldt) == TY_CHAR || DTY(subscr.eldt) == TY_NCHAR) {
2990 ILM_RESTYPE(curilm) = ILM_ISCHAR;
2991 if (DTY(subscr.eldt) == TY_NCHAR) /* kanji char type ... */
2992 /* value represented by subscr.elmsz is twice too large: */
2993 ILM_CLEN(curilm) = kanji_divide(subscr.elmsz);
2994 else
2995 ILM_CLEN(curilm) = subscr.elmsz;
2996
2997 if (DTySeqTyElement(subscr.eldt) == DT_NONE)
2998 ILM_MXLEN(curilm) = 0;
2999 else
3000 ILM_MXLEN(curilm) = ILM_CLEN(curilm); /*subscr.elmsz;*/
3001 }
3002 return;
3003 }
3004
3005 bigobj = XBIT(68, 0x1);
3006 /* ELEMENT nsubs array-lval dtype subs+ */
3007 /* INLEMEN nsubs array-lval dtype subs+ */
3008
3009 if (opc == IM_ELEMENT) {
3010 dtype = ILM_DTyOPND(ilmp, 3);
3011 adp = AD_DPTR(dtype);
3012 if (!XBIT(52, 4) && AD_SDSC(adp)) {
3013 /* Assumed shape and pointer arrays have not been previously
3014 * linearized in terms of their sdsc. Do that now if necessary.
3015 */
3016 compute_sdsc_subscr(ilmp, bigobj);
3017 } else
3018 compute_subscr(ilmp, bigobj);
3019 inl_flg = false;
3020 } else {
3021 inlarr(curilm, DT_NONE, bigobj);
3022 inl_flg = true;
3023 }
3024
3025 ili3 = finish_array(bigobj, inl_flg);
3026 nme = subscr.finalnme;
3027 if (DTY(subscr.eldt) == TY_CHAR || DTY(subscr.eldt) == TY_NCHAR) {
3028 ILM_RESTYPE(curilm) = ILM_ISCHAR;
3029 ili1 = kimove(subscr.elmsz);
3030 if (DTY(subscr.eldt) == TY_NCHAR) /* kanji char type ... */
3031 /* value represented by subscr.elmsz is twice too large: */
3032 ILM_CLEN(curilm) = kanji_divide(subscr.elmsz);
3033 else
3034 ILM_CLEN(curilm) = ili1;
3035
3036 if (DTySeqTyElement(subscr.eldt) == DT_NONE)
3037 ILM_MXLEN(curilm) = 0;
3038 else
3039 ILM_MXLEN(curilm) = ILM_CLEN(curilm); /*subscr.elmsz;*/
3040 }
3041
3042 NME_OF(curilm) = nme;
3043 ILI_OF(curilm) = ili3;
3044 }
3045
3046 /**
3047 * \brief create an array reference given the array and subscripts
3048 */
3049 static void
create_array_subscr(int nmex,SPTR sym,DTYPE dtype,int nsubs,int * subs,int ilix)3050 create_array_subscr(int nmex, SPTR sym, DTYPE dtype, int nsubs, int *subs,
3051 int ilix)
3052 {
3053 ADSC *adp; /* array descriptor */
3054 int zbase; /* zbase sym/ili ptr */
3055 int i;
3056 ILM *ilmp1;
3057 int sub;
3058 int mplyr;
3059 int offset;
3060 int ili2;
3061 ISZ_T coffset;
3062 int any_kr;
3063 int sub_1, osub_1;
3064 bool bigobj = false;
3065
3066 subscr.nsubs = nsubs;
3067 #if DEBUG
3068 assert(subscr.nsubs <= (sizeof(subscr.sub) / sizeof(int)),
3069 "create_array_subscr:nsubs exceeded", subscr.nsubs, ERR_Severe);
3070 #endif
3071 if (XBIT(68, 0x1))
3072 bigobj = true;
3073 adp = AD_DPTR(dtype);
3074 zbase = genload(AD_ZBASE(adp), bigobj); /* ili for zero-based offset */
3075 subscr.eldt = DTySeqTyElement(dtype); /* element data type */
3076
3077 /*-
3078 * use scale_of to get the multiplier -- this is in two forms:
3079 * val = number of units to scale
3080 * scale = scaling factor of the subscript
3081 */
3082
3083 if (subscr.eldt != DT_ASSCHAR && subscr.eldt != DT_ASSNCHAR &&
3084 subscr.eldt != DT_DEFERCHAR && subscr.eldt != DT_DEFERNCHAR) {
3085 INT val;
3086 subscr.elmsz = ad_icon(size_of(subscr.eldt));
3087 subscr.scale = scale_of(subscr.eldt, &val);
3088 subscr.elmscz = ad_icon(val);
3089 }
3090 else if (subscr.eldt == DT_DEFERCHAR || subscr.eldt == DT_DEFERNCHAR) {
3091 /* defered-size character; size is in symtab */
3092 int bytes;
3093 #if DEBUG
3094 assert((STYPEG(sym) == ST_ARRAY ||
3095 (STYPEG(sym) == ST_MEMBER && subscr.eldt == DT_DEFERCHAR)),
3096 "create_array_subscr: DEFERCH sym not array", sym, ERR_Severe);
3097 #endif
3098 /* generate load of elem size */
3099 if (STYPEG(sym) == ST_MEMBER) {
3100 bytes = exp_get_sdsc_len(sym, ilix, NME_OF(nmex));
3101 } else
3102 bytes = exp_get_sdsc_len(sym, 0, 0);
3103 if (subscr.eldt == DT_DEFERNCHAR) /* assumed size kanji dummy */
3104 bytes = kanji_bytes(bytes);
3105 subscr.elmscz = subscr.elmsz = bytes;
3106 subscr.scale = 0;
3107 }
3108 else {
3109 /* assumed-size character; size is in symtab */
3110 int bytes;
3111 #if DEBUG
3112 assert(STYPEG(sym) == ST_ARRAY, "create_array_subscr: ASSCH sym not array",
3113 sym, ERR_Severe);
3114 #endif
3115 /* generate load of elem size */
3116 bytes = charlen(sym);
3117 if (subscr.eldt == DT_ASSNCHAR) /* assumed size kanji dummy */
3118 bytes = kanji_bytes(bytes);
3119 subscr.elmscz = subscr.elmsz = bytes;
3120 subscr.scale = 0;
3121 }
3122
3123 /* calculate offset */
3124 coffset = 0;
3125 subscr.basenm = nmex;
3126 any_kr = 0;
3127 if (XBIT(125, 0x20000))
3128 any_kr = 1;
3129 for (i = 0; i < subscr.nsubs; ++i) {
3130 sub = subs[i]; /* subscript ili */
3131 subscr.sub[i] = subscr.osub[i] = sub;
3132 if (!bigobj && IL_RES(ILI_OPC(sub)) == ILIA_KR)
3133 any_kr = 1;
3134 }
3135 if (any_kr || bigobj) {
3136 for (i = 0; i < subscr.nsubs; ++i) {
3137 subscr.sub[i] = ikmove(subscr.sub[i]);
3138 }
3139 }
3140 offset = sel_icnst(0, any_kr);
3141
3142 /*
3143 * if the first/left-most subscript is a constant, the initial value
3144 * of the constant offset is the subscript's value and the first
3145 * subscript must be set to 0.
3146 */
3147 sub_1 = subscr.sub[0];
3148 osub_1 = subscr.osub[0];
3149 if (!XBIT(125, 0x4000) && IL_TYPE(ILI_OPC(sub_1)) == ILTY_CONS) {
3150 coffset = get_isz_cval(ILI_OPND(sub_1, 1));
3151 subscr.sub[0] = subscr.osub[0] = offset; /* the zero */
3152 }
3153
3154 for (i = 0; i < subscr.nsubs; ++i) {
3155 sub = subscr.sub[i]; /* subscript ili */
3156 if (!bigobj) {
3157 /* ili for multiplier */
3158 mplyr = genload(AD_MLPYR(adp, i), false);
3159 /* offset += sub * mplyr */
3160 if (ILI_OPC(mplyr) == IL_ICON) {
3161 if ((ILI_OPC(sub) == IL_IADD) &&
3162 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_ICON) {
3163 /*
3164 * subcript is of the form i + c, where c is a constant. the
3165 * value c*mlpyr is accumulated and i becomes sub.
3166 */
3167 coffset += CONVAL2G(ILI_OPND(ili2, 1)) * CONVAL2G(ILI_OPND(mplyr, 1));
3168 sub = ILI_OPND(sub, 1);
3169 } else if ((ILI_OPC(sub) == IL_ISUB) &&
3170 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_ICON) {
3171 /*
3172 * subscript is of the form i - c, where c is a constant. the
3173 * value c*mlpyr is accumulated and i becomes sub.
3174 */
3175 coffset -= CONVAL2G(ILI_OPND(ili2, 1)) * CONVAL2G(ILI_OPND(mplyr, 1));
3176 sub = ILI_OPND(sub, 1);
3177 } else if ((ILI_OPC(sub) == IL_KADD) &&
3178 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_KCON) {
3179 /*
3180 * subcript is of the form i + c, where c is a constant. the
3181 * value c*mlpyr is accumulated and i becomes sub.
3182 */
3183 coffset +=
3184 get_isz_cval(ILI_OPND(ili2, 1)) * CONVAL2G(ILI_OPND(mplyr, 1));
3185 sub = ILI_OPND(sub, 1);
3186 } else if ((ILI_OPC(sub) == IL_KSUB) &&
3187 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_KCON) {
3188 /*
3189 * subscript is of the form i - c, where c is a constant. the
3190 * value c*mlpyr is accumulated and i becomes sub.
3191 */
3192 coffset -=
3193 get_isz_cval(ILI_OPND(ili2, 1)) * CONVAL2G(ILI_OPND(mplyr, 1));
3194 sub = ILI_OPND(sub, 1);
3195 }
3196 }
3197 if (!any_kr) {
3198 ili2 = ad2ili(IL_IMUL, sub, mplyr);
3199 offset = ad2ili(IL_IADD, offset, ili2);
3200 } else {
3201 ili2 = ad1ili(IL_IKMV, mplyr);
3202 ili2 = ad2ili(IL_KMUL, sub, ili2);
3203 if (IL_TYPE(ILI_OPC(ili2)) == ILTY_CONS &&
3204 IL_TYPE(ILI_OPC(sub)) != ILTY_CONS) {
3205 subscr.sub[i] = subscr.osub[i] = ili2;
3206 }
3207 offset = ad2ili(IL_KADD, offset, ili2);
3208 }
3209 } else {
3210 /* ili for multiplier */
3211 mplyr = genload(AD_MLPYR(adp, i), true);
3212 if (ILI_OPC(mplyr) == IL_KCON) {
3213 if ((ILI_OPC(sub) == IL_KADD) &&
3214 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_KCON) {
3215 /*
3216 * subcript is of the form i + c, where c is a constant. the
3217 * value c*mlpyr is accumulated and i becomes sub.
3218 */
3219 coffset +=
3220 ad_val_of(ILI_OPND(ili2, 1)) * ad_val_of(ILI_OPND(mplyr, 1));
3221 sub = ILI_OPND(sub, 1);
3222 } else if ((ILI_OPC(sub) == IL_KSUB) &&
3223 ILI_OPC(ili2 = ILI_OPND(sub, 2)) == IL_KCON) {
3224 /*
3225 * subscript is of the form i - c, where c is a constant. the
3226 * value c*mlpyr is accumulated and i becomes sub.
3227 */
3228 coffset -=
3229 ad_val_of(ILI_OPND(ili2, 1)) * ad_val_of(ILI_OPND(mplyr, 1));
3230 sub = ILI_OPND(sub, 1);
3231 }
3232 }
3233 ili2 = ad2ili(IL_KMUL, sub, mplyr);
3234 if (IL_TYPE(ILI_OPC(ili2)) == ILTY_CONS &&
3235 IL_TYPE(ILI_OPC(sub)) != ILTY_CONS) {
3236 subscr.sub[i] = subscr.osub[i] = ili2;
3237 }
3238 offset = ad2ili(IL_KADD, offset, ili2);
3239 }
3240 }
3241 /*
3242 * Eventually, offset will multiplied by the element size. Check the
3243 * offset for the pattern 'i + c' or 'i - c', if the size is a constant.
3244 * The constant part can be folded into coffset; note that this is
3245 * without the multiply since the caller of compute_subscr() will perform
3246 * the multiply by the element size.
3247 */
3248 mplyr = subscr.elmscz; /* ili for multiplier */
3249 if (IL_TYPE(ILI_OPC(mplyr)) == ILTY_CONS) {
3250 if ((ILI_OPC(offset) == IL_IADD) &&
3251 ILI_OPC(ili2 = ILI_OPND(offset, 2)) == IL_ICON) {
3252 /*
3253 * offset is of the form i + c, where c is a constant. the
3254 * value c is accumulated and i becomes offset.
3255 */
3256 coffset += CONVAL2G(ILI_OPND(ili2, 1));
3257 offset = ILI_OPND(offset, 1);
3258 } else if ((ILI_OPC(offset) == IL_ISUB) &&
3259 ILI_OPC(ili2 = ILI_OPND(offset, 2)) == IL_ICON) {
3260 /*
3261 * offset is of the form i - c, where c is a constant. the
3262 * value c is accumulated and i becomes offset.
3263 */
3264 coffset -= CONVAL2G(ILI_OPND(ili2, 1));
3265 offset = ILI_OPND(offset, 1);
3266 } else if ((ILI_OPC(offset) == IL_KADD) &&
3267 ILI_OPC(ili2 = ILI_OPND(offset, 2)) == IL_KCON) {
3268 /*
3269 * offset is of the form i + c, where c is a constant. the
3270 * value c is accumulated and i becomes offset.
3271 */
3272 coffset += get_isz_cval(ILI_OPND(ili2, 1));
3273 offset = ILI_OPND(offset, 1);
3274 } else if ((ILI_OPC(offset) == IL_KSUB) &&
3275 ILI_OPC(ili2 = ILI_OPND(offset, 2)) == IL_KCON) {
3276 /*
3277 * offset is of the form i - c, where c is a constant. the
3278 * value c is accumulated and i becomes offset.
3279 */
3280 coffset -= get_isz_cval(ILI_OPND(ili2, 1));
3281 offset = ILI_OPND(offset, 1);
3282 }
3283 }
3284
3285 /* base = (array_base - (zbase - coffset) * size) <scaled by> scale */
3286
3287 if (coffset) {
3288 if (!bigobj)
3289 zbase = ad2ili(IL_ISUB, zbase, ad_icon(coffset));
3290 else
3291 zbase = ad2ili(IL_KSUB, zbase, ad_kconi(coffset));
3292 }
3293 subscr.zbase = zbase;
3294 subscr.offset = offset;
3295 subscr.base = ilix;
3296 subscr.sub[0] = sub_1;
3297 subscr.osub[0] = osub_1;
3298 } /* create_array_subscr */
3299
3300 int
create_array_ref(int nmex,SPTR sptr,DTYPE dtype,int nsubs,int * subs,int ilix,int sdscilix,int inline_flag,int * pnme)3301 create_array_ref(int nmex, SPTR sptr, DTYPE dtype, int nsubs, int *subs,
3302 int ilix, int sdscilix, int inline_flag, int *pnme)
3303 {
3304 int base;
3305 int ili1;
3306 int ili2;
3307 int ili3;
3308 int nme;
3309 int i;
3310 int sub;
3311 bool bigobj = false, usek = false;
3312 ADSC *adp;
3313 bool constant_zbase;
3314
3315 adp = AD_DPTR(dtype);
3316 if (!XBIT(52, 4) && AD_SDSC(adp)) {
3317 /* Assumed shape and pointer arrays have not been previously
3318 * linearized in terms of their sdsc. Do that now if necessary.
3319 */
3320 create_sdsc_subscr(nmex, sptr, nsubs, subs, dtype, ilix, sdscilix);
3321 } else
3322 {
3323 create_array_subscr(nmex, sptr, dtype, nsubs, subs, ilix);
3324 }
3325
3326 nme = nmex;
3327 for (i = 0; i < subscr.nsubs; ++i) {
3328 sub = subscr.osub[i];
3329 if (IL_TYPE(ILI_OPC(sub)) == ILTY_CONS) {
3330 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, ad_val_of(ILI_OPND(sub, 1)), sub,
3331 inline_flag);
3332 } else {
3333 nme = add_arrnme(NT_ARR, NME_NULL, nme, (INT)0, sub, inline_flag);
3334 }
3335 }
3336
3337 if (XBIT(68, 0x1))
3338 bigobj = true;
3339 usek = true;
3340 constant_zbase = false;
3341 if (!bigobj &&
3342 (XBIT(70, 0x4000000) || (IL_TYPE(ILI_OPC(subscr.zbase)) == ILTY_CONS &&
3343 IL_TYPE(ILI_OPC(subscr.elmscz)) == ILTY_CONS)))
3344 constant_zbase = true;
3345 if (!bigobj && !constant_zbase) {
3346 base = subscr.base;
3347 } else {
3348 /* base = (array_base - (zbase - coffset) * size) <scaled by> scale */
3349 if (bigobj || usek || IL_RES(ILI_OPC(subscr.zbase)) == ILIA_KR) {
3350 ili1 = ikmove(subscr.zbase);
3351 ili2 = ikmove(subscr.elmscz);
3352 ili2 = ad2ili(IL_KMUL, ili1, ili2);
3353 ili2 = ad1ili(IL_KAMV, ili2);
3354 } else {
3355 ili2 = ad2ili(IL_IMUL, subscr.zbase, subscr.elmscz);
3356 ili2 = ad1ili(IL_IAMV, ili2);
3357 }
3358 base = ad3ili(IL_ASUB, subscr.base, ili2, subscr.scale);
3359 }
3360
3361 /*-
3362 * compute the final address of the reference. Generate:
3363 * (0) isub offset zbase !constant_zbase && !bigobj
3364 * (1) imul offset size(ili1)
3365 * (2) damv (1)
3366 * (3) aadd base (2) scale
3367 */
3368 if (bigobj) {
3369 ili2 = ad2ili(IL_KMUL, subscr.offset, ikmove(subscr.elmscz));
3370 ili2 = ad1ili(IL_KAMV, ili2);
3371 } else if (IL_RES(ILI_OPC(subscr.offset)) == ILIA_KR) {
3372 ili1 = subscr.offset;
3373 if (!constant_zbase) {
3374 ili1 = ad2ili(IL_KSUB, ili1, ikmove(subscr.zbase));
3375 }
3376 ili2 = ad2ili(IL_KMUL, ili1, ikmove(subscr.elmscz));
3377 ili2 = ad1ili(IL_KAMV, ili2);
3378 } else {
3379 ili1 = subscr.offset;
3380 if (!constant_zbase) {
3381 ili1 = ad2ili(IL_ISUB, ili1, kimove(subscr.zbase));
3382 }
3383 ili2 = ad2ili(IL_IMUL, ili1, subscr.elmscz);
3384 ili2 = ad1ili(IL_IAMV, ili2);
3385 }
3386
3387 ili1 = ad3ili(IL_AADD, base, ili2, subscr.scale);
3388
3389 if (pnme)
3390 *pnme = nme;
3391 return ili1;
3392 } /* create_array_ref */
3393
3394 /***************************************************************/
3395
3396 static bool
simple_ili(int ilix)3397 simple_ili(int ilix)
3398 {
3399 int opc;
3400
3401 opc = ILI_OPC(ilix);
3402 if (IL_TYPE(opc) == ILTY_CONS)
3403 return true;
3404 if (IL_TYPE(opc) == ILTY_LOAD && !func_in(ilix))
3405 return true;
3406 return false;
3407 }
3408
3409 void
exp_bran(ILM_OP opc,ILM * ilmp,int curilm)3410 exp_bran(ILM_OP opc, ILM *ilmp, int curilm)
3411 {
3412 static struct {
3413 ILI_OP jmpop; /* aif jump op */
3414 ILI_OP cseop; /* aif cse op */
3415 DTYPE dtype; /* data type */
3416 ILI_OP stop; /* store op */
3417 ILI_OP ldop; /* load op */
3418 ILI_OP cmpop; /* compare with 0 op */
3419 ILI_OP subop; /* subtract op */
3420 ILI_OP cjmpop; /* compare and jump op */
3421 short msz; /* msz for load/store */
3422 } aif[5] = {
3423 {IL_ICJMPZ, IL_CSEIR, DT_INT, IL_ST, IL_LD, IL_ICMPZ, IL_ISUB, IL_ICJMP,
3424 MSZ_WORD},
3425 {IL_FCJMPZ, IL_CSESP, DT_REAL, IL_STSP, IL_LDSP, IL_FCMPZ, IL_FSUB,
3426 IL_FCJMP, MSZ_F4},
3427 {IL_DCJMPZ, IL_CSEDP, DT_DBLE, IL_STDP, IL_LDDP, IL_DCMPZ, IL_DSUB,
3428 IL_DCJMP, MSZ_F8},
3429 {IL_KCJMPZ, IL_CSEKR, DT_INT8, IL_STKR, IL_LDKR, IL_KCMPZ, IL_KSUB,
3430 IL_KCJMP, MSZ_I8},
3431 };
3432 int i; /* temp */
3433 int ilix; /* ILI index */
3434 int sym1;
3435 int sym2, sym3;
3436 int type;
3437 SPTR sym;
3438 int save, ililnk, nme;
3439 int op1;
3440 ILM *ilmpx;
3441
3442 #define BR_TRUE(t, i, c, s) \
3443 ad3ili(Get_expb_logcjmp(), ad2ili(aif[t].cmpop, i, c), CC_NE, s)
3444
3445 switch (opc) {
3446 case IM_CGOTO: /* computed goto */
3447 exp_cgoto(ilmp, curilm);
3448 break;
3449
3450 case IM_AGOTO: /* assigned goto */
3451 exp_agoto(ilmp, curilm);
3452 break;
3453
3454 case IM_KAIF: /* integer*8 arithmetic IF */
3455 type = 4;
3456 goto comaif;
3457 case IM_IAIF: /* integer arithmetic IF */
3458 type = 0;
3459 goto comaif;
3460 case IM_RAIF: /* real arithmetic IF */
3461 type = 1;
3462 goto comaif;
3463 case IM_DAIF: /* double arithmetic IF */
3464 type = 2;
3465 comaif:
3466 /* arithmetic if processing */
3467 ilix = ILM_RESULT(ILM_OPND(ilmp, 1));
3468 sym1 = ILM_OPND(ilmp, 2);
3469 sym2 = ILM_OPND(ilmp, 3);
3470 sym3 = ILM_OPND(ilmp, 4);
3471 if (sym1 == sym2) {
3472 RFCNTD(sym1);
3473 if (sym1 == sym3) { /* all are equal */
3474 RFCNTD(sym1);
3475 ilix = ad1ili(IL_JMP, sym1);
3476 } else {
3477 /* if <= goto sym1 */
3478 ilix = BR_TRUE(type, ilix, CC_LE, sym1);
3479 if (ilix)
3480 chk_block(ilix);
3481 ilix = ad1ili(IL_JMP, sym3);
3482 }
3483 } else if (sym1 == sym3) {
3484 /* if != goto sym1 */
3485 RFCNTD(sym1);
3486 ilix = BR_TRUE(type, ilix, CC_NE, sym1);
3487 if (ilix)
3488 chk_block(ilix);
3489 ilix = ad1ili(IL_JMP, sym2);
3490 } else if (sym2 == sym3) {
3491 /* if >= goto sym2 */
3492 RFCNTD(sym2);
3493 ilix = BR_TRUE(type, ilix, CC_GE, sym2);
3494 if (ilix)
3495 chk_block(ilix);
3496 ilix = ad1ili(IL_JMP, sym1);
3497 } else { /* all are different */
3498 if (flg.opt == 1) {
3499 /* Just add multiple branches of the if expression which is
3500 * asserted to be a common subexpression via the CSE ili.
3501 */
3502 save = ilix;
3503 /* if < goto sym1 */
3504 ilix = ad3ili(aif[type].jmpop, ilix, CC_LT, sym1);
3505 if (ilix)
3506 chk_block(ilix);
3507 ilix = ad1ili(aif[type].cseop, save);
3508 /* if = goto sym2 */
3509 ilix = ad3ili(aif[type].jmpop, ilix, CC_EQ, sym2);
3510 if (ilix)
3511 chk_block(ilix);
3512 ilix = ad1ili(IL_JMP, sym3);
3513 } else {
3514 /* For the I386, always create multiple blocks; asserted cse
3515 * opportunities are problematic across branches because of the
3516 * floating point stack. The code generator may not pop the
3517 * stack for the first conditional.
3518 * For other targets, make multiple blocks for opt 0 & opt >= 2.
3519 * in general, generate:
3520 * tmp = expr;
3521 * if (tmp < 0) goto lab1;
3522 * if (tmp == 0) goto lab2;
3523 * goto lab3;
3524 */
3525 int load;
3526 int op1, op2;
3527
3528 /* special case:
3529 * if (x - y) l1, l2, l3 becomes
3530 * if (x .lt. y) goto l1
3531 * if (x .eq. y) goto l2
3532 * goto l3
3533 * where
3534 * x & y are "simple"
3535 */
3536 if (ILI_OPC(ilix) == aif[type].subop &&
3537 simple_ili(op1 = ILI_OPND(ilix, 1)) &&
3538 simple_ili(op2 = ILI_OPND(ilix, 2))) {
3539 /* if x < y goto sym1 */
3540 ilix = ad4ili(aif[type].cjmpop, op1, op2, CC_LT, sym1);
3541 if (ilix)
3542 chk_block(ilix);
3543 /* if x = y goto sym2 */
3544 ilix = ad4ili(aif[type].cjmpop, op1, op2, CC_EQ, sym2);
3545 if (ilix)
3546 chk_block(ilix);
3547 ilix = ad1ili(IL_JMP, sym3);
3548 if (ilix)
3549 chk_block(ilix);
3550 break;
3551 }
3552 if (simple_ili(ilix))
3553 /* don't need to temp store if arith if expr is simple */
3554 load = ilix;
3555 else {
3556 sym = mkrtemp_sc(ilix, expb.sc);
3557 nme = addnme(NT_VAR, sym, 0, 0);
3558 DTYPEP(sym, aif[type].dtype);
3559 ililnk = ad_acon(sym, 0);
3560 ilix = ad4ili(aif[type].stop, ilix, ililnk, nme, aif[type].msz);
3561 load = ad3ili(aif[type].ldop, ililnk, nme, aif[type].msz);
3562 chk_block(ilix);
3563 }
3564 /* if < goto sym1 */
3565 ilix = ad3ili(aif[type].jmpop, load, CC_LT, sym1);
3566 if (ilix)
3567 chk_block(ilix);
3568 /* if = goto sym2 */
3569 ilix = ad3ili(aif[type].jmpop, load, CC_EQ, sym2);
3570 if (ilix)
3571 chk_block(ilix);
3572 ilix = ad1ili(IL_JMP, sym3);
3573 }
3574 }
3575 if (ilix)
3576 chk_block(ilix);
3577 break;
3578
3579 case IM_BRF:
3580 /*
3581 * .OP ICJMPZ null p1 eq v2
3582 * .OP LCJMPZ null p1 eq v2
3583 */
3584 sym1 = CC_EQ;
3585 goto logcjmp_;
3586
3587 case IM_BRT:
3588 /*
3589 * .OP ICJMPZ null p1 ne v2
3590 * .OP LCJMPZ null p1 ne v2
3591 */
3592 sym1 = CC_NE;
3593 logcjmp_:
3594 sym = ILM_SymOPND(ilmp, 2);
3595 if (CCSYMG(sym) == 0) {
3596 /* refd but not defd */
3597 }
3598 op1 = ILM_OPND(ilmp, 1);
3599 ilix = ILM_RESULT(op1);
3600 ilmpx = (ILM *)(ilmb.ilm_base + op1);
3601 switch (ILM_OPC(ilmpx)) {
3602 case IM_EQ8:
3603 case IM_NE8:
3604 case IM_LT8:
3605 case IM_GE8:
3606 case IM_LE8:
3607 case IM_GT8:
3608 if (ILI_OPC(ilix) == IL_IKMV)
3609 ilix = ILI_OPND(ilix, 1);
3610 break;
3611 default:
3612 break;
3613 }
3614 if (IL_RES(ILI_OPC(ilix)) == ILIA_KR) {
3615 if (XBIT(125, 0x8)) {
3616 /* -Munixlogical */
3617 ilix = ad2ili(IL_KCMPZ, ilix, sym1);
3618 sym1 = CC_NE;
3619 }
3620 }
3621 if ((ilix = ad3ili(Get_expb_logcjmp(), ilix, sym1, sym)) != 0)
3622 chk_block(ilix);
3623 break;
3624
3625 default: /* this code is same as for C */
3626 i = ILM_OPND(ilmp, ilms[opc].oprs); /* get label */
3627 if (CCSYMG(i) == 0) {
3628 /* refd but not defd */
3629 }
3630 if ((ilix = exp_mac(opc, ilmp, curilm)) != 0)
3631 chk_block(ilix);
3632 break;
3633 }
3634 }
3635
3636 /***************************************************************/
3637
3638 void
exp_misc(ILM_OP opc,ILM * ilmp,int curilm)3639 exp_misc(ILM_OP opc, ILM *ilmp, int curilm)
3640 {
3641 int tmp;
3642 int ilix, listilix;
3643 int nme;
3644 int lpcnt;
3645 SPTR sym;
3646 char lbl[32];
3647 SPTR s;
3648 int i;
3649 int pragmatype, pragmascope, pragmanargs, pragmaarg, pragmasym, devarg,
3650 argili;
3651 int parentnmex, parentilix;
3652 static int hostsptr = 0, devsptr = 0;
3653 static int blocknest, gridnest, kernelnest;
3654 int ilmx;
3655 ILM *ilmpx;
3656
3657 switch (opc) {
3658 case IM_NOP: /* skip to next ILM */
3659 break;
3660
3661 case IM_BOS:
3662 expb.ilm_words += expb.nilms - BOS_SIZE;
3663 expb.curlin = ILM_OPND(ilmp, 1);
3664 if (expb.curlin) {
3665 gbl.lineno = expb.curlin;
3666
3667 /* per flyspray 15632, we want to get the line number correctly
3668 for higher optimization. Blocks are merged into ENLAB
3669 block until there is a branch. We want to get a line
3670 number of the next block if the current block does not
3671 have ilt.
3672 */
3673 if (expb.curilt == 0 && BIH_ENLAB(expb.curbih))
3674 BIH_LINENO(expb.curbih) = expb.curlin;
3675 }
3676
3677 expb.arglcnt.next = expb.arglcnt.start;
3678
3679 if (expb.flags.bits.noblock) {
3680 /*
3681 * no bih exists - create one with no ilts and set its line
3682 * number field
3683 */
3684 cr_block();
3685 /*
3686 * if no entry header has been written yet, then this BOS
3687 * is the first one for the subprogram. create the entry
3688 * header for this subprogram; passing 0 to begin_entry/exp_header
3689 * indicates that the entry symbol (an unnamed program,
3690 * program, subroutine, or function) is retrieved from
3691 * gbl.currsub
3692 */
3693 if (expb.flags.bits.noheader) {
3694 begin_entry(SPTR_NULL);
3695 expb.flags.bits.noheader = 0;
3696 }
3697 } else if (flg.opt == 0) {
3698
3699 /*
3700 * since the opt level is zero, the current block is written out
3701 * provided that the current block is not empty, or already has a
3702 * line number or label. A new one is created with no ilts with
3703 * its line number field set.
3704 */
3705 if (expb.curilt != 0 || BIH_LINENO(expb.curbih) != 0 ||
3706 BIH_LABEL(expb.curbih) != 0) {
3707 wr_block();
3708 cr_block();
3709 } else {
3710 BIH_LINENO(expb.curbih) = expb.curlin;
3711 expb.curlin = 0;
3712 }
3713 } else if (expb.ilm_words > expb.ilm_thresh) {
3714 /* prevent merge of this block at opt >= 2 */
3715 BIH_NOMERGE(expb.curbih) = 1;
3716 if (expb.curilt || expb.flags.bits.waitlbl) {
3717 flsh_block();
3718 if (expb.flags.bits.noblock)
3719 cr_block();
3720 }
3721 }
3722 mkrtemp_init();
3723 hostsptr = 0;
3724 devsptr = 0;
3725 break;
3726
3727 case IM_ENTRY:
3728 /* process an entry defined by the ENTRY statement */
3729 begin_entry(ILM_SymOPND(ilmp, 1));
3730 break;
3731
3732 case IM_ENLAB:
3733 #if !defined(TARGET_OSX)
3734 sprintf(lbl, "..EN%d_%d", gbl.func_count, entry_sptr);
3735 #else
3736 sprintf(lbl, "L.EN%d_%d", gbl.func_count, entry_sptr);
3737 #endif
3738 s = getsym(lbl, strlen(lbl));
3739 STYPEP(s, ST_LABEL);
3740 RFCNTP(s, 1);
3741 exp_label(s);
3742 BIH_ENLAB(expb.curbih) = 1;
3743 CCSYMP(s, 1);
3744
3745 break;
3746
3747 case IM_LABEL:
3748 exp_label(ILM_SymOPND(ilmp, 1));
3749 break;
3750
3751 case IM_ESTMT:
3752 exp_estmt(ILI_OF(ILM_OPND(ilmp, 1)));
3753 break;
3754
3755 case IM_ARET:
3756 tmp = ILM_RESULT(ILM_OPND(ilmp, 1));
3757 store_aret(tmp);
3758 goto ret_shared;
3759
3760 case IM_RET:
3761 if (gbl.arets) {
3762 tmp = ad_icon((INT)0);
3763 store_aret(tmp);
3764 }
3765 /*
3766 * generate a jump to the return label which is common to the
3767 * function
3768 */
3769 ret_shared:
3770 if (expb.retlbl == 0) {
3771 /*
3772 * this is the first return ILM seen for this function:
3773 */
3774 expb.retlbl = getccsym('R', expb.retcnt++, ST_LABEL);
3775 }
3776 RFCNTI(expb.retlbl);
3777 chk_block(ad1ili(IL_JMP, expb.retlbl));
3778 break;
3779
3780 case IM_ENDF:
3781 exp_end(ilmp, curilm, true);
3782 break;
3783
3784 case IM_END:
3785 exp_end(ilmp, curilm, false);
3786 break;
3787
3788 case IM_BYVAL:
3789 ilmx = ILM_OPND(ilmp, 1); /* operand being passed */
3790 ilmpx = (ILM *)(ilmb.ilm_base + ilmx);
3791 if (ILM_OPC(ilmpx) == IM_DPVAL) {
3792 ilmx = ILM_OPND(ilmpx, 1); /* operand of the %val() */
3793 ILM_OPND(ilmp, 1) = ilmx;
3794 }
3795 /* now defer it */
3796 break;
3797 case IM_DPSCON:
3798 case IM_DPVAL:
3799 case IM_DPREF:
3800 case IM_DPREF8:
3801 case IM_DPNULL:
3802 /* defer these */
3803 break;
3804 #ifdef IM_DOBEGNZ
3805 case IM_DOBEGNZ:
3806 lpcnt = ILM_RESULT(ILM_OPND(ilmp, 1)); /* fetch loop count */
3807 if (expb.isguarded <= 0) {
3808 lpcnt = ILM_RESULT(ILM_OPND(ilmp, 4));
3809 tmp = ad3ili(IL_ICJMPZ, lpcnt, CC_NE, (int)ILM_OPND(ilmp, 2));
3810 if (tmp) {
3811 chk_block(tmp);
3812 expb.isguarded++;
3813 }
3814 } else {
3815 expb.isguarded++;
3816 }
3817 if (expb.isguarded == 1) {
3818 BIH_GUARDER(expb.curbih) = 1;
3819 } else if (expb.isguarded) {
3820 BIH_GUARDEE(expb.curbih) = 1;
3821 sym = (SPTR) ILM_OPND(ilmp, 2);
3822 RFCNTD(sym);
3823 }
3824 expb.curlin = gbl.lineno; /* ensure next ilm (LABEL) gets line #*/
3825 break;
3826 #endif
3827
3828 case IM_DOBEG:
3829 /* fetch loop count */
3830 lpcnt = ILM_RESULT(ILM_OPND(ilmp, 1));
3831 /* For zero-trip loops, test the loop count and generate a branch to the
3832 * zero-trip label it's less than or equal to zero. "Check" the block, but
3833 * watch out for branches that are no-op'd. Note that we don't emit a cse
3834 * of the loop count; a load is better suited for tracking the store's uses.
3835 */
3836 if (!flg.onetrip) {
3837 /* address of count var */
3838 sym = ILM_SymOPND(ilmp, 3);
3839 if (IL_TYPE(ILI_OPC(lpcnt)) != ILTY_CONS) {
3840 ilix = mk_address(sym);
3841 nme = addnme(NT_VAR, sym, 0, (INT)0);
3842 if (DTYPEG(sym) == DT_INT8)
3843 lpcnt = ad3ili(IL_LDKR, ilix, nme, MSZ_I8);
3844 else
3845 lpcnt = ad3ili(IL_LD, ilix, nme, MSZ_WORD);
3846 ADDRCAND(lpcnt, nme);
3847 }
3848 if (DTYPEG(sym) == DT_INT8)
3849 tmp = ad3ili(IL_KCJMPZ, lpcnt, CC_LE, ILM_OPND(ilmp, 2));
3850 else
3851 tmp = ad3ili(IL_ICJMPZ, lpcnt, CC_LE, ILM_OPND(ilmp, 2));
3852 if (tmp)
3853 chk_block(tmp);
3854 }
3855 expb.curlin = gbl.lineno; /* ensure next ilm (LABEL) gets line #*/
3856 break;
3857
3858 #ifdef IM_DOENDNZ
3859 case IM_DOENDNZ:
3860 if (expb.isguarded)
3861 expb.isguarded--;
3862 if (BIH_LABEL(expb.curbih) && RFCNTG(BIH_LABEL(expb.curbih)) == 0) {
3863 ILIBLKP(BIH_LABEL(expb.curbih), 0);
3864 BIH_LABEL(expb.curbih) = SPTR_NULL;
3865 }
3866
3867 #endif
3868 case IM_DOEND:
3869 /* for address of count variable */
3870 sym = ILM_SymOPND(ilmp, 2);
3871 ilix = mk_address(sym);
3872 nme = addnme(NT_VAR, sym, 0, 0);
3873 /*
3874 * generate the decrement of the loop count variable
3875 */
3876 if (DTYPEG(sym) == DT_INT8) {
3877 lpcnt = ad3ili(IL_LDKR, ilix, nme, MSZ_I8);
3878 ADDRCAND(lpcnt, nme);
3879 lpcnt = ad2ili(IL_KSUB, lpcnt, ad1ili(IL_KCON, stb.k1));
3880 tmp = ad4ili(IL_STKR, lpcnt, ilix, nme, MSZ_I8);
3881 ADDRCAND(tmp, nme);
3882 chk_block(tmp);
3883 /*
3884 * generate compare and branch ILI against zero which branches to the top
3885 * of the loop if still greater than zero. Also, if at opt 2 and the loop
3886 * is a zero-trip loop, set the zero-trip flag of the block (BIH) defined
3887 * by the loop top label.
3888 */
3889 /* assertion: should be safe with respect to optimizations to use a load
3890 * of the loop count variable instead of a cse of the rhs of the store; if
3891 * not, change ilix to ad_cse(lpcnt).
3892 */
3893 tmp = ad3ili(IL_KCJMPZ, ad3ili(IL_LDKR, ilix, nme, MSZ_I8), CC_GT,
3894 (int)ILM_OPND(ilmp, 1));
3895 } else
3896 {
3897 lpcnt = ad3ili(IL_LD, ilix, nme, MSZ_WORD);
3898 ADDRCAND(lpcnt, nme);
3899 lpcnt = ad2ili(IL_ISUB, lpcnt, ad1ili(IL_ICON, stb.i1));
3900 tmp = ad4ili(IL_ST, lpcnt, ilix, nme, MSZ_WORD);
3901 ADDRCAND(tmp, nme);
3902 chk_block(tmp);
3903 /*
3904 * generate compare and branch ILI against zero which branches to the top
3905 * of the loop if still greater than zero. Also, if at opt 2 and the loop
3906 * is a zero-trip loop, set the zero-trip flag of the block (BIH) defined
3907 * by the loop top label.
3908 */
3909 /* assertion: should be safe with respect to optimizations to use a load
3910 * of the loop count variable instead of a cse of the rhs of the store; if
3911 * not, change ilix to ad_cse(lpcnt).
3912 */
3913 tmp = ad3ili(IL_ICJMPZ, ad3ili(IL_LD, ilix, nme, MSZ_WORD), CC_GT,
3914 (int)ILM_OPND(ilmp, 1));
3915 }
3916 chk_block(tmp);
3917 if (!flg.onetrip && flg.opt >= 2 && opc != IM_DOENDNZ)
3918 BIH_ZTRP(ILIBLKG(ILM_OPND(ilmp, 1))) = 1;
3919 if (*(SYMNAME(sym)+2) == 'C')
3920 BIH_DOCONC(ILIBLKG(ILM_OPND(ilmp, 1))) = 1;
3921 break;
3922
3923 case IM_ADJARR:
3924 sym = ILM_SymOPND(ilmp, 1);
3925 #if DEBUG
3926 assert(STYPEG(sym) == ST_ENTRY, "exp_misc: not ST_ENTRY in ilm", curilm,
3927 ERR_Severe);
3928 #endif
3929 if (AFTENTG(sym)) {
3930 tmp = ad1ili(IL_JMP, (int)ILM_OPND(ilmp, 2));
3931 chk_block(tmp);
3932 if (sym == gbl.currsub)
3933 /* for ENTRYs, "branch around" label is used as "return" */
3934 exp_label(ILM_SymOPND(ilmp, 3));
3935 }
3936 break;
3937
3938 case IM_VFENTER:
3939 /* label vf "function" */
3940 exp_label(ILM_SymOPND(ilmp, 1));
3941 ilix = ad1ili(IL_VFENTER, vf_addr); /* enter "function" */
3942 chk_block(ilix);
3943 break;
3944 case IM_VFRET:
3945 ilix = ILI_OF(ILM_OPND(ilmp, 1)); /* return value */
3946 ilix = ad2ili(IL_VFEXIT, vf_addr, ilix); /* leave "function" */
3947 chk_block(ilix);
3948 break;
3949
3950 case IM_CMSIZE:
3951 /* common block symbol */
3952 sym = ILM_SymOPND(ilmp, 1);
3953 #if DEBUG
3954 assert(STYPEG(sym) == ST_CMBLK, "exp_misc: CMSIZE not cmblk", sym,
3955 ERR_Severe);
3956 #endif
3957 ilix = ad_kconi(SIZEG(sym));
3958 ILM_RESULT(curilm) = ilix;
3959 break;
3960
3961 #ifdef IM_PARG
3962 case IM_PARG:
3963 /* defer to exp_rte */
3964 break;
3965 #endif
3966
3967 case IM_PREFETCH:
3968 ilix = ILI_OF(ILM_OPND(ilmp, 1)); /* address */
3969 nme = NME_OF(ILM_OPND(ilmp, 1));
3970 if (XBIT(39, 0x4000) && TEST_MACH(MACH_AMD_HAMMER)) {
3971 ilix = ad3ili(IL_PREFETCHT0, ilix, 0, nme);
3972 } else if (TEST_MACH(MACH_AMD_HAMMER)) {
3973 ilix = ad3ili(IL_PREFETCHNTA, ilix, 0, NME_UNK);
3974 } else if (TEST_MACH(MACH_AMD)) {
3975 ilix = ad3ili(IL_PREFETCH, ilix, 0, nme); /* Athlon */
3976 } else {
3977 ilix = ad3ili(IL_PREFETCHNTA, ilix, 0, nme); /* PIII+ sse */
3978 }
3979 chk_block(ilix);
3980 break;
3981 case IM_FARG:
3982 ILM_CLEN(curilm) = ILM_CLEN(ILM_OPND(ilmp, 1));
3983 ILM_RESULT(curilm) = ILM_RESULT(ILM_OPND(ilmp, 1));
3984 ILM_RESTYPE(curilm) = ILM_RESTYPE(ILM_OPND(ilmp, 1));
3985 break;
3986 case IM_FARGF:
3987 ILM_CLEN(curilm) = ILM_CLEN(ILM_OPND(ilmp, 1));
3988 ILM_RESULT(curilm) = ILM_RESULT(ILM_OPND(ilmp, 1));
3989 ILM_RESTYPE(curilm) = ILM_RESTYPE(ILM_OPND(ilmp, 1));
3990 break;
3991 case IM_BBND:
3992 break;
3993 #if defined(IM_FILE)
3994 case IM_FILE:
3995 /* PGF90 only */
3996 if (!XBIT(6, 0x40000) && fihb.currfindex != ILM_OPND(ilmp, 2)) {
3997 /* start a new block */
3998 wr_block();
3999 cr_block();
4000 }
4001 if (fihb.nextfindex != ILM_OPND(ilmp, 2) ||
4002 fihb.nextftag < ILM_OPND(ilmp, 3)) {
4003 fihb.nextfindex = ILM_OPND(ilmp, 2);
4004 fihb.nextftag = ILM_OPND(ilmp, 3);
4005 if (ILT_NEXT(0) == 0) {
4006 /* no ILTs yet */
4007 fihb.currftag = fihb.nextftag;
4008 fihb.currfindex = fihb.nextfindex;
4009 gbl.findex = fihb.nextfindex;
4010 }
4011 }
4012 break;
4013 #endif
4014 case IM_PRAGMASYM:
4015 case IM_PRAGMASLIST:
4016 pragmanargs = ILM_OPND(ilmp, 1);
4017 pragmatype = ILM_OPND(ilmp, 2);
4018 pragmascope = ILM_OPND(ilmp, 3);
4019 switch (pragmatype) {
4020 }
4021 break;
4022 case IM_PRAGMASYMEXPR:
4023 case IM_PRAGMASELIST:
4024 pragmanargs = ILM_OPND(ilmp, 1);
4025 pragmatype = ILM_OPND(ilmp, 2);
4026 pragmascope = ILM_OPND(ilmp, 3);
4027 pragmaarg = ILM_OPND(ilmp, 4);
4028 pragmasym = 0;
4029 parentilix = 0;
4030 parentnmex = 0;
4031 devarg = 0;
4032 argili = 0;
4033 if (opc == IM_PRAGMASELIST
4034 ) {
4035 ILM *ilmp1;
4036 int arg, depth;
4037 /* pragmaarg is an ILM pointer to the IM_BASE of the symbol */
4038 arg = pragmaarg;
4039 ilmp1 = (ILM *)(ilmb.ilm_base + arg);
4040 while (ILM_OPC(ilmp1) == IM_ELEMENT) {
4041 /* can come from inlining */
4042 arg = ILM_OPND(ilmp1, 2);
4043 ilmp1 = (ILM *)(ilmb.ilm_base + arg);
4044 }
4045 argili = ILI_OF(arg);
4046 switch (ILM_OPC(ilmp1)) {
4047 case IM_PLD:
4048 case IM_MEMBER:
4049 pragmasym = ILM_OPND(ilmp1, 2);
4050 break;
4051 case IM_BASE:
4052 pragmasym = ILM_OPND(ilmp1, 1);
4053 break;
4054 default:
4055 if (IM_TYPE(ILM_OPC(ilmp1)) == IMTY_CONS)
4056 return; /* substituted by inlining? */
4057 interr("pragma: bad ilmopc", ILM_OPC(ilmp1), ERR_Severe);
4058 pragmasym = 0;
4059 }
4060 depth = 0;
4061 while (arg > 1) {
4062 ILM *argilm = (ILM *)(ilmb.ilm_base + arg);
4063 switch (ILM_OPC(argilm)) {
4064 case IM_PLD:
4065 if (depth == 0) {
4066 arg = ILM_OPND(argilm, 1);
4067 } else {
4068 parentilix = ILI_OF(arg);
4069 parentnmex = NME_OF(arg);
4070 arg = 0;
4071 }
4072 break;
4073 case IM_MEMBER:
4074 ++depth;
4075 if (depth == 1) {
4076 arg = ILM_OPND(argilm, 1);
4077 } else {
4078 parentilix = ILI_OF(arg);
4079 parentnmex = NME_OF(arg);
4080 arg = 0;
4081 }
4082 break;
4083 case IM_ELEMENT:
4084 parentilix = ILI_OF(arg);
4085 parentnmex = NME_OF(arg);
4086 arg = 0;
4087 break;
4088 case IM_BASE:
4089 parentilix = ILI_OF(arg);
4090 parentnmex = NME_OF(arg);
4091 arg = 0;
4092 break;
4093 }
4094 }
4095 }
4096 if (pragmasym == hostsptr)
4097 devarg = devsptr;
4098 break;
4099 case IM_PRAGMAEXPR:
4100 pragmanargs = ILM_OPND(ilmp, 1);
4101 pragmatype = ILM_OPND(ilmp, 2);
4102 pragmascope = ILM_OPND(ilmp, 3);
4103 pragmaarg = ILM_OPND(ilmp, 4);
4104 switch (pragmatype) {
4105 case PR_ACCVECTOR:
4106 break;
4107 case PR_ACCGANG:
4108 break;
4109 case PR_ACCGANGDIM:
4110 break;
4111 case PR_ACCGANGCHUNK:
4112 break;
4113 case PR_ACCWORKER:
4114 break;
4115 case PR_ACCAUTO:
4116 break;
4117 case PR_ACCPARALLEL:
4118 break;
4119 case PR_ACCSEQ:
4120 break;
4121 case PR_ACCHOST:
4122 break;
4123 case PR_ACCDEVICEID:
4124 break;
4125 case PR_ACCIF:
4126 break;
4127 case PR_ACCASYNC:
4128 break;
4129 case PR_ACCNUMWORKERS:
4130 break;
4131 case PR_ACCNUMGANGS:
4132 break;
4133 case PR_ACCNUMGANGS2:
4134 break;
4135 case PR_ACCNUMGANGS3:
4136 break;
4137 case PR_ACCVLENGTH:
4138 break;
4139 case PR_ACCSEQUNROLL:
4140 break;
4141 case PR_ACCPARUNROLL:
4142 break;
4143 case PR_ACCVECUNROLL:
4144 break;
4145 case PR_ACCUNROLL:
4146 break;
4147 case PR_KERNEL_BLOCK:
4148 break;
4149 case PR_KERNEL_GRID:
4150 break;
4151 case PR_KERNEL_NEST:
4152 break;
4153 case PR_KERNEL_STREAM:
4154 break;
4155 case PR_KERNEL_DEVICE:
4156 break;
4157 case PR_ACCWAITARG:
4158 break;
4159 }
4160 break;
4161 case IM_PRAGMAGEN:
4162 pragmanargs = ILM_OPND(ilmp, 1);
4163 pragmatype = ILM_OPND(ilmp, 2);
4164 pragmascope = ILM_OPND(ilmp, 3);
4165 pragmaarg = ILM_OPND(ilmp, 4);
4166 switch (pragmatype) {
4167 case PR_ACCEL:
4168 break;
4169 case PR_ENDACCEL:
4170 break;
4171 case PR_ACCKERNELS:
4172 break;
4173 case PR_ACCENDKERNELS:
4174 break;
4175 case PR_ACCPARCONSTRUCT:
4176 break;
4177 case PR_ACCENDPARCONSTRUCT:
4178 break;
4179 case PR_ACCSCALARREG:
4180 break;
4181 case PR_ACCENDSCALARREG:
4182 break;
4183 case PR_ACCSERIAL:
4184 break;
4185 case PR_ACCENDSERIAL:
4186 break;
4187 case PR_ACCDATAREG:
4188 break;
4189 case PR_ACCIMPDATAREG:
4190 break;
4191 case PR_ACCIMPDATAREGX:
4192 break;
4193 case PR_ACCENDDATAREG:
4194 break;
4195 case PR_ACCENDIMPDATAREG:
4196 break;
4197 case PR_ACCENTERDATA:
4198 break;
4199 case PR_ACCEXITDATA:
4200 break;
4201 case PR_ACCFINALEXITDATA:
4202 break;
4203 case PR_ACCBEGINDIR:
4204 break;
4205 case PR_ACCELLP:
4206 break;
4207 case PR_ACCKLOOP:
4208 break;
4209 case PR_ACCTKLOOP:
4210 break;
4211 case PR_ACCPLOOP:
4212 break;
4213 case PR_ACCTPLOOP:
4214 break;
4215 case PR_ACCSLOOP:
4216 case PR_ACCTSLOOP:
4217 /* don't need anything at this for the a
4218 * loop clause in a serial construct */
4219 break;
4220 case PR_ACCUPDATE:
4221 break;
4222 case PR_PCASTCOMPARE:
4223 break;
4224 case PR_ACCSHORTLOOP:
4225 break;
4226 case PR_ACCKERNEL:
4227 break;
4228 case PR_ACCINDEPENDENT:
4229 break;
4230 case PR_ACCWAIT:
4231 break;
4232 case PR_ACCNOWAIT:
4233 break;
4234 case PR_KERNELBEGIN:
4235 break;
4236 case PR_KERNEL:
4237 break;
4238 case PR_ENDKERNEL:
4239 break;
4240 case PR_ACCWAITDIR:
4241 break;
4242 case PR_ACCREDUCTOP:
4243 accreduct_op = ILM_OPND(ilmp, 4);
4244 break;
4245 case PR_ACCCACHEDIR:
4246 break;
4247 case PR_ACCCACHEREADONLY:
4248 break;
4249 case PR_ACCHOSTDATA:
4250 if (ACC_DATAMOVEMENT_DISABLED)
4251 break;
4252 break;
4253 case PR_ACCENDHOSTDATA:
4254 if (ACC_DATAMOVEMENT_DISABLED)
4255 break;
4256 break;
4257 case PR_ACCCOLLAPSE:
4258 break;
4259 case PR_ACCFORCECOLLAPSE:
4260 break;
4261 case PR_ACCDEFNONE:
4262 break;
4263 case PR_ACCDEFPRESENT:
4264 break;
4265 default:
4266 break;
4267 }
4268 break;
4269 #ifdef IM_ALLOCA
4270 case IM_DEALLOCA:
4271 if (bihb.parfg || bihb.taskfg || ILM_OPND(ilmp, 4) == 1) {
4272 /* void RTE_auto_dealloc($p) */
4273 s = ILM_SymOPND(ilmp, 3);
4274 ilix = ILI_OF(ILM_OPND(ilmp, 1));
4275 tmp = ad1ili(IL_NULL, 0);
4276 #if defined(TARGET_X8664)
4277 tmp = ad3ili(IL_DAAR, ilix, ARG_IR(0), tmp);
4278 #else
4279 tmp = ad3ili(IL_ARGAR, ilix, tmp, 0);
4280 #endif
4281 ilix = ad2ili(IL_JSR, s, tmp);
4282 chk_block(ilix);
4283 }
4284 break;
4285 #endif
4286
4287 #ifdef IM_BEGINATOMIC
4288 case IM_BEGINATOMIC: {
4289 wr_block();
4290 cr_block();
4291 set_is_in_atomic(1);
4292 set_atomic_store_created(0);
4293 } break;
4294 #endif
4295
4296 #ifdef IM_BEGINATOMICCAPTURE
4297 case IM_BEGINATOMICCAPTURE: {
4298 wr_block();
4299 cr_block();
4300 set_is_in_atomic_capture(1);
4301 set_atomic_store_created(0);
4302 set_atomic_capture_created(0);
4303 set_capture_read_ili(0);
4304 set_capture_update_ili(0);
4305 } break;
4306 #endif
4307
4308 #ifdef IM_BEGINATOMICREAD
4309 case IM_BEGINATOMICREAD: {
4310 wr_block();
4311 cr_block();
4312 set_is_in_atomic_read(1);
4313 set_atomic_store_created(0);
4314 } break;
4315 #endif
4316
4317 #ifdef IM_BEGINATOMICWRITE
4318 case IM_BEGINATOMICWRITE: {
4319 wr_block();
4320 cr_block();
4321 set_is_in_atomic_write(1);
4322 set_atomic_store_created(0);
4323 } break;
4324 #endif
4325
4326 #ifdef IM_ENDATOMIC
4327 case IM_ENDATOMIC: {
4328 if (get_is_in_atomic_capture()) {
4329 if (get_capture_read_ili() == 0 || get_capture_update_ili() == 0 ||
4330 !get_atomic_capture_created()) {
4331 error(S_0155_OP1_OP2, ERR_Severe, gbl.lineno,
4332 "Invalid/Incomplete atomic capture.", CNULL);
4333 }
4334 set_is_in_atomic_capture(0);
4335 } else {
4336 if (!get_atomic_store_created()) {
4337 error(S_0155_OP1_OP2, ERR_Severe, gbl.lineno, "Invalid atomic region.",
4338 CNULL);
4339 }
4340 set_is_in_atomic(0);
4341 set_is_in_atomic_read(0);
4342 set_is_in_atomic_write(0);
4343 }
4344 } break;
4345 #endif
4346
4347 default:
4348 interr("exp_misc:ilm not cased", opc, ERR_Severe);
4349 }
4350 }
4351
4352 /** \brief Shared function for calling target specific exp_header */
4353 static void
begin_entry(SPTR esym)4354 begin_entry(SPTR esym)
4355 {
4356 SPTR tmp;
4357
4358 exp_header(esym);
4359 if (!gbl.outlined
4360 && !ISTASKDUPG(GBL_CURRFUNC)
4361 )
4362 ccff_open_unit();
4363 if (esym == 0)
4364 entry_sptr = gbl.currsub;
4365 else
4366 entry_sptr = esym;
4367 if (gbl.vfrets) { /* subprogram contains <expr> in FORMATs */
4368 int itmp;
4369 if (esym == 0) {
4370 /* first time for subprogram */
4371 tmp = getccsym('Q', expb.gentmps++, ST_VAR);
4372 SCP(tmp, SC_STATIC);
4373 DTYPEP(tmp, DT_DCMPLX); /* need at least 3 words */
4374 vf_addr = mk_address(tmp);
4375 }
4376 /* have sched save fp */
4377 itmp = ad1ili(IL_FPSAVE, vf_addr);
4378 chk_block(itmp);
4379 }
4380 if (gbl.arets && esym == 0) {
4381 expb.aret_tmp = getccsym('Q', expb.gentmps++, ST_VAR);
4382 SCP(expb.aret_tmp, SC_AUTO);
4383 DTYPEP(expb.aret_tmp, DT_INT);
4384 }
4385 if (gbl.denorm) {
4386 int addr, mask;
4387 int sym, arg, itmp;
4388 if (esym == 0) {
4389 expb.mxcsr_tmp = getccsym('Q', expb.gentmps++, ST_VAR);
4390 SCP(expb.mxcsr_tmp, SC_AUTO);
4391 DTYPEP(expb.mxcsr_tmp, DT_INT);
4392 ADDRTKNP(expb.mxcsr_tmp, 1);
4393 }
4394 #if defined(TARGET_ARM64)
4395 /*
4396 * __fenv_mask_fz(int mask, int *psv)
4397 */
4398 mask = ad_icon(0x0); /* clear FZ */
4399 addr = ad_acon(expb.mxcsr_tmp, 0);
4400 sym = mkfunc("__fenv_mask_fz");
4401 #else
4402 /*
4403 * __fenv_mask_mxcsr(int mask, int *psv)
4404 */
4405 mask = ad_icon(0xffff7fbf); /* clear bit 15 (FZ) & bit 6 (DAZ) */
4406 addr = ad_acon(expb.mxcsr_tmp, 0);
4407 sym = mkfunc("__fenv_mask_mxcsr");
4408 #endif
4409 arg = ad1ili(IL_NULL, 0);
4410 #if defined(TARGET_X8664)
4411 arg = ad3ili(IL_DAIR, mask, ARG_IR(0), arg);
4412 arg = ad3ili(IL_DAAR, addr, ARG_IR(1), arg);
4413 #else
4414 arg = ad3ili(IL_ARGAR, addr, arg, 0);
4415 arg = ad2ili(IL_ARGIR, mask, arg);
4416 #endif
4417 itmp = ad2ili(IL_JSR, sym, arg);
4418 iltb.callfg = 1;
4419 chk_block(itmp);
4420 }
4421 }
4422
4423 void
exp_restore_mxcsr(void)4424 exp_restore_mxcsr(void)
4425 {
4426 if (gbl.denorm) {
4427 int addr, nme, tmp;
4428 int sym, arg;
4429 addr = ad_acon(expb.mxcsr_tmp, 0);
4430 nme = addnme(NT_VAR, expb.mxcsr_tmp, 0, 0);
4431 tmp = ad3ili(IL_LD, addr, nme, MSZ_WORD);
4432 #if defined(TARGET_ARM64)
4433 /*
4434 * __fenv_restore_fz(int sv)
4435 */
4436 sym = mkfunc("__fenv_restore_fz");
4437 #else
4438 /*
4439 * __fenv_restore_mxcsr(int sv)
4440 */
4441 sym = mkfunc("__fenv_restore_mxcsr");
4442 #endif
4443 arg = ad1ili(IL_NULL, 0);
4444 arg = ad3ili(IL_ARGIR, tmp, arg, 0);
4445 tmp = ad2ili(IL_JSR, sym, arg);
4446 iltb.callfg = 1;
4447 chk_block(tmp);
4448 }
4449 }
4450
4451 static void
store_aret(int val)4452 store_aret(int val)
4453 {
4454 int addr;
4455 int nme;
4456 int tmp;
4457
4458 addr = ad_acon(expb.aret_tmp, 0);
4459 nme = addnme(NT_VAR, expb.aret_tmp, 0, 0);
4460 tmp = ad4ili(IL_ST, val, addr, nme, MSZ_WORD);
4461 ADDRCAND(tmp, nme);
4462 chk_block(tmp);
4463 }
4464
4465 int
exp_get_sdsc_len(int s,int base,int basenm)4466 exp_get_sdsc_len(int s, int base, int basenm)
4467 {
4468 SPTR sdsc;
4469 int len, scale, elmsz;
4470 int ili, acon;
4471 sdsc = SDSCG(s);
4472 PTRSAFEP(sdsc, 1);
4473 #if DEBUG
4474 assert((DDTG(DTYPEG(s)) == DT_ASSCHAR || DDTG(DTYPEG(s)) == DT_ASSNCHAR ||
4475 DDTG(DTYPEG(s)) == DT_DEFERCHAR || DDTG(DTYPEG(s)) == DT_DEFERNCHAR),
4476 "exp_get_sdsc_len expects deferred or assumed length character type",
4477 s, ERR_Severe);
4478 #endif
4479
4480 /* the DESC_HDR_BYTE_LEN is 32-bit in the descriptor if not compiled with
4481 * -i8/Mlarge_arrays
4482 * make sure it is 64-bit
4483 */
4484 len = get_sdsc_element(sdsc, DESC_HDR_BYTE_LEN, base, basenm);
4485 if (XBIT(68, 0x20) && IL_RES(ILI_OPC(len)) != ILIA_KR) {
4486 len = ad1ili(IL_IKMV, len);
4487 } else {
4488 len = kimove(get_sdsc_element(sdsc, DESC_HDR_BYTE_LEN, base, basenm));
4489 }
4490 return len;
4491 }
4492
4493 SPTR
frte_func(SPTR (* pf)(const char *),const char * root)4494 frte_func(SPTR (*pf)(const char *), const char *root)
4495 {
4496 char bf[32];
4497 char *p;
4498 SPTR sym;
4499
4500 p = bf;
4501 strcpy(p, root);
4502 #if DEBUG
4503 assert(strlen(bf) <= 31, "frte_func:exceed bf", sizeof(bf), ERR_Severe);
4504 #endif
4505 sym = (*pf)(bf);
4506 return sym;
4507 }
4508