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 Common expander routines
20 */
21
22 #define EXPANDER_DECLARE_INTERNAL
23 #include "expand.h"
24 #include "exputil.h"
25 #include "exp_ftn.h"
26 #include "expatomics.h"
27 #include "expreg.h"
28 #include "expsmp.h"
29 #include "error.h"
30 #include "regutil.h"
31 #include "machreg.h"
32 #include "fih.h"
33 #include "ilmtp.h"
34 #include "ilm.h"
35 #include "ili.h"
36 #include "machar.h"
37 #include "scope.h"
38 #include "llassem.h"
39 #include "outliner.h"
40 #include "verify.h"
41 #include "ccffinfo.h"
42 #include "ilidir.h"
43 #include "exp_rte.h"
44 #include "dtypeutl.h"
45 #include "symfun.h"
46 #if defined(OMP_OFFLOAD_LLVM) || defined(OMP_OFFLOAD_PGI)
47 #include "ompaccel.h"
48 #endif
49 #ifdef OMP_OFFLOAD_LLVM
50 #include "tgtutil.h"
51 #include "kmpcutil.h"
52 #endif
53 extern int in_extract_inline; /* Bottom-up auto-inlining */
54
55 static int efunc(const char *);
56 static int create_ref(SPTR sym, int *pnmex, int basenm, int baseilix,
57 int *pclen, int *pmxlen, int *prestype);
58 static int jsr2qjsr(int);
59
60 #define DO_PFO ((XBIT(148, 0x1000) && !XBIT(148, 0x4000)) || XBIT(148, 1))
61
62 /***************************************************************/
63
64 /*
65 * Initialize global data structures
66 */
67 void
ds_init(void)68 ds_init(void)
69 {
70 int i;
71 ili_init();
72 ilt_init();
73 bih_init();
74 nme_init();
75
76 /*
77 * allocate the register areas for use by the expander or the optimizer
78 */
79 i = 128;
80 EXP_ALLOC(rcandb, RCAND, i);
81 BZERO(&rcandb.stg_base[0], RCAND, i); /* purify umr when cand = 0 */
82 rcandb.stg_avail = 1;
83 rcandb.weight = 1;
84 rcandb.kr = 0;
85 EXP_ALLOC(ratb, RAT, i);
86 ratb.stg_avail = 1;
87 EXP_ALLOC(rgsetb, RGSET, i);
88 BZERO(&rgsetb.stg_base[0], RGSET, i);
89 rgsetb.stg_avail = 1;
90
91 } /* ds_init */
92
93 void
exp_init(void)94 exp_init(void)
95 {
96 /*
97 * Allocate the space necessary to hold the auxiliary information for ILM
98 * evaluation required by the expander. If necessary the space could
99 * depend on sem.ilm_size, but this is probably too much. The ilm index
100 * i is associated with the ith entry in this area (there will items that
101 * are not used). The following size is probably sufficient but a check
102 * will be done each time rdilms is called.
103 */
104 EXP_ALLOC(expb.ilmb, ILM_AUX, 610);
105 expb.flags.wd = 0;
106
107 expb.gentmps = 0; /* PGC: counter increments across functions */
108 expb.str_avail = 0;
109 if (expb.str_size == 0) {
110 expb.str_size = 32;
111 NEW(expb.str_base, STRDESC, expb.str_size);
112 }
113 expb.logcjmp = XBIT(125, 0x8) ? IL_ICJMPZ : IL_LCJMPZ;
114 aux.curr_entry->display = SPTR_NULL;
115
116 ds_init();
117 expb.curilt = 0;
118 expb.curbih = 0;
119 expb.isguarded = 0;
120 expb.flags.bits.noblock = 1;
121 expb.flags.bits.noheader = 1;
122 if (CHARLEN_64BIT)
123 expb.charlen_dtype = DT_INT8;
124 else
125 expb.charlen_dtype = DT_INT;
126
127 if (flg.xon != 0 || flg.xoff ^ 0xFFFFFFFF)
128 expb.flags.bits.excstat = 1;
129
130 /* For C, only rewind the ilm file once (performed by main()) */
131 rewindilms();
132
133 /* set threshold of # of ilm words, if exceeded, to break ili blocks */
134
135 if (flg.x[100])
136 expb.ilm_thresh = 1 << (flg.x[100] & 0x1f);
137 else {
138 #ifdef TM_ILM_THRESH
139 expb.ilm_thresh = TM_ILM_THRESH;
140 if (flg.opt >= 3 || flg.vect & 16)
141 expb.ilm_thresh += TM_ILM_THRESH >> 1; /* allow for 50% more */
142 #else
143 expb.ilm_thresh = 1 << 30; /* BIG */
144 #endif
145 }
146 expb.sc = SC_AUTO; /* default storage class for expander-created temps */
147 exp_smp_init();
148 expb.clobber_ir = expb.clobber_pr = 0;
149 }
150
151 /*
152 * clean up allocated space when the program isn't compiled
153 */
154 void
exp_cleanup(void)155 exp_cleanup(void)
156 {
157 if (rgsetb.stg_base)
158 EXP_FREE(rgsetb);
159 rgsetb.stg_base = NULL;
160 if (rcandb.stg_base) {
161 EXP_FREE(rcandb);
162 }
163 rcandb.stg_base = NULL;
164 if (ratb.stg_base)
165 EXP_FREE(ratb);
166 ratb.stg_base = NULL;
167 } /* exp_cleanup */
168
169 /*
170 * Parse an IM_FILE ilm.
171 *
172 * - ilmp is an IM_FILE ilm.
173 * - lineno_out becomes the line number, but only if the IM_FILE has a non-zero
174 * lineno operand. Otherwise, lineno_out is not touched.
175 * - findex_out becomes a valid index into the FIH table.
176 * - ftag_out becomes the ftag.
177 */
178 static void
parse_im_file(const ILM * ilmp,int * lineno_out,int * findex_out,int * ftag_out)179 parse_im_file(const ILM *ilmp, int *lineno_out, int *findex_out, int *ftag_out)
180 {
181 /* IM_FILE lineno findex ftag */
182 int lineno = ILM_OPND(ilmp, 1);
183 int findex = ILM_OPND(ilmp, 2);
184 int ftag = ILM_OPND(ilmp, 3);
185
186 assert(ILM_OPC(ilmp) == IM_FILE, "parse_im_file: Expected IM_FILE",
187 ILM_OPC(ilmp), ERR_Fatal);
188
189 /* The bottom-up inliner will generate some IM_FILE ilms with findex
190 * operands that reference the IFIH table. These references are encoded as
191 * negative numbers. Translate them back to FIH references here. */
192 if (findex < 0) {
193 int ifindex = -findex - 1;
194 assert(ifindex < ifihb.stg_avail,
195 "parse_im_file: Invalid IFIH reference on IM_FILE", ifindex,
196 ERR_Warning);
197 findex = IFIH_FINDEX(ifindex);
198 }
199
200 assert(findex < fihb.stg_avail,
201 "parse_im_file: Invalid FIH reference on IM_FILE", findex,
202 ERR_Warning);
203
204 if (lineno_out && lineno)
205 *lineno_out = lineno;
206 if (findex_out)
207 *findex_out = findex;
208 if (ftag_out)
209 *ftag_out = ftag;
210 }
211
212 /***************************************************************/
213
214 /** \brief Expand ILMs to ILIs */
215 int
expand(void)216 expand(void)
217 {
218 int ilmx; /* index of the ILM */
219 int len; /* length of the ILM */
220 ILM *ilmp; /* absolute pointer to the ILM */
221 ILM_OP opc; /* opcode of the ILM */
222 int countcalls; /* how many calls in this block of ilms */
223 int last_label_bih = 0;
224 int last_ftag = 0;
225 int nextftag = 0, nextfindex = 0;
226 int last_cpp_branch = 0;
227
228 /*
229 * NOTE, for an ILM: ilmx is needed to access the ILM_AUX area, ilmp is
230 * needed to access the ILM area
231 */
232 exp_init();
233 /* During expand, we want to generate unique proc ili each time a
234 * proc ILM is processed. The assumption is that the scheduler will
235 * cse a proc ili if it appears multiple times in a block. E.g.,
236 * COMPLEX c(10)
237 * x = f() + f() ! two ili for calling f
238 * c(ifunc()) = ... ! 1 call to ifunc (although two uses)
239 * After expand, we share proc ili; the optimizer may create expressions
240 * which contain calls where the intent is to cse a call if it already
241 * exists in the block.
242 */
243 share_proc_ili = false;
244
245 if (!XBIT(120, 0x4000000)) {
246 set_allfiles(0);
247 } else {
248 gbl.findex = 1;
249 }
250
251 /*
252 * process all blocks for a function. For Fortran, the terminating
253 * condition is when the "end" ILM is seen (there may be multiple
254 * subprograms per compilation -- the ilm file is reused). For C,
255 * the ilm file contains the blocks for all function. The loop
256 * terminates when the "end" ILM is seen and a non-zero value is
257 * returned; if the ilm file is at end-of-file, 0 is returned.
258 */
259 do {
260 expb.nilms = rdilms();
261 nextftag = fihb.nextftag;
262 nextfindex = fihb.nextfindex;
263 #if DEBUG
264 if (DBGBIT(4, 0x800))
265 dumpilms();
266 #endif
267 DEBUG_ASSERT(expb.nilms, "expand:ilm end of file");
268 /*
269 * the following check could be deleted if the max ilm block size is
270 * known or if space doesn't have to be conserved during this phase
271 */
272 if (expb.nilms > expb.ilmb.stg_size) {
273 EXP_MORE(expb.ilmb, ILM_AUX, expb.nilms + 100);
274 }
275
276 /* scan through all the ilms in the current ILM block */
277
278 for (ilmx = 0; ilmx < expb.nilms; ilmx += len) {
279 int saved_curbih = expb.curbih;
280 int saved_findex = fihb.nextfindex;
281 bool followed_by_file = false;
282 bool ilmx_is_block_label = false;
283 int findex, ftag;
284
285 /* the first time an ilm is seen, it has no result */
286
287 ILM_RESULT(ilmx) = 0;
288 ILM_EXPANDED_FOR(ilmx) = 0;
289
290 ILM_RESTYPE(ilmx) = 0; /* zero out result types */
291 ILM_NME(ilmx) = 0; /* zero out name entry (?) */
292 findex = 0;
293 ftag = 0;
294
295 ilmp = (ILM *)(ilmb.ilm_base + ilmx);
296 opc = ILM_OPC(ilmp);
297
298 if (opc == IM_BR) {
299 last_cpp_branch = ILM_OPND(ilmp, 1);
300 } else if (opc == IM_LABEL) {
301 /* Scope labels don't cause block breaks. */
302 ilmx_is_block_label = !is_scope_label(ILM_OPND(ilmp, 1));
303 if (!ilmx_is_block_label) {
304 new_callee_scope = ENCLFUNCG(ILM_OPND(ilmp, 1));
305 }
306 }
307
308 DEBUG_ASSERT(opc > 0 && opc < N_ILM, "expand: bad ilm");
309 len = ilms[opc].oprs + 1; /* length is number of words for the
310 * fixed operands and the opcode */
311 if (IM_VAR(opc))
312 len += ILM_OPND(ilmp, 1); /* include the number of
313 * variable operands */
314 if (IM_TRM(opc)) {
315 int cur_label = BIH_LABEL(expb.curbih);
316 eval_ilm(ilmx);
317 }
318 else if (flg.smp && len) {
319 ll_rewrite_ilms(-1, ilmx, len);
320 }
321
322 if (opc != IM_FILE) {
323 ++nextftag;
324 fihb.nextftag = nextftag;
325 } else if ((XBIT(148, 0x1) || XBIT(148, 0x1000)) && !followed_by_file) {
326 int ftag;
327 int findex;
328 parse_im_file((ILM *)&ilmb.ilm_base[ilmx], NULL, &findex, &ftag);
329 if (ftag) {
330 nextfindex = findex;
331 nextftag = ftag;
332 fihb.nextfindex = nextfindex;
333 fihb.nextftag = nextftag;
334 }
335 }
336
337 /* If a new bih is created, detect certain scenarios */
338
339 if (expb.curbih > saved_curbih) {
340
341 /* Pay special attention to the transition from inlinee to inliner.
342 * If last bih (in the inlinee) is created by an IM_LABEL followed
343 * by an IM_FILE, we need to honor the ftag info in the IM_FILE.
344 */
345
346 if ((saved_curbih != 0) && (saved_curbih == last_label_bih) &&
347 (saved_findex > fihb.nextfindex))
348 BIH_FTAG(last_label_bih) = last_ftag;
349
350 /* Flag the scenario that the new bih is created by an IM_LABEL that is
351 * followed by an IM_FILE.
352 */
353
354 if (ilmx_is_block_label && followed_by_file) {
355 last_label_bih = expb.curbih;
356 last_ftag = ftag;
357 }
358 }
359 } /* end of loop through ILM block */
360
361 new_callee_scope = 0;
362 }
363 while (opc != IM_END && opc != IM_ENDF);
364
365 if (DBGBIT(10, 2) && (bihb.stg_avail != 1)) {
366 int bih;
367 for (bih = 1; bih != 0; bih = BIH_NEXT(bih)) {
368 if (BIH_EN(bih))
369 dump_blocks(gbl.dbgfil, bih, "***** BIHs for Function \"%s\" *****", 1);
370 }
371 dmpili();
372 }
373 #if DEBUG
374 verify_function_ili(VERIFY_ILI_DEEP);
375 if (DBGBIT(10, 16)) {
376 dmpnme();
377 {
378 int i, j;
379 for (i = nmeb.stg_avail - 1; i >= 2; i--) {
380 for (j = nmeb.stg_avail - 1; j >= 2; j--) {
381 if (i != j)
382 (void)conflict(i, j);
383 }
384 }
385 }
386 }
387 if (DBGBIT(8, 64)) {
388 fprintf(gbl.dbgfil, " ILM(%d)", expb.ilmb.stg_size);
389 fprintf(gbl.dbgfil, " ILI(%d)", ilib.stg_avail);
390 fprintf(gbl.dbgfil, " ILT(%d)", iltb.stg_size);
391 fprintf(gbl.dbgfil, " BIH(%d)", bihb.stg_size);
392 fprintf(gbl.dbgfil, " NME(%d)\n", nmeb.stg_avail);
393 }
394 #endif
395
396 ili_lpprg_init();
397 /* for C, we don't free the ilm area until we reach end-of-file */
398 FREE(ilmb.ilm_base);
399 ilmb.ilm_base = NULL;
400 EXP_FREE(expb.ilmb);
401 freearea(STR_AREA);
402 if (flg.opt < 2) {
403 if (rcandb.stg_base) {
404 EXP_FREE(rcandb);
405 rcandb.stg_base = NULL;
406 }
407 }
408 share_proc_ili = true;
409 exp_smp_fini();
410 fihb.nextftag = fihb.currftag = 0;
411
412 if (!XBIT(120, 0x4000000)) {
413 /* Restored file indexes to where they were before expand in case
414 they got changed somewhere.
415 */
416 set_allfiles(1);
417 } else {
418 fihb.nextfindex = fihb.currfindex = 1;
419 }
420 return expb.nilms;
421 }
422
423 /***************************************************************/
424
425 /*
426 * Check that operand opr of ILM ilmx has been expanded.
427 * If this will be the first use of this ILM, then set ILM_EXPANDED_FOR
428 * to ilmx.
429 */
430 static void
eval_ilm_argument1(int opr,ILM * ilmpx,int ilmx)431 eval_ilm_argument1(int opr, ILM *ilmpx, int ilmx)
432 {
433 int op1, ilix;
434 if ((ilix = ILI_OF(op1 = ILM_OPND(ilmpx, opr))) == 0) {
435 /* hasn't been evaluated yet */
436 eval_ilm(op1);
437 /* mark this as expanded for this ILM */
438 ILM_EXPANDED_FOR(op1) = -ilmx;
439 } else if (ILM_EXPANDED_FOR(op1) < 0 && !is_cseili_opcode(ILI_OPC(ilix))) {
440 /* This was originally added for a parent ILM, so it hasn't
441 * been used as an operand ILI yet. Take ownership of it here.
442 * When it is reused later for a parent ILM,
443 * it will get then get turned into a CSE ILI */
444 ILM_EXPANDED_FOR(op1) = -ilmx;
445 }
446 } /* eval_ilm_argument1 */
447
448 void
eval_ilm(int ilmx)449 eval_ilm(int ilmx)
450 {
451
452 ILM *ilmpx;
453 int noprs, /* number of operands in the ILM */
454 ilix, /* ili index */
455 tmp, /* temporary */
456 op1; /* operand 1 */
457 ILM_OP opcx; /**< ILM opcode of the ILM */
458
459 int first_op = 0;
460
461 opcx = ILM_OPC(ilmpx = (ILM *)(ilmb.ilm_base + ilmx));
462
463 if (flg.smp) {
464 if (IM_TYPE(opcx) != IMTY_SMP && ll_rewrite_ilms(-1, ilmx, 0)) {
465 if (ilmx == 0 && opcx == IM_BOS) {
466 /* Set line no for EPARx */
467 gbl.lineno = ILM_OPND(ilmpx, 1);
468 }
469 return;
470 }
471 }
472
473 if (EXPDBG(8, 2))
474 fprintf(gbl.dbgfil, "---------- eval ilm %d\n", ilmx);
475
476 if (!ll_ilm_is_rewriting())
477 {
478 #ifdef OMP_OFFLOAD_LLVM
479 if (flg.omptarget && gbl.ompaccel_intarget) {
480 if (opcx == IM_MP_BREDUCTION) {
481 ompaccel_notify_reduction(true);
482 exp_ompaccel_reduction(ilmpx, ilmx);
483 } else if (opcx == IM_MP_EREDUCTION) {
484 ompaccel_notify_reduction(false);
485 return;
486 }
487
488 if (ompaccel_is_reduction_region())
489 return;
490 }
491 #endif
492 /*-
493 * evaluate unevaluated "fixed" arguments:
494 * For each operand which is a link to another ilm, recurse (evaluate it)
495 * if not already evaluated
496 */
497 if (opcx == IM_DCMPLX || opcx == IM_CMPLX) {
498 for (tmp = 1, noprs = 1; noprs <= ilms[opcx].oprs; ++tmp, ++noprs) {
499 if (IM_OPRFLAG(opcx, noprs) == OPR_LNK) {
500 eval_ilm_argument1(noprs, ilmpx, ilmx);
501 }
502 }
503 } else {
504 for (tmp = 1, noprs = ilms[opcx].oprs; noprs > first_op; ++tmp, --noprs) {
505 if (IM_OPRFLAG(opcx, noprs) == OPR_LNK) {
506 eval_ilm_argument1(noprs, ilmpx, ilmx);
507 }
508 }
509 }
510
511 /* evaluate unevaluated "variable" arguments */
512
513 if (IM_VAR(opcx) && IM_OPRFLAG(opcx, ilms[opcx].oprs + 1) == OPR_LNK) {
514 for (noprs = ILM_OPND(ilmpx, 1); noprs > 0; --noprs, ++tmp) {
515 eval_ilm_argument1(tmp, ilmpx, ilmx);
516 }
517 }
518
519 /*-
520 * check the "fixed" arguments for any duplicated values
521 */
522 for (tmp = 1, noprs = ilms[opcx].oprs; noprs > first_op; ++tmp, --noprs) {
523 if (IM_OPRFLAG(opcx, noprs) == OPR_LNK) {
524 /* all arguments will have been evaluated by now */
525 ilix = ILI_OF(op1 = ILM_OPND(ilmpx, noprs));
526 if (ILM_EXPANDED_FOR(op1) == -ilmx) {
527 ILM_EXPANDED_FOR(op1) = ilmx;
528 } else if (ilix && ILM_EXPANDED_FOR(op1) != ilmx) {
529 if (ILM_RESTYPE(op1) != ILM_ISCMPLX &&
530 ILM_RESTYPE(op1) != ILM_ISDCMPLX
531 #ifdef LONG_DOUBLE_FLOAT128
532 && ILM_RESTYPE(op1) != ILM_ISFLOAT128CMPLX
533 #endif
534 )
535 /* not complex */
536 ILM_RESULT(op1) = check_ilm(op1, ilix);
537 else {
538 /* complex */
539 ILM_RRESULT(op1) = check_ilm(op1, (int)ILM_RRESULT(op1));
540 ILM_IRESULT(op1) = check_ilm(op1, (int)ILM_IRESULT(op1));
541 }
542 }
543 }
544 }
545
546 /* check the "variable" arguments for any duplicated values */
547
548 if (IM_VAR(opcx) && IM_OPRFLAG(opcx, ilms[opcx].oprs + 1) == OPR_LNK) {
549 for (noprs = ILM_OPND(ilmpx, 1); noprs > 0; --noprs, ++tmp) {
550 ilix = ILI_OF(op1 = ILM_OPND(ilmpx, tmp));
551 if (ILM_EXPANDED_FOR(op1) == -ilmx) {
552 ILM_EXPANDED_FOR(op1) = ilmx;
553 } else if (ilix && ILM_EXPANDED_FOR(op1) != ilmx) {
554 if (ILM_RESTYPE(op1) != ILM_ISCMPLX &&
555 ILM_RESTYPE(op1) != ILM_ISDCMPLX
556 #ifdef LONG_DOUBLE_FLOAT128
557 && ILM_RESTYPE(op1) != ILM_ISFLOAT128CMPLX
558 #endif
559 ) {
560 /* not complex */
561 ILM_RESULT(op1) = check_ilm(op1, ilix);
562 } else {
563 /* complex */
564 ILM_RRESULT(op1) = check_ilm(op1, (int)ILM_RRESULT(op1));
565 ILM_IRESULT(op1) = check_ilm(op1, (int)ILM_IRESULT(op1));
566 }
567 }
568 }
569 }
570 }
571 /*
572 * ready to evaluate the ilm. opcx is opcode of current ilm, ilmpx is
573 * pointer to current ilm, and ilmx is index to the current ilm.
574 */
575 if (EXPDBG(8, 2))
576 fprintf(gbl.dbgfil, "ilm %s, index %d, lineno %d\n", ilms[opcx].name, ilmx,
577 gbl.lineno);
578
579 if (!IM_SPEC(opcx))
580 {
581 /* expand the macro definition */
582 tmp = exp_mac(opcx, ilmpx, ilmx);
583 if (IM_I8(opcx))
584 ILM_RESTYPE(ilmx) = ILM_ISI8;
585
586 return;
587 }
588 switch (IM_TYPE(opcx)) { /* special-cased ILM */
589
590 case IMTY_REF: /* reference */
591 exp_ref(opcx, ilmpx, ilmx);
592 break;
593
594 case IMTY_LOAD: /* load */
595 exp_load(opcx, ilmpx, ilmx);
596 break;
597
598 case IMTY_STORE: /* store */
599 exp_store(opcx, ilmpx, ilmx);
600 break;
601
602 case IMTY_BRANCH: /* branch */
603 exp_bran(opcx, ilmpx, ilmx);
604 break;
605
606 case IMTY_PROC: /* procedure */
607 exp_call(opcx, ilmpx, ilmx);
608 break;
609
610 case IMTY_INTR: /* intrinsic */
611 case IMTY_ARTH: /* arithmetic */
612 case IMTY_CONS: /* constant */
613 exp_ac(opcx, ilmpx, ilmx);
614 break;
615
616 case IMTY_MISC: /* miscellaneous */
617 exp_misc(opcx, ilmpx, ilmx);
618 break;
619
620 case IMTY_FSTR: /* fortran string */
621 exp_fstring(opcx, ilmpx, ilmx);
622 break;
623
624 case IMTY_SMP: /* smp ILMs */
625 exp_smp(opcx, ilmpx, ilmx);
626 break;
627
628 default: /* error */
629 interr("eval_ilm: bad op type", IM_TYPE(opcx), ERR_Severe);
630 break;
631 } /* end of switch on ILM opc */
632
633 #ifdef OMP_OFFLOAD_LLVM
634
635 if (flg.omptarget && opcx == IM_ENLAB) {
636 /* Enables creation of libomptarget related structs in the main function,
637 * but it is not recommended option. Default behaviour is to initialize and
638 * create them in the global constructor. */
639 if (XBIT(232, 0x10)) {
640 if (!ompaccel_is_tgt_registered() && !OMPACCRTG(gbl.currsub) &&
641 !gbl.outlined) {
642 ilix = ll_make_tgt_register_lib2();
643 iltb.callfg = 1;
644 chk_block(ilix);
645 ompaccel_register_tgt();
646 }
647 }
648 /* We do not initialize spmd kernel library since we do not use spmd data
649 * sharing model. It does extra work and allocates device on-chip memory.
650 * */
651 if (XBIT(232, 0x40) && gbl.ompaccel_intarget) {
652 ilix = ompaccel_nvvm_get(threadIdX);
653 ilix = ll_make_kmpc_spmd_kernel_init(ilix);
654 iltb.callfg = 1;
655 chk_block(ilix);
656 }
657 }
658 #endif
659 if (IM_I8(opcx))
660 ILM_RESTYPE(ilmx) = ILM_ISI8;
661 }
662
663 /***************************************************************/
664 /*
665 * An ESTMT ILM (or an ILI whose value is to be discarded) is processed by
666 * walking the ILI tree (located by ilix) and creating ILTs for any function
667 * calls that exist in the tree. This routine is similar to reduce_ilt
668 * (iltutil.c) except that chk_block is used to add an ILT. This is done so
669 * that the "end of block" checks are performed.
670 */
671 void
exp_estmt(int ilix)672 exp_estmt(int ilix)
673 {
674 int noprs, i, ilix1;
675
676 ILI_OP opc = ILI_OPC(ilix);
677 if (IL_TYPE(opc) == ILTY_PROC && opc >= IL_JSR) {
678 iltb.callfg = 1; /* create an ILT for the function */
679 chk_block(ilix);
680 } else if (opc == IL_DFRDP && ILI_OPC(ILI_OPND(ilix, 1)) != IL_QJSR) {
681 iltb.callfg = 1;
682 chk_block(ad1ili(IL_FREEDP, ilix));
683 } else if (opc == IL_DFRSP && ILI_OPC(ILI_OPND(ilix, 1)) != IL_QJSR) {
684 iltb.callfg = 1;
685 chk_block(ad1ili(IL_FREESP, ilix));
686 } else if (opc == IL_DFRCS && ILI_OPC(ILI_OPND(ilix, 1)) != IL_QJSR) {
687 iltb.callfg = 1;
688 chk_block(ad1ili(IL_FREECS, ilix));
689 }
690 #ifdef LONG_DOUBLE_FLOAT128
691 else if (opc == IL_FLOAT128RESULT && ILI_OPC(ILI_OPND(ilix, 1)) != IL_QJSR) {
692 iltb.callfg = 1;
693 chk_block(ad1ili(IL_FLOAT128FREE, ilix));
694 }
695 #endif
696 else if (opc == IL_VA_ARG) {
697 iltb.callfg = 1;
698 chk_block(ilix);
699 } else if (IL_HAS_FENCE(opc)) {
700 chk_block(ad_free(ilix));
701 } else {
702 /* otherwise, walk all of the link operands of the ILI */
703 noprs = ilis[opc].oprs;
704 for (i = 1; i <= noprs; ++i)
705 if (IL_ISLINK(opc, i))
706 exp_estmt((int)ILI_OPND(ilix, i));
707 }
708 }
709
710 /***************************************************************/
711
712 /* Expand a scope label that should be inserted as an in-stream IL_LABEL ilt
713 * instead of splitting the current block.
714 *
715 * These scope labels are generated by enter_lexical_block() and
716 * exit_lexical_block(). They are verified by scope_verify().
717 */
718 static void
exp_scope_label(int lbl)719 exp_scope_label(int lbl)
720 {
721 int ilt, ilix;
722
723 /* Each scope label can only appear in one block. The ILIBLK field for the
724 * label must point to the unique BIH containing the IL_LABEL ilt.
725 */
726 assert(ILIBLKG(lbl) == 0 || ISTASKDUPG(GBL_CURRFUNC),
727 "Duplicate appearance of scope label", lbl, ERR_Severe);
728
729 /* This IM_LABEL may have been created for a lexical scope that turned out
730 * to not contain any variables. Such a label should simply be ignored. See
731 * cancel_lexical_block(). */
732 if (!ENCLFUNCG(lbl))
733 return;
734
735 ilix = ad1ili(IL_LABEL, lbl);
736
737 /* Insert the label at the top of the current block instead of appending
738 * it. Labels are not supposed to affect code generation, but they
739 * interfere with the trailing branches in a block. We also have code which
740 * expects the last three ilts in a block to follow a certain pattern for
741 * indiction variable updates.
742 *
743 * Skip any existing labels at the beginning of the block so that multiple
744 * labels appear in source order.
745 *
746 * The first and last ilts in the current block are stored in ILT_NEXT(0)
747 * and ILT_PREV(0) respectively; BIH_ILTFIRST isn't up-to-date. See
748 * wrilts().
749 */
750 ilt = ILT_NEXT(0);
751 while (ilt && ILI_OPC(ILT_ILIP(ilt)) == IL_LABEL)
752 ilt = ILT_NEXT(ilt);
753
754 if (!ilt) {
755 /* This block is all labels. Append the new label. */
756 expb.curilt = addilt(expb.curilt, ilix);
757 } else {
758 /* Now, ilt is the first non-label ilt in the block.
759 * Insert new label before ilt.
760 * This also does the right thing when ILT_PREV(ilt) == 0.
761 */
762 addilt(ILT_PREV(ilt), ilix);
763 }
764
765 ILIBLKP(lbl, expb.curbih);
766 }
767
768 void
exp_label(SPTR lbl)769 exp_label(SPTR lbl)
770 {
771 int ilix; /* ili of an ilt */
772
773 /* Handle in-stream labels by creating an IL_LABEL ilt. */
774 if (is_scope_label(lbl)) {
775 exp_scope_label(lbl);
776 /* In-stream labels newer cause a new block to be created, so we're
777 * done. */
778 return;
779 }
780
781 if (expb.flags.bits.waitlbl) {
782 /*
783 * the current ilt points to a conditional branch. saveili locates an
784 * unconditional branch. If the conditional label is lbl, then the
785 * conditional is complemented whose label is changed to locate the
786 * one specified in the unconditional. The unconditional ili is not
787 * added.
788 */
789 expb.flags.bits.waitlbl = 0;
790 ilix = ILT_ILIP(expb.curilt); /* conditional branch ili */
791
792 if (expb.curilt && (ILI_OPND(ilix, ilis[ILI_OPC(ilix)].oprs)) == lbl) {
793 ILT_ILIP(expb.curilt) = compl_br(ilix, (int)(ILI_OPND(expb.saveili, 1)));
794 RFCNTD(lbl);
795 } else {
796 if (flg.opt != 1) {
797 wr_block();
798 cr_block();
799 }
800 expb.curilt = addilt(expb.curilt, expb.saveili);
801 }
802 }
803 /*
804 * check to see if the current ilt locates an ili which is a branch to
805 * lbl -- this only happens for opt levels other than 0.
806 */
807 if (flg.opt != 0 && ILT_BR(expb.curilt)) {
808 ilix = ILT_ILIP(expb.curilt);
809 if (ILI_OPND(ilix, ilis[ILI_OPC(ilix)].oprs) == lbl &&
810 ILI_OPC(ilix) != IL_JMPA && ILI_OPC(ilix) != IL_JMPMK &&
811 ILI_OPC(ilix) != IL_JMPM) {
812 int curilt = expb.curilt;
813
814 /*
815 * delete the branch ilt -- this may create ilts which locate
816 * functions
817 */
818 if (EXPDBG(8, 32))
819 fprintf(gbl.dbgfil,
820 "---exp_label: deleting branch ili %d from block %d\n", ilix,
821 expb.curbih);
822
823 expb.curilt = ILT_PREV(curilt);
824 ILT_NEXT(expb.curilt) = 0;
825 ILT_PREV(0) = expb.curilt;
826 STG_ADD_FREELIST(iltb, curilt);
827 expb.curilt = reduce_ilt(expb.curilt, ilix);
828 RFCNTD(lbl);
829 }
830 }
831 /*-
832 * finish off by checking lbl --
833 * 1. If opt 0 is requested, the label will always begin a block
834 * if it is a user label. NOTE that this covers the case when
835 * just -debug is specified (no -opt); if debug is requested along
836 * with a higher opt, we do not allow unreferenced labels to
837 * appear in the blocks since this can drastically affect code.
838 * WARNING: coffasm needs to be follow these conventions --- see
839 * the Is_user_label macro in all versions of coffasm.c.
840 * KLUDGE: for C blocks, labels are created -- their RFCNT's must
841 * be nonzero (set by semant).
842 * 2. If the reference count is still non-zero, a new block is
843 * created labeled by lbl.
844 */
845 if (flg.opt == 0 && CCSYMG(lbl) == 0) {
846 if (BIH_LABEL(expb.curbih) != 0 ||
847 (expb.curilt != 0 && !ILT_DBGLINE(expb.curilt))) {
848 wr_block();
849 cr_block();
850 }
851 BIH_LABEL(expb.curbih) = lbl;
852 ILIBLKP(lbl, expb.curbih);
853 fihb.currftag = fihb.nextftag;
854 fihb.currfindex = fihb.nextfindex;
855 } else if (RFCNTG(lbl) != 0) {
856 if (BIH_LABEL(expb.curbih) != 0 ||
857 (expb.curilt != 0 && !ILT_DBGLINE(expb.curilt))) {
858 wr_block();
859 cr_block();
860 } else if ((XBIT(148, 0x1) || XBIT(148, 0x1000)) && (expb.curilt == 0) &&
861 (fihb.currfindex != fihb.nextfindex)) {
862 fihb.currfindex = fihb.nextfindex;
863 fihb.currftag = fihb.nextftag;
864 }
865
866 BIH_LABEL(expb.curbih) = lbl;
867 ILIBLKP(lbl, expb.curbih);
868 fihb.currftag = fihb.nextftag;
869 fihb.currfindex = fihb.nextfindex;
870 }
871
872 else if (CCSYMG(lbl) == 0 && DBGBIT(8, 4096))
873 /* defd but not refd */
874 errlabel((error_code_t)120, ERR_Informational, gbl.lineno, SYMNAME(lbl),
875 CNULL);
876 }
877
878 /***************************************************************/
879
880 /*
881 * the following macro is used by the load and store code to determine if the
882 * load or store operation conflicts with the data type of the item being
883 * fetched or stored. This is done for those names entries which are
884 * constant array or indirection references.
885 * Conflicts could occur when:
886 * 1. if the operation is for a double data item and the data type is not
887 * double.
888 * 2. if the operation is for a float data item and the data type is not
889 * float.
890 * 3. if the operation is for an integral type and its size is inconsistent
891 * with the size of the data type.
892 * A conflict is resolved by creating an array (or indirection) reference
893 * which has a non-constant offset. The macro argument, "cond", specifies the
894 * whether or not there is a conflict.
895 */
896 #define CHECK_NME(nme, cond) \
897 { \
898 NT_KIND i = NME_TYPE(nme); \
899 if (NME_SYM(nme) == 0 && (i == NT_ARR || i == NT_IND) && (cond)) \
900 nme = add_arrnme(i, NME_NULL, NME_NM(nme), 0, NME_SUB(nme), \
901 NME_INLARR(nme)); \
902 }
903
904 static int
SCALAR_SIZE(DTYPE dtype,int n)905 SCALAR_SIZE(DTYPE dtype, int n)
906 {
907 if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR)
908 /* assume that this a pointer to an adjustable length character */
909 return n;
910 if (dtype == DT_ASSNCHAR || dtype == DT_DEFERNCHAR)
911 return n;
912 return size_of(dtype);
913 }
914
915 /***************************************************************/
916 /*
917 * when inlining a function with an optional argument, where the
918 * optional argument is missing in the call, the compiler passes
919 * a placeholder, pghpf_03, which it then can test for in PRESENT() calls.
920 */
921 int
optional_missing(int nme)922 optional_missing(int nme)
923 {
924 int sptr, cmblk;
925 sptr = NME_SYM(nme);
926 if (CCSYMG(sptr) && SCG(sptr) == SC_CMBLK && ADDRESSG(sptr) == 8) {
927 cmblk = MIDNUMG(sptr);
928 if (strcmp(SYMNAME(cmblk), "pghpf_0") == 0) {
929 return 1;
930 }
931 }
932 return 0;
933 } /* optional_missing */
934
935 /*
936 * same as above, given an ILM pointer
937 */
938 int
optional_missing_ilm(ILM * ilmpin)939 optional_missing_ilm(ILM *ilmpin)
940 {
941 int sptr, cmblk;
942 ILM *ilmp;
943 ilmp = ilmpin;
944 while (1) {
945 switch (ILM_OPC(ilmp)) {
946 case IM_BASE:
947 sptr = ILM_OPND(ilmp, 1);
948 if (CCSYMG(sptr) && SCG(sptr) == SC_CMBLK && ADDRESSG(sptr) == 8) {
949 cmblk = MIDNUMG(sptr);
950 if (strcmp(SYMNAME(cmblk), "pghpf_0") == 0) {
951 return 1;
952 }
953 }
954 return 0;
955 case IM_PLD:
956 case IM_MEMBER:
957 ilmp = (ILM *)(ilmb.ilm_base + ILM_OPND(ilmp, 1));
958 break;
959 case IM_ELEMENT:
960 case IM_INLELEM:
961 ilmp = (ILM *)(ilmb.ilm_base + ILM_OPND(ilmp, 2));
962 break;
963 default:
964 return 0;
965 }
966 }
967 } /* optional_missing_ilm */
968
969 /*
970 * here, we have a load of the missing optional, replace by a zero
971 */
972 void
replace_by_zero(ILM_OP opc,ILM * ilmp,int curilm)973 replace_by_zero(ILM_OP opc, ILM *ilmp, int curilm)
974 {
975 INT num[4];
976 int zero;
977 ILM_OP newopc;
978 int i1 = ILM_OPND(ilmp, 1);
979 switch (opc) {
980 /* handle complex */
981 case IM_CLD:
982 num[0] = 0;
983 num[1] = 0;
984 zero = getcon(num, DT_CMPLX);
985 newopc = IM_CDCON;
986 break;
987 case IM_CDLD:
988 num[0] = stb.dbl0;
989 num[1] = stb.dbl0;
990 zero = getcon(num, DT_DCMPLX);
991 newopc = IM_CCON;
992 break;
993 case IM_ILD:
994 case IM_LLD:
995 case IM_LFUNC: /* LFUNC, for PRESENT calls replaced by zero */
996 zero = stb.i0;
997 newopc = IM_ICON;
998 break;
999
1000 case IM_KLD:
1001 case IM_KLLD:
1002 zero = stb.k0;
1003 newopc = IM_KCON;
1004 break;
1005
1006 case IM_SLLD:
1007 case IM_SILD:
1008 case IM_CHLD:
1009 zero = stb.i0;
1010 newopc = IM_ICON;
1011 break;
1012
1013 case IM_RLD:
1014 zero = stb.flt0;
1015 newopc = IM_RCON;
1016 break;
1017
1018 case IM_DLD:
1019 zero = stb.dbl0;
1020 newopc = IM_DCON;
1021 break;
1022
1023 case IM_PLD:
1024 zero = stb.i0;
1025 newopc = IM_ICON;
1026 break;
1027
1028 default:
1029 interr("replace_by_zero opc not cased", opc, ERR_Severe);
1030 break;
1031 }
1032 /* CHANGE the ILM in place */
1033 SetILM_OPC(ilmp, newopc);
1034 ILM_OPND(ilmp, 1) = zero;
1035 /* process as a constant */
1036 eval_ilm(curilm);
1037 SetILM_OPC(ilmp, opc);
1038 ILM_OPND(ilmp, 1) = i1;
1039 } /* replace_by_zero */
1040
1041 /*
1042 * when inlining a function with an optional argument, where the
1043 * optional argument is present in the call, the compiler passes
1044 * the argument, which we can detect as present since it's
1045 * not a DUMMY
1046 */
1047 int
optional_present(int nme)1048 optional_present(int nme)
1049 {
1050 int sptr, cmblk, ptr;
1051 sptr = NME_SYM(nme);
1052 if (SCG(sptr) == SC_LOCAL) {
1053 return 1;
1054 } else if (SCG(sptr) == SC_BASED) {
1055 ptr = MIDNUMG(sptr);
1056 if (SCG(ptr) == SC_LOCAL || SCG(ptr) == SC_CMBLK) {
1057 return 1;
1058 }
1059 } else if (SCG(sptr) == SC_CMBLK) {
1060 cmblk = MIDNUMG(sptr);
1061 if (strcmp(SYMNAME(cmblk), "pghpf_0") != 0) {
1062 return 1;
1063 }
1064 }
1065 return 0;
1066 } /* optional_present */
1067
1068 /*
1069 * replace this by one
1070 * use this to inline a function call that we know is TRUE
1071 */
1072 void
replace_by_one(ILM_OP opc,ILM * ilmp,int curilm)1073 replace_by_one(ILM_OP opc, ILM *ilmp, int curilm)
1074 {
1075 INT num[4];
1076 int one;
1077 ILM_OP newopc;
1078 int i1;
1079 i1 = ILM_OPND(ilmp, 1);
1080 switch (opc) {
1081 case IM_LFUNC: /* LFUNC, for PRESENT calls replaced by one */
1082 one = stb.i1;
1083 newopc = IM_ICON;
1084 break;
1085
1086 default:
1087 interr("replace_by_one opc not cased", opc, ERR_Severe);
1088 break;
1089 }
1090 /* CHANGE the ILM in place */
1091 SetILM_OPC(ilmp, newopc);
1092 ILM_OPND(ilmp, 1) = one;
1093 /* process as a constant */
1094 eval_ilm(curilm);
1095 SetILM_OPC(ilmp, opc);
1096 ILM_OPND(ilmp, 1) = i1;
1097 } /* replace_by_one */
1098 /***************************************************************/
1099 void
exp_load(ILM_OP opc,ILM * ilmp,int curilm)1100 exp_load(ILM_OP opc, ILM *ilmp, int curilm)
1101 {
1102 int sym; /* symbol ST item */
1103 int op1;
1104 int imag; /* address of the imag. part if complex */
1105
1106 int nme; /* names entry */
1107 int addr, /* address of the load */
1108 load; /* load ili generated */
1109 SPTR tmp;
1110 int siz; /* MSZ value for load */
1111 DTYPE dt;
1112 bool confl;
1113 ILM *tmpp;
1114
1115 op1 = ILM_OPND(ilmp, 1);
1116 addr = op1;
1117 nme = NME_OF(addr);
1118 if (optional_missing_ilm(ilmp)) {
1119 replace_by_zero(opc, ilmp, curilm);
1120 return;
1121 }
1122
1123 /*
1124 * if the names entry is for a variable which is an array, then a new
1125 * names entry is created which will denote the first element (offset 0)
1126 * of the array -- this catches the cases of '*(a)', where a is an array
1127 * name
1128 */
1129 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1130 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1131
1132 addr = ILI_OF(addr);
1133 switch (opc) {
1134 /* handle complex */
1135 case IM_CLD:
1136 if (XBIT(70, 0x40000000)) {
1137 CHECK_NME(nme, dt_nme(nme) != DT_CMPLX);
1138 load = ad3ili(IL_LDSCMPLX, addr, nme, MSZ_F8);
1139 goto cand_load;
1140 } else {
1141 imag = ad3ili(IL_AADD, addr, ad_aconi(size_of(DT_FLOAT)), 0);
1142 tmp = addnme(NT_MEM, SPTR_NULL, nme, 0);
1143 ILM_RRESULT(curilm) = ad3ili(IL_LDSP, addr, tmp, MSZ_F4);
1144 tmp = addnme(NT_MEM, NOSYM, nme, 4);
1145 ILM_IRESULT(curilm) = ad3ili(IL_LDSP, imag, tmp, MSZ_F4);
1146 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
1147 return;
1148 }
1149 case IM_CDLD:
1150 if (XBIT(70, 0x40000000)) {
1151 CHECK_NME(nme, dt_nme(nme) != DT_DCMPLX);
1152 load = ad3ili(IL_LDDCMPLX, addr, nme, MSZ_F16);
1153 goto cand_load;
1154 } else {
1155 imag = ad3ili(IL_AADD, addr, ad_aconi(size_of(DT_DBLE)), 0);
1156 tmp = addnme(NT_MEM, SPTR_NULL, nme, 0);
1157 ILM_RRESULT(curilm) = ad3ili(IL_LDDP, addr, tmp, MSZ_F8);
1158 tmp = addnme(NT_MEM, NOSYM, nme, 8);
1159 ILM_IRESULT(curilm) = ad3ili(IL_LDDP, imag, tmp, MSZ_F8);
1160 ILM_RESTYPE(curilm) = ILM_ISDCMPLX;
1161 return;
1162 }
1163
1164 case IM_ILD:
1165 case IM_LLD:
1166 confl = false;
1167 dt = dt_nme(nme);
1168 if (dt && DT_ISSCALAR(dt) && SCALAR_SIZE(dt, 4) != 4)
1169 confl = true;
1170 CHECK_NME(nme, confl);
1171 load = ad3ili(IL_LD, addr, nme, MSZ_WORD);
1172 cand_load:
1173 ADDRCAND(load, nme);
1174 break;
1175
1176 case IM_KLD:
1177 case IM_KLLD:
1178 confl = false;
1179 dt = dt_nme(nme);
1180 if (dt && DT_ISSCALAR(dt) && SCALAR_SIZE(dt, 8) != 8)
1181 confl = true;
1182 CHECK_NME(nme, confl);
1183 if (XBIT(124, 0x400)) {
1184 load = ad3ili(IL_LDKR, addr, nme, MSZ_I8);
1185 rcandb.kr = 1;
1186 } else {
1187 if (flg.endian)
1188 addr = ad3ili(IL_AADD, addr, ad_aconi((INT)size_of(DT_INT)), 0);
1189 load = ad3ili(IL_LD, addr, nme, MSZ_WORD);
1190 }
1191 ADDRCAND(load, nme);
1192 break;
1193
1194 case IM_SLLD:
1195 case IM_SILD:
1196 siz = MSZ_SHWORD;
1197 ld_hw:
1198 confl = false;
1199 dt = dt_nme(nme);
1200 if (dt && DT_ISSCALAR(dt) && size_of(dt) != 2)
1201 confl = true;
1202 CHECK_NME(nme, confl);
1203 load = ad3ili(IL_LD, addr, nme, siz);
1204 goto cand_load;
1205
1206 case IM_CHLD:
1207 siz = MSZ_SBYTE;
1208 ld_byte:
1209 confl = false;
1210 dt = dt_nme(nme);
1211 if (dt && DT_ISSCALAR(dt) && size_of(dt) != 1)
1212 confl = true;
1213 CHECK_NME(nme, confl);
1214 load = ad3ili(IL_LD, addr, nme, siz);
1215 goto cand_load;
1216
1217 case IM_RLD:
1218 CHECK_NME(nme, dt_nme(nme) != DT_FLOAT);
1219 load = ad3ili(IL_LDSP, addr, nme, MSZ_F4);
1220 goto cand_load;
1221
1222 case IM_DLD:
1223 CHECK_NME(nme, dt_nme(nme) != DT_DBLE);
1224 load = ad3ili(IL_LDDP, addr, nme, MSZ_F8);
1225 goto cand_load;
1226 case IM_QLD: /*m128*/
1227 CHECK_NME(nme, DTY(dt_nme(nme)) != TY_128);
1228 load = ad3ili(IL_LDQ, addr, nme, MSZ_F16);
1229 goto cand_load;
1230 case IM_M256LD: /*m256*/
1231 CHECK_NME(nme, DTY(dt_nme(nme)) != TY_256);
1232 load = ad3ili(IL_LD256, addr, nme, MSZ_F32);
1233 goto cand_load;
1234 #ifdef LONG_DOUBLE_FLOAT128
1235 case IM_FLOAT128LD:
1236 CHECK_NME(nme, DTY(dt_nme(nme)) != TY_FLOAT128);
1237 load = ad3ili(IL_FLOAT128LD, addr, nme, MSZ_F16);
1238 goto cand_load;
1239 #endif /* LONG_DOUBLE_FLOAT128 */
1240
1241 case IM_PLD:
1242 /* fortran: pointer variables are really integer variables;
1243 * later phases 'depend' on seeing references via pointers
1244 * via the 'LDA' ili.
1245 */
1246 /* if using integer*8 variables and not 64-bit precision,
1247 adjust the address of pointer */
1248 /* ???
1249 if (flg.endian && !XBIT(124,0x400))
1250 */
1251 if (flg.endian) {
1252 tmp = ILM_SymOPND(ilmp, 2);
1253 tmpp = (ILM *)(ilmb.ilm_base + ILM_OPND(ilmp, 1));
1254 if (((tmp == SPTR_NULL) && DTYPEG(ILM_OPND(tmpp, 1)) == DT_INT8) ||
1255 (SCG(tmp) == SC_BASED && DTYPEG(MIDNUMG(tmp)) == DT_INT8))
1256 addr = ad3ili(IL_AADD, addr, ad_aconi(size_of(DT_INT)), 0);
1257 }
1258 load = ad2ili(IL_LDA, addr, nme);
1259 ADDRCAND(load, nme);
1260 /*
1261 * if the 2nd operand is non-zero, then the 2nd operand is the
1262 * symbol table entry of some sort of based object. The symbol
1263 * table entry is the object in a POINTER statement
1264 *
1265 * For POINTER, a names entry of NT_IND through the pointer variable
1266 * is sufficent.
1267 *
1268 * When the PLD is to load the pointer to a character object, the
1269 * additional character information needs to be created (examine
1270 * the data type of the symbol which is the second operand.
1271 */
1272 tmp = ILM_SymOPND(ilmp, 2);
1273 if (tmp) {
1274 DTYPE dtype;
1275 #if DEBUG
1276 if (!(tmp && DEVICECOPYG(tmp) && DEVCOPYG(tmp))) {
1277 assert(STYPEG(tmp) == ST_MEMBER || SCG(tmp) == SC_BASED ||
1278 SCG(tmp) == SC_EXTERN,
1279 "exp_load:PLD op#2 not based sym, member, or procedure pointer",
1280 tmp, ERR_Severe);
1281 }
1282 #endif
1283 dtype = DDTG(DTYPEG(tmp));
1284 if (DTY(dtype) == TY_PTR)
1285 dtype = DTySeqTyElement(dtype);
1286 if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) {
1287 int mxlen, clen;
1288 mxlen = 0;
1289 if ((dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR) && SDSCG(tmp)) {
1290 if (STYPEG(tmp) == ST_MEMBER) {
1291 int member, base;
1292 member = ILM_OPND(ilmp, 1);
1293 base = ilmb.ilm_base[member + 1];
1294 clen = exp_get_sdsc_len(tmp, ILI_OF(base), NME_OF(base));
1295 } else {
1296 clen = exp_get_sdsc_len(tmp, 0, 0);
1297 }
1298 } else
1299 if (
1300 STYPEG(tmp) != ST_MEMBER &&
1301 CLENG(tmp) > 0) {
1302 if (CHARLEN_64BIT) {
1303 int clensym, ili;
1304 clensym = CLENG(tmp);
1305 if (size_of(DTYPEG(clensym)) == 8) {
1306 ili = mk_address(CLENG(tmp));
1307 clen = ad3ili(IL_LDKR, ili, addnme(NT_VAR, CLENG(tmp), 0, 0),
1308 MSZ_I8);
1309 } else {
1310 /*
1311 * -Mlarge_arrays (large character lengths WORK-AROUND)
1312 * there are several cases where the front-end IS NOT creating
1313 * 64-bit length temps, e.g., the length temp for the adjustl
1314 * intrinisc. When we're ready to correct the support of
1315 * large character, this section of code ought to turn into
1316 * an assert.
1317 */
1318 ili = mk_address(CLENG(tmp));
1319 clen = ad3ili(IL_LD, ili, addnme(NT_VAR, CLENG(tmp), 0, 0),
1320 MSZ_WORD);
1321 clen = ad1ili(IL_IKMV, clen);
1322 }
1323 } else {
1324 int ili = mk_address(CLENG(tmp));
1325 clen =
1326 ad3ili(IL_LD, ili, addnme(NT_VAR, CLENG(tmp), 0, 0), MSZ_WORD);
1327 }
1328 }
1329 else if (DTyCharLength(dtype) == 0 && SDSCG(tmp)) {
1330 clen = exp_get_sdsc_len(tmp, 0, 0);
1331 }
1332 else if (CHARLEN_64BIT)
1333 clen = mxlen = ad_kconi(DTyCharLength(dtype));
1334 else
1335 clen = mxlen = ad_icon(DTyCharLength(dtype));
1336 ILM_CLEN(curilm) = clen;
1337 ILM_MXLEN(curilm) = mxlen;
1338 ILM_RESTYPE(curilm) = ILM_ISCHAR;
1339 } else if (STYPEG(tmp) == ST_MEMBER) {
1340 ILM_NME(curilm) = addnme(NT_IND, SPTR_NULL, nme, 0);
1341 #ifdef DEVICEG
1342 } else if (DEVICEG(tmp) && DT_ISBASIC(DTYPEG(tmp))) {
1343 ILM_NME(curilm) = addnme(NT_VAR, tmp, 0, 0);
1344 #ifdef TEXTUREG
1345 } else if (DEVICEG(tmp) && TEXTUREG(tmp)) {
1346 ILM_NME(curilm) = addnme(NT_VAR, tmp, 0, 0);
1347 #endif
1348 #endif
1349 } else if (NOCONFLICTG(tmp)) {
1350 /* the frontend has determined that this pointer-based object
1351 * cannot conflict with other references via pointers; for
1352 * example, allocatable arrays and automatic arrays.
1353 */
1354 ILM_NME(curilm) = addnme(NT_VAR, tmp, 0, 0);
1355 } else if (XBIT(125, 0x40)) {
1356 /* Cray's pointer semantics */
1357 ILM_NME(curilm) = addnme(NT_VAR, tmp, 0, 0);
1358 } else {
1359 ILM_NME(curilm) = addnme(NT_IND, SPTR_NULL, nme, 0);
1360 }
1361 } else {
1362 ILM_NME(curilm) = addnme(NT_IND, SPTR_NULL, nme, 0);
1363 }
1364 break;
1365
1366 #ifdef LONG_DOUBLE_FLOAT128
1367 case IM_CFLOAT128LD:
1368 ILM_RRESULT(curilm) =
1369 ad3ili(IL_FLOAT128LD, addr, addnme(NT_MEM, 0, nme, 0), MSZ_F16);
1370 ILM_IRESULT(curilm) =
1371 ad3ili(IL_FLOAT128LD, ad3ili(IL_AADD, addr, ad_aconi(16), 0),
1372 addnme(NT_MEM, 1, nme, 16), MSZ_F16);
1373 ILM_RESTYPE(curilm) = ILM_ISFLOAT128CMPLX;
1374 return;
1375 #endif /* LONG_DOUBLE_FLOAT128 */
1376
1377 default:
1378 interr("exp_load opc not cased", opc, ERR_Severe);
1379 break;
1380 }
1381
1382 ILM_RESULT(curilm) = load;
1383 }
1384
1385 /***************************************************************/
1386 /***************************************************************/
1387
1388 /***** try to use ASSN for all user variables, all compilers *****/
1389 void
set_assn(int nme)1390 set_assn(int nme)
1391 {
1392 int s = basesym_of(nme);
1393 if (s)
1394 ASSNP(s, 1);
1395 }
1396 #define SET_ASSN(n) set_assn(n)
1397
1398 void
exp_store(ILM_OP opc,ILM * ilmp,int curilm)1399 exp_store(ILM_OP opc, ILM *ilmp, int curilm)
1400 {
1401 INT val[2]; /* constant value array */
1402 int nme; /* names entry */
1403 int op1, /* operand 1 of the ILM */
1404 op2; /* operand 2 of the ILM */
1405 int store, /* store ili generated */
1406 addr, /* address ili where value stored */
1407 expr, /* ili of value being stored */
1408 sym, /* ST item */
1409 siz, /* size of the field in the field store */
1410 cnt, /* left shift amount to field align expr*/
1411 ilix, /* ili index */
1412 ilix1; /* ili index */
1413 INT n, un; /* value of field mask */
1414 int tmp;
1415 DTYPE dt;
1416 bool confl;
1417 ILM *tmpp;
1418
1419 int imag; /* address of the imag. part if complex */
1420
1421 op1 = ILM_OPND(ilmp, 1);
1422
1423 op2 = ILM_OPND(ilmp, 2);
1424 nme = NME_OF(op1);
1425 if (opc != IM_PSEUDOST) {
1426 if (optional_missing_ilm(ilmp)) {
1427 /* this is a store to a missing optional argument.
1428 * it must be on a path that is branched around, or it is illegal.
1429 * simply drop the expression */
1430 return;
1431 }
1432 }
1433
1434 switch (opc) {
1435 case IM_LST:
1436 case IM_IST:
1437 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1438 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1439 confl = false;
1440 dt = dt_nme(nme);
1441 if (dt && DT_ISSCALAR(dt) && SCALAR_SIZE(dt, 4) != 4)
1442 confl = true;
1443 CHECK_NME(nme, confl);
1444 ilix = ILI_OF(op2);
1445 if (IL_RES(ILI_OPC(ilix)) == ILIA_AR)
1446 ilix = ad1ili(IL_AIMV, ilix);
1447 store = ad4ili(IL_ST, ilix, ILI_OF(op1), nme, MSZ_WORD);
1448 cand_store:
1449 if (NME_TYPE(nme) == NT_VAR)
1450 ASSNP(NME_SYM(nme), 1);
1451 ADDRCAND(store, nme);
1452 SET_ASSN(nme);
1453 break;
1454
1455 case IM_KLST:
1456 case IM_KST:
1457 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1458 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1459 confl = false;
1460 dt = dt_nme(nme);
1461 if (dt && DT_ISSCALAR(dt) && SCALAR_SIZE(dt, 8) != 8)
1462 confl = true;
1463 if (XBIT(124, 0x400)) {
1464 /* problem arose with the pointer statement and the value
1465 * returned by the call to ftn_allocate being an IR
1466 * AND (as of 12/09/2010) with the result being an AR
1467 */
1468 ilix = ILI_OF(op2);
1469 if (IL_RES(ILI_OPC(ilix)) == ILIA_AR)
1470 ilix = ad1ili(IL_AKMV, ilix);
1471 else {
1472 if (IL_RES(ILI_OPC(ilix)) != ILIA_KR)
1473 ilix = ad1ili(IL_IKMV, ilix);
1474 }
1475 store = ad4ili(IL_STKR, ilix, ILI_OF(op1), nme, MSZ_I8);
1476 rcandb.kr = 1;
1477 } else {
1478 addr = ILI_OF(op1);
1479 if (flg.endian)
1480 addr = ad3ili(IL_AADD, (int)ILI_OF(op1), ad_aconi((INT)size_of(DT_INT)),
1481 0);
1482 ilix = ILI_OF(op2);
1483 if (IL_RES(ILI_OPC(ilix)) == ILIA_AR)
1484 ilix = ad1ili(IL_AIMV, ilix);
1485 else if (IL_RES(ILI_OPC(ilix)) == ILIA_KR)
1486 ilix = ad1ili(IL_KIMV, ilix);
1487 store = ad4ili(IL_ST, ilix, addr, nme, MSZ_WORD);
1488 }
1489 CHECK_NME(nme, confl);
1490 if (NME_TYPE(nme) == NT_VAR)
1491 ASSNP(NME_SYM(nme), 1);
1492 ADDRCAND(store, nme);
1493 SET_ASSN(nme);
1494 break;
1495
1496 case IM_SLST:
1497 case IM_SIST:
1498 siz = MSZ_SHWORD;
1499 do_sist:
1500 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1501 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1502 confl = false;
1503 dt = dt_nme(nme);
1504 if (dt && DT_ISSCALAR(dt) && size_of(dt) != 2)
1505 confl = true;
1506 CHECK_NME(nme, confl);
1507 expr = ILI_OF(op2);
1508 store = ad4ili(IL_ST, expr, (int)ILI_OF(op1), nme, siz);
1509 goto cand_store;
1510
1511 case IM_CHST:
1512 siz = MSZ_SBYTE;
1513 do_chst:
1514 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1515 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1516 confl = false;
1517 dt = dt_nme(nme);
1518 if (dt && DT_ISSCALAR(dt) && size_of(dt) != 1)
1519 confl = true;
1520 CHECK_NME(nme, confl);
1521 expr = ILI_OF(op2);
1522 store = ad4ili(IL_ST, expr, (int)ILI_OF(op1), nme, siz);
1523 goto cand_store;
1524
1525 case IM_AST:
1526 expr = ILI_OF(op2);
1527 if (IL_RES(ILI_OPC(expr)) == ILIA_AR)
1528 expr = ad1ili(IL_AIMV, expr);
1529 store = ad4ili(IL_ST, expr, (int)ILI_OF(op1), nme, MSZ_WORD);
1530 SET_ASSN(nme);
1531 break;
1532
1533 case IM_KAST:
1534 addr = ILI_OF(op1);
1535 expr = ILI_OF(op2);
1536 if (IL_RES(ILI_OPC(expr)) == ILIA_AR)
1537 expr = ad1ili(IL_AKMV, expr);
1538 store = ad4ili(IL_STKR, expr, addr, nme, MSZ_I8);
1539 SET_ASSN(nme);
1540 break;
1541
1542 case IM_PSTRG1:
1543 store = ad2ili(IL_STRG1, (int)ILI_OF(op1), op2);
1544 break;
1545
1546 case IM_PST:
1547 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1548 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1549 confl = false;
1550 dt = dt_nme(nme);
1551 if (dt && DT_ISSCALAR(dt) && SCALAR_SIZE(dt, 8) != 8)
1552 confl = true;
1553 CHECK_NME(nme, confl);
1554 expr = ILI_OF(op2);
1555 switch (ILI_OPC(expr)) {
1556 case IL_AIMV:
1557 case IL_AKMV:
1558 expr = ILI_OPND(expr, 1);
1559 break;
1560 default:
1561 break;
1562 }
1563 if (IL_RES(ILI_OPC(expr)) != ILIA_AR) {
1564 expr = ad1ili(IL_KAMV, expr);
1565 }
1566 store = ad3ili(IL_STA, expr, (int)ILI_OF(op1), nme);
1567
1568 /*
1569 * check if &var is being stored. If so, the base symbol's "address
1570 * taken" flag is set.
1571 */
1572 loc_of((int)NME_OF(op2));
1573
1574 /*
1575 * store the names result of the store -- this is just an indirection
1576 * based on the names entry of the STA
1577 */
1578 ILM_NME(curilm) = addnme(NT_IND, SPTR_NULL, nme, (INT)0);
1579 goto cand_store;
1580
1581 case IM_RST:
1582 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1583 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1584 CHECK_NME(nme, dt_nme(nme) != DT_FLOAT);
1585 store = ad4ili(IL_STSP, (int)ILI_OF(op2), (int)ILI_OF(op1), nme, MSZ_F4);
1586 goto cand_store;
1587
1588 case IM_DST:
1589 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1590 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1591 CHECK_NME(nme, dt_nme(nme) != DT_DBLE);
1592 store = ad4ili(IL_STDP, (int)ILI_OF(op2), (int)ILI_OF(op1), nme, MSZ_F8);
1593 goto cand_store;
1594 case IM_QST: /*m128*/
1595 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1596 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1597 CHECK_NME(nme, DTY(dt_nme(nme)) != TY_128);
1598 store = ad4ili(IL_STQ, (int)ILI_OF(op2), (int)ILI_OF(op1), nme, MSZ_F16);
1599 goto cand_store;
1600 case IM_M256ST: /*m256*/
1601 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1602 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1603 CHECK_NME(nme, DTY(dt_nme(nme)) != TY_256);
1604 store = ad4ili(IL_ST256, ILI_OF(op2), ILI_OF(op1), nme, MSZ_F32);
1605 goto cand_store;
1606
1607 #ifdef LONG_DOUBLE_FLOAT128
1608 case IM_FLOAT128ST:
1609 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1610 nme = add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1611 CHECK_NME(nme, DTY(dt_nme(nme)) != TY_FLOAT128);
1612 store = ad4ili(IL_FLOAT128ST, ILI_OF(op2), ILI_OF(op1), nme, MSZ_F16);
1613 goto cand_store;
1614 #endif /* LONG_DOUBLE_FLOAT128 */
1615
1616 case IM_SMOVE: /* make sure this works for both languages */
1617 SET_ASSN(NME_OF(op1));
1618 {
1619 ILM *ilmpx = (ILM *)(ilmb.ilm_base + op2);
1620 int rsi = ilm_return_slot_index((ILM_T *)ilmpx);
1621 if (rsi) {
1622 ilmpx = (ILM *)(ilmb.ilm_base + ILM_OPND(ilmpx, rsi));
1623 if (ILM_OPC(ilmpx) == IM_LOC && ILM_OPND(ilmpx, 1) == op1) {
1624 /* avoid useless struct copy for functions returning structs */
1625 chk_block(ILI_OF(op2));
1626 ILM_NME(curilm) = NME_OF(op2);
1627 ILM_RESULT(curilm) = ILI_OF(op2);
1628 return;
1629 }
1630 if (XBIT(121, 0x800) &&
1631 ILM_OPC((ILM *)(ilmb.ilm_base + op2)) == IM_SFUNC &&
1632 ILM_OPC(ilmpx) == IM_FARG) {
1633 /*
1634 * Have SMOVE representing LHS = SFUNC().
1635 * SFUNC expands to a JSR with the result as the first hidden
1636 * argument; make the LHS the result.
1637 */
1638 ilix = ILI_OF(op2); /* IL_JSR */
1639 ilix1 = ILI_OPND(ilix, 2); /* IL_ARGAR of the result */
1640 ILI_OPND(ilix1, 1) = ILI_OF(op1); /* replace result with LHS */
1641 ilix1 = ILI_ALT(ilix); /* IL_JSR's IL_GJSR */
1642 ilix1 = ILI_OPND(ilix1, 2); /* IL_GARGRET */
1643 ILI_OPND(ilix1, 1) = ILI_OF(op1);
1644 ILI_OPND(ilix1, 4) = NME_OF(op1);
1645 chk_block(ilix);
1646 ILM_NME(curilm) = NME_OF(op1);
1647 ILM_RESULT(curilm) = ilix;
1648 return;
1649 }
1650 }
1651 }
1652 expand_smove(op1, op2, ILM_DTyOPND(ilmp, 3));
1653 ILM_RESULT(curilm) = ILI_OF(op2);
1654 ILM_NME(curilm) = NME_OF(op2);
1655 return;
1656
1657 case IM_SZERO: /* make sure this works for both languages */
1658 SET_ASSN(NME_OF(op1));
1659 exp_szero(ilmp, curilm, op1, op2, (int)ILM_OPND(ilmp, 3));
1660 ILM_RESULT(curilm) = 0;
1661 ILM_NME(curilm) = NME_UNK;
1662 return;
1663
1664 case IM_PSEUDOST:
1665 expr = ILI_OF(op2);
1666 switch (IL_RES(ILI_OPC(expr))) {
1667 case ILIA_IR:
1668 store = ad1ili(IL_FREEIR, expr);
1669 break;
1670
1671 case ILIA_SP:
1672 /*
1673 * For complex, store the imaginary part and then the real part.
1674 * Then fall thru to set the ilm's real result and block number
1675 * and update the block.
1676 */
1677 if (ILM_RESTYPE(op2) == ILM_ISCMPLX) {
1678 store = ad1ili(IL_FREESP, (int)ILM_IRESULT(op2));
1679 chk_block(store);
1680 ILM_IRESULT(curilm) = store;
1681 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
1682 if (EXPDBG(8, 16))
1683 fprintf(gbl.dbgfil, "store imag: ilm %d, block %d, ili %d\n", curilm,
1684 expb.curbih, store);
1685 }
1686 store = ad1ili(IL_FREESP, expr);
1687 break;
1688
1689 case ILIA_DP:
1690 if (ILM_RESTYPE(op2) == ILM_ISDCMPLX) {
1691 store = ad1ili(IL_FREEDP, (int)ILM_IRESULT(op2));
1692 chk_block(store);
1693 ILM_IRESULT(curilm) = store;
1694 ILM_RESTYPE(curilm) = ILM_ISDCMPLX;
1695 if (EXPDBG(8, 16))
1696 fprintf(gbl.dbgfil, "store imag: ilm %d, block %d, ili %d\n", curilm,
1697 expb.curbih, store);
1698 }
1699 store = ad1ili(IL_FREEDP, expr);
1700 break;
1701 #ifdef ILIA_CS
1702 case ILIA_CS:
1703 store = ad1ili(IL_FREECS, expr);
1704 break;
1705 case ILIA_CD:
1706 store = ad1ili(IL_FREECD, expr);
1707 break;
1708 #endif
1709 case ILIA_AR:
1710 store = ad1ili(IL_FREEAR, expr);
1711 ILM_NME(curilm) = NME_OF(op2);
1712 break;
1713
1714 case ILIA_KR:
1715 store = ad1ili(IL_FREEKR, expr);
1716 break;
1717
1718 #ifdef LONG_DOUBLE_FLOAT128
1719 case ILIA_FLOAT128:
1720 if (ILM_RESTYPE(op2) == ILM_ISFLOAT128CMPLX) {
1721 store = ad1ili(IL_FLOAT128FREE, (int)ILM_IRESULT(op2));
1722 chk_block(store);
1723 ILM_IRESULT(curilm) = store;
1724 ILM_RESTYPE(curilm) = ILM_ISFLOAT128CMPLX;
1725 if (EXPDBG(8, 16))
1726 fprintf(gbl.dbgfil, "store imag: ilm %d, block %d, ili %d\n", curilm,
1727 expb.curbih, store);
1728 }
1729 store = ad1ili(IL_FLOAT128FREE, expr);
1730 break;
1731 #endif /* LONG_DOUBLE_FLOAT128 */
1732
1733 case ILIA_LNK:
1734 dt = ili_get_vect_dtype(expr);
1735 if (dt) {
1736 store = ad2ili(IL_FREE, expr, dt);
1737 break;
1738 }
1739
1740 default:
1741 interr("PSEUDOST: bad link", curilm, ERR_Severe);
1742 }
1743 break;
1744 /* complex stuff */
1745 case IM_CST:
1746 if (XBIT(70, 0x40000000)) {
1747 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1748 nme =
1749 add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1750 CHECK_NME(nme, dt_nme(nme) != DT_CMPLX);
1751 store = ad4ili(IL_STSCMPLX, ILI_OF(op2), ILI_OF(op1), nme, MSZ_F8);
1752 goto cand_store;
1753 } else {
1754 /*
1755 * For complex, store the imaginary part and then the real part.
1756 * Then fall thru to set the ilm's real result and block number
1757 * and update the block.
1758
1759 * If this is a store of return value of float complex,
1760 * need to make nme to NME_UNK otherwise cg will not do correct store.
1761 */
1762 tmp = expb.curilt;
1763 store = ad1ili(IL_FREESP, (int)ILM_RRESULT(op2));
1764 chk_block(store);
1765 if (tmp != expb.curilt)
1766 ILT_CPLX(expb.curilt) = 1;
1767
1768 nme = addnme(NT_MEM, NOSYM, (int)NME_OF(op1), (INT)4);
1769 imag = ad3ili(IL_AADD, (int)ILI_OF(op1), ad_aconi((INT)size_of(DT_FLOAT)),
1770 0);
1771 store = ad4ili(IL_STSP, (int)ILM_IRESULT(op2), imag, nme, MSZ_F4);
1772 tmp = expb.curilt;
1773 chk_block(store);
1774 ILM_IRESULT(curilm) = store;
1775 if (tmp != expb.curilt)
1776 ILT_CPLX(expb.curilt) = 1;
1777 if (EXPDBG(8, 16))
1778 fprintf(gbl.dbgfil, "store imag: ilm %d, block %d, ili %d\n", curilm,
1779 expb.curbih, store);
1780 nme = addnme(NT_MEM, SPTR_NULL, (int)NME_OF(op1), (INT)0);
1781 store = ad4ili(IL_STSP, ad1ili(IL_CSESP, (int)ILM_RRESULT(op2)),
1782 (int)ILI_OF(op1), nme, MSZ_F4);
1783 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
1784 SET_ASSN(nme);
1785 }
1786 goto cmplx_shared;
1787
1788 case IM_CDST:
1789 if (XBIT(70, 0x40000000)) {
1790 if (NME_TYPE(nme) == NT_VAR && DTY(DTYPEG(NME_SYM(nme))) == TY_ARRAY)
1791 nme =
1792 add_arrnme(NT_ARR, SPTR_NULL, nme, 0, ad_icon(0), NME_INLARR(nme));
1793 CHECK_NME(nme, dt_nme(nme) != DT_DCMPLX);
1794 store = ad4ili(IL_STDCMPLX, ILI_OF(op2), ILI_OF(op1), nme, MSZ_F16);
1795 goto cand_store;
1796 } else {
1797 tmp = expb.curilt;
1798 store = ad1ili(IL_FREEDP, (int)ILM_RRESULT(op2));
1799 chk_block(store);
1800 if (tmp != expb.curilt)
1801 ILT_CPLX(expb.curilt) = 1;
1802
1803 nme = addnme(NT_MEM, NOSYM, NME_OF(op1), 8);
1804 imag = ad3ili(IL_AADD, ILI_OF(op1), ad_aconi(size_of(DT_DBLE)), 0);
1805 store = ad4ili(IL_STDP, ILM_IRESULT(op2), imag, nme, MSZ_F8);
1806 tmp = expb.curilt;
1807 chk_block(store);
1808 if (tmp != expb.curilt)
1809 ILT_CPLX(expb.curilt) = 1;
1810 ILM_IRESULT(curilm) = store;
1811 if (EXPDBG(8, 16))
1812 fprintf(gbl.dbgfil, "store imag: ilm %d, block %d, ili %d\n", curilm,
1813 expb.curbih, store);
1814
1815 nme = addnme(NT_MEM, SPTR_NULL, NME_OF(op1), 0);
1816 store = ad4ili(IL_STDP, ad1ili(IL_CSEDP, ILM_RRESULT(op2)), ILI_OF(op1),
1817 nme, MSZ_F8);
1818 ILM_RESTYPE(curilm) = ILM_ISDCMPLX;
1819 }
1820 cmplx_shared:
1821 SET_ASSN(NME_OF(op1));
1822 tmp = expb.curilt;
1823 chk_block(store);
1824 if (tmp != expb.curilt && !XBIT(70, 0x40000000))
1825 ILT_CPLX(expb.curilt) = 1;
1826 ILM_RESULT(curilm) = store;
1827 ILM_BLOCK(curilm) = expb.curbih;
1828
1829 if (XBIT(70, 0x40000000)) {
1830 if (EXPDBG(8, 16))
1831 fprintf(gbl.dbgfil, "store complex: ilm %d, block %d, ili %d\n", curilm,
1832 expb.curbih, store);
1833 } else {
1834 if (EXPDBG(8, 16))
1835 fprintf(gbl.dbgfil, "store real: ilm %d, block %d, ili %d\n", curilm,
1836 expb.curbih, store);
1837 }
1838 return;
1839 case IM_CSTR:
1840 /* ONLY store the real part of a complex */
1841 nme = NME_OF(op1);
1842 nme = addnme(NT_MEM, SPTR_NULL, nme, 0);
1843 addr = ILI_OF(op1);
1844 store = ad4ili(IL_STSP, ILI_OF(op2), addr, nme, MSZ_F4);
1845 ILM_RESULT(curilm) = store;
1846 if (EXPDBG(8, 16))
1847 fprintf(gbl.dbgfil, "ONLY store real: ilm %d, block %d, ili %d\n", curilm,
1848 expb.curbih, store);
1849 SET_ASSN(nme);
1850 break;
1851 case IM_CSTI:
1852 /* ONLY store the imaginary part of a complex */
1853 nme = NME_OF(op1);
1854 nme = addnme(NT_MEM, NOSYM, nme, 4);
1855 addr = ILI_OF(op1);
1856 addr = ad3ili(IL_AADD, addr, ad_aconi((INT)size_of(DT_FLOAT)), 0);
1857 store = ad4ili(IL_STSP, ILI_OF(op2), addr, nme, MSZ_F4);
1858 ILM_RESULT(curilm) = store;
1859 if (EXPDBG(8, 16))
1860 fprintf(gbl.dbgfil, "ONLY store imag: ilm %d, block %d, ili %d\n", curilm,
1861 expb.curbih, store);
1862 SET_ASSN(nme);
1863 break;
1864 case IM_CDSTR:
1865 /* ONLY store the real part of a complex */
1866 nme = NME_OF(op1);
1867 nme = addnme(NT_MEM, SPTR_NULL, nme, 0);
1868 addr = ILI_OF(op1);
1869 store = ad4ili(IL_STDP, ILI_OF(op2), addr, nme, MSZ_F8);
1870 ILM_RESULT(curilm) = store;
1871 if (EXPDBG(8, 16))
1872 fprintf(gbl.dbgfil, "ONLY store real: ilm %d, block %d, ili %d\n", curilm,
1873 expb.curbih, store);
1874 SET_ASSN(nme);
1875 break;
1876 case IM_CDSTI:
1877 /* ONLY store the imaginary part of a complex */
1878 nme = NME_OF(op1);
1879 nme = addnme(NT_MEM, NOSYM, nme, 8);
1880 addr = ILI_OF(op1);
1881 addr = ad3ili(IL_AADD, addr, ad_aconi(size_of(DT_DBLE)), 0);
1882 store = ad4ili(IL_STDP, ILI_OF(op2), addr, nme, MSZ_F8);
1883 ILM_RESULT(curilm) = store;
1884 if (EXPDBG(8, 16))
1885 fprintf(gbl.dbgfil, "ONLY store imag: ilm %d, block %d, ili %d\n", curilm,
1886 expb.curbih, store);
1887 SET_ASSN(nme);
1888 break;
1889
1890 #ifdef LONG_DOUBLE_FLOAT128
1891 case IM_CFLOAT128ST: {
1892 int real = ILM_RRESULT(op2);
1893 store = ad1ili(IL_FLOAT128FREE, real);
1894 tmp = expb.curilt;
1895 chk_block(store);
1896 if (tmp != expb.curilt)
1897 ILT_CPLX(expb.curilt) = 1;
1898 nme = addnme(NT_MEM, 1, NME_OF(op1), 16);
1899 tmp = ad3ili(IL_AADD, ILI_OF(op1), ad_aconi(16), 0);
1900 store = ad4ili(IL_FLOAT128ST, ILM_IRESULT(op2), tmp, nme, MSZ_F16);
1901 ILM_IRESULT(curilm) = store;
1902 tmp = expb.curilt;
1903 chk_block(store);
1904 if (tmp != expb.curilt)
1905 ILT_CPLX(expb.curilt) = 1;
1906 nme = addnme(NT_MEM, 0, NME_OF(op1), 0);
1907 real = ad_cse(real);
1908 store = ad4ili(IL_FLOAT128ST, real, ILI_OF(op1), nme, MSZ_F16);
1909 tmp = expb.curilt;
1910 chk_block(store);
1911 if (tmp != expb.curilt)
1912 ILT_CPLX(expb.curilt) = 1;
1913 ILM_RRESULT(curilm) = store;
1914 ILM_BLOCK(curilm) = expb.curbih;
1915 ILM_RESTYPE(curilm) = ILM_ISFLOAT128CMPLX;
1916 SET_ASSN(NME_OF(op1));
1917 return;
1918 }
1919
1920 case IM_CFLOAT128STR:
1921 /* ONLY store the real part of a complex */
1922 nme = NME_OF(op1);
1923 nme = addnme(NT_MEM, 0, nme, (INT)0);
1924 addr = ILI_OF(op1);
1925 store = ad4ili(IL_FLOAT128ST, ILI_OF(op2), addr, nme, MSZ_F16);
1926 ILM_RESULT(curilm) = store;
1927 SET_ASSN(nme);
1928 break;
1929
1930 case IM_CFLOAT128STI:
1931 /* ONLY store the imaginary part of a complex */
1932 nme = NME_OF(op1);
1933 nme = addnme(NT_MEM, 1, nme, (INT)16);
1934 addr = ILI_OF(op1);
1935 addr = ad3ili(IL_AADD, addr, ad_aconi(16), 0);
1936 store = ad4ili(IL_FLOAT128ST, ILI_OF(op2), addr, nme, MSZ_F16);
1937 ILM_RESULT(curilm) = store;
1938 SET_ASSN(nme);
1939 break;
1940 #endif /* LONG_DOUBLE_FLOAT128 */
1941
1942 default:
1943 interr("exp_store: ilm not cased", curilm, ERR_Severe);
1944 break;
1945 } /***** end of switch(opc) *****/
1946
1947 end_exp_store:
1948
1949 if (!exp_end_atomic(store, curilm)) {
1950 chk_block(store);
1951 ILM_RESULT(curilm) = store;
1952 ILM_BLOCK(curilm) = expb.curbih;
1953 }
1954
1955 if (EXPDBG(8, 16))
1956 fprintf(gbl.dbgfil, "store result: ilm %d, block %d, ili %d\n", curilm,
1957 expb.curbih, store);
1958 }
1959
1960 /***************************************************************/
1961 /*
1962 * this routine expands the ilm which are defined as macros. The macro
1963 * expansion of an ilm is relatively straight forward and is defined by the
1964 * information in the template definitions as processed by the ilmtp utility.
1965 */
1966 int
exp_mac(ILM_OP opc,ILM * ilmp,int curilm)1967 exp_mac(ILM_OP opc, ILM *ilmp, int curilm)
1968 {
1969
1970 int ilicnt, noprs, i;
1971 unsigned int pattern, index;
1972 DTYPE dtype;
1973 union {
1974 INT numi[2];
1975 DBLE numd;
1976 } num;
1977 ILI newili;
1978 ILMOPND *ilmopr;
1979 ILMMAC *ilmtpl;
1980 char *nmptr;
1981
1982 /*
1983 * locate the following for the ilm - the number of ili the ilm expands
1984 * to (ilicnt), its length, and the index into the template area of the
1985 * first ili (pattern)
1986 */
1987 index = 0;
1988 ilicnt = ilms[opc].ilict;
1989 pattern = ilms[opc].pattern;
1990
1991 /* Loop for each ili template in this ILM expansion */
1992 while (ilicnt-- > 0) {
1993 ilmtpl = (ILMMAC *)&ilmtp[pattern];
1994
1995 newili.opc = (ILI_OP)ilmtpl->opc; /* get ili opcode */ // ???
1996
1997 /* Loop for each operand in this ili template */
1998 for (i = 0, noprs = ilis[newili.opc].oprs; noprs > 0; ++i, --noprs) {
1999
2000 ilmopr = (ILMOPND *)&ilmopnd[ilmtpl->opnd[i]];
2001 switch (ilmopr->type) {
2002
2003 case ILMO_P:
2004 newili.opnd[i] = ILM_RESULT(ILM_OPND(ilmp, ilmopr->aux));
2005 break;
2006
2007 case ILMO_RP:
2008 newili.opnd[i] = ILM_RRESULT(ILM_OPND(ilmp, ilmopr->aux));
2009 break;
2010
2011 case ILMO_IP:
2012 newili.opnd[i] = ILM_IRESULT(ILM_OPND(ilmp, ilmopr->aux));
2013 break;
2014
2015 case ILMO_T:
2016 newili.opnd[i] = ILM_TEMP(ilmopr->aux);
2017 break;
2018
2019 case ILMO_V:
2020 newili.opnd[i] = ILM_OPND(ilmp, ilmopr->aux);
2021 break;
2022
2023 case ILMO_IV:
2024 newili.opnd[i] = ilmopr->aux;
2025 break;
2026 case ILMO_DR:
2027 newili.opnd[i] = IR(ilmopr->aux);
2028 break;
2029 case ILMO_AR:
2030 newili.opnd[i] = AR(ilmopr->aux);
2031 break;
2032 case ILMO_SP:
2033 newili.opnd[i] = SP(ilmopr->aux);
2034 break;
2035 case ILMO_DP:
2036 newili.opnd[i] = DP(ilmopr->aux);
2037 break;
2038 case ILMO_ISP:
2039 newili.opnd[i] = ISP(ilmopr->aux);
2040 break;
2041 case ILMO_IDP:
2042 newili.opnd[i] = IDP(ilmopr->aux);
2043 break;
2044
2045 case ILMO_SZ:
2046 dtype = DT_INT;
2047 num.numi[0] = 0;
2048 num.numi[1] = size_of((DTYPE)ILM_OPND(ilmp, ilmopr->aux));
2049 if (num.numi[1] == 0)
2050 num.numi[1] = 1;
2051 goto get_con;
2052
2053 case ILMO_SCZ: /* size with the scale factored out */
2054 dtype = DT_INT;
2055 num.numi[0] = 0;
2056 scale_of((DTYPE)ILM_OPND(ilmp, ilmopr->aux), &num.numi[1]);
2057 goto get_con;
2058
2059 case ILMO_RSYM:
2060 nmptr = ilmaux[ilmopr->aux];
2061 dtype = DT_FLOAT;
2062 num.numi[0] = 0;
2063 if (atoxf(nmptr, &num.numi[1], strlen(nmptr)) != 0)
2064 interr("exp_mac: RSYM error", curilm, ERR_Severe);
2065 goto get_con;
2066
2067 case ILMO_DSYM:
2068 nmptr = ilmaux[ilmopr->aux];
2069 dtype = DT_DBLE;
2070 if (atoxd(nmptr, num.numd, strlen(nmptr)) != 0)
2071 interr("exp_mac: DSYM error", curilm, ERR_Severe);
2072 goto get_con;
2073
2074 case ILMO_XRSYM:
2075 nmptr = ilmaux[ilmopr->aux];
2076 dtype = DT_FLOAT;
2077 num.numi[0] = 0;
2078 if (atoxi(nmptr, &num.numi[1], strlen(nmptr), 16) != 0)
2079 interr("exp_mac: XRSYM error", curilm, ERR_Severe);
2080 goto get_con;
2081
2082 case ILMO_XDSYM:
2083 nmptr = ilmaux[ilmopr->aux];
2084 dtype = DT_DBLE;
2085 {
2086 int len;
2087 char *p;
2088 for (len = 0, p = nmptr; *p != ','; p++) {
2089 if (*p)
2090 len++;
2091 else {
2092 interr("exp_mac: XDSYM error1", curilm, ERR_Severe);
2093 goto get_con;
2094 }
2095 }
2096 if (atoxi(nmptr, &num.numi[0], len, 16) != 0) {
2097 interr("exp_mac: XDSYM error2", curilm, ERR_Severe);
2098 goto get_con;
2099 }
2100 p++;
2101 if (atoxi(p, &num.numi[1], strlen(p), 16) != 0) {
2102 interr("exp_mac: XDSYM error3", curilm, ERR_Severe);
2103 }
2104 }
2105 goto get_con;
2106 case ILMO_LLSYM:
2107 nmptr = ilmaux[ilmopr->aux];
2108 dtype = DT_INT8;
2109 num.numi[0] = 0;
2110 if (atoxi64(nmptr, &num.numi[0], strlen(nmptr), 10) != 0)
2111 interr("exp_mac: LSYM error", curilm, ERR_Severe);
2112 goto get_con;
2113 case ILMO_ISYM:
2114 nmptr = ilmaux[ilmopr->aux];
2115 dtype = DT_INT;
2116 num.numi[0] = 0;
2117 if (atoxi(nmptr, &num.numi[1], strlen(nmptr), 10) != 0)
2118 interr("exp_mac: ISYM error", curilm, ERR_Severe);
2119
2120 get_con:
2121 newili.opnd[i] = getcon(num.numi, dtype);
2122 break;
2123
2124 case ILMO__ESYM:
2125 /*
2126 * need to generate the name of an external function taking into
2127 * consideration the number of '_'s beginning the name. the name passed
2128 * from ilmtp.n is exactly how the name should appear in the generated
2129 * code. This processing is necessary since an additional '_' may be
2130 * prependend by getsname() (assem.c).
2131 */
2132 /* otherwise, fall thru */
2133 case ILMO_ESYM:
2134 newili.opnd[i] = efunc(ilmaux[ilmopr->aux]);
2135 break;
2136
2137 case ILMO_SCF: /* scale factor of size - an immediate val */
2138 newili.opnd[i] = scale_of(ILM_DTyOPND(ilmp, ilmopr->aux), &num.numi[1]);
2139 break;
2140
2141 case ILMO_DRRET:
2142 #if defined(IR_RETVAL)
2143 newili.opnd[i] = IR_RETVAL;
2144 #else
2145 interr("exp_mac: need IR_RETVAL", ilmopr->type, ERR_Severe);
2146 #endif
2147 break;
2148 case ILMO_ARRET:
2149 #if defined(AR_RETVAL)
2150 newili.opnd[i] = AR_RETVAL;
2151 #else
2152 interr("exp_mac: need AR_RETVAL", (int)ilmopr->type, ERR_Severe);
2153 #endif
2154 break;
2155 case ILMO_SPRET:
2156 #if defined(SP_RETVAL)
2157 newili.opnd[i] = SP_RETVAL;
2158 #else
2159 interr("exp_mac: need SP_RETVAL", (int)ilmopr->type, ERR_Severe);
2160 #endif
2161 break;
2162 case ILMO_DPRET:
2163 #if defined(DP_RETVAL)
2164 newili.opnd[i] = DP_RETVAL;
2165 #else
2166 interr("exp_mac: need DP_RETVAL", (int)ilmopr->type, ERR_Severe);
2167 #endif
2168 break;
2169 case ILMO_KRRET:
2170 #if defined(KR_RETVAL)
2171 newili.opnd[i] = KR_RETVAL;
2172 #else
2173 interr("exp_mac: need KR_RETVAL", (int)ilmopr->type, ERR_Severe);
2174 #endif
2175 break;
2176 #if defined(ILMO_DRPOS)
2177 case ILMO_DRPOS:
2178 #if defined(TARGET_WIN)
2179 newili.opnd[i] = IR((ilmopr->aux >> 8) & 0xff);
2180 #else
2181 newili.opnd[i] = IR((ilmopr->aux) & 0xff);
2182 #endif
2183 break;
2184 case ILMO_ARPOS:
2185 #if defined(TARGET_WIN)
2186 newili.opnd[i] = AR((ilmopr->aux >> 8) & 0xff);
2187 #else
2188 newili.opnd[i] = AR((ilmopr->aux) & 0xff);
2189 #endif
2190 break;
2191 case ILMO_SPPOS:
2192 #if defined(TARGET_WIN)
2193 newili.opnd[i] = SP((ilmopr->aux >> 8) & 0xff);
2194 #else
2195 newili.opnd[i] = SP((ilmopr->aux) & 0xff);
2196 #endif
2197 break;
2198 case ILMO_DPPOS:
2199 #if defined(TARGET_WIN)
2200 newili.opnd[i] = DP((ilmopr->aux >> 8) & 0xff);
2201 #else
2202 newili.opnd[i] = DP((ilmopr->aux) & 0xff);
2203 #endif
2204 break;
2205 #endif
2206
2207 default:
2208 interr("exp_mac: opnd not handled", opc /*(int)ilmopr->type*/,
2209 ERR_Severe);
2210
2211 } /*** end of switch on operand type ***/
2212 } /*** end of noprs loop ***/
2213
2214 /*
2215 * add the ili just formed
2216 */
2217
2218 /*
2219 printf("%s, %u, %u\n",
2220 ilis[newili.opc].name, newili.opnd[0], newili.opnd[1]);
2221 */
2222
2223 index = addili((ILI *)&newili);
2224 /*
2225 * store away the location (index) of the ili just created
2226 */
2227 ilmopr = (ILMOPND *)&ilmopnd[ilmtpl->result];
2228 switch (ilmopr->type) {
2229
2230 case ILMO_R:
2231 ILM_RESULT(curilm) = index;
2232 break;
2233
2234 case ILMO_KR:
2235 ILM_RESULT(curilm) = index;
2236 break;
2237
2238 case ILMO_T:
2239 ILM_TEMP(ilmopr->aux) = index;
2240 break;
2241
2242 case ILMO_NULL:
2243 break;
2244
2245 case ILMO_RR:
2246 ILM_RRESULT(curilm) = index;
2247 ILM_RESTYPE(curilm) = IM_DCPLX(opc) ? ILM_ISDCMPLX : ILM_ISCMPLX;
2248 break;
2249
2250 case ILMO_IR:
2251 ILM_IRESULT(curilm) = index;
2252 ILM_RESTYPE(curilm) = IM_DCPLX(opc) ? ILM_ISDCMPLX : ILM_ISCMPLX;
2253 break;
2254
2255 default:
2256 interr("exp_mac: bad ilmopr->type", newili.opc /*(int)ilmopr->type*/,
2257 ERR_Severe);
2258 }
2259 /*
2260 * skip to the next ili template -- the length of the template is the
2261 * number of operands + 2 (1 for the opcode and 1 for the result
2262 * specifier
2263 */
2264 pattern += ilis[newili.opc].oprs + 2;
2265
2266 } /*** end of ilicnt loop ***/
2267
2268 return index; /* return the last ili created */
2269 }
2270
2271 static int
efunc(const char * nm)2272 efunc(const char *nm)
2273 {
2274 const char *p;
2275 int func;
2276 DTYPE resdt;
2277
2278 resdt = (DTYPE)-1;
2279 p = nm;
2280 if (*p == '%') {
2281 switch (*++p) {
2282 case 's':
2283 resdt = DT_FLOAT;
2284 break;
2285 case 'd':
2286 resdt = DT_DBLE;
2287 break;
2288 case 'i':
2289 resdt = DT_INT;
2290 break;
2291 case 'l':
2292 resdt = DT_INT8;
2293 break;
2294 case 'u':
2295 p++;
2296 if (*p == 'i')
2297 resdt = DT_UINT;
2298 else if (*p == 'l')
2299 resdt = DT_UINT8;
2300 else {
2301 interr("efunc: unexpected u type", *p, ERR_Severe);
2302 }
2303 break;
2304 case 'v':
2305 resdt = DT_NONE;
2306 break;
2307 default:
2308 interr("efunc: unexpected result type", *p, ERR_Severe);
2309 break;
2310 }
2311 while (*++p != '%') {
2312 if (*p == 0) {
2313 interr("efunc: malformed result type", 0, ERR_Severe);
2314 p = nm;
2315 break;
2316 }
2317 p++;
2318 }
2319 p++;
2320 }
2321 func = mkfunc(p);
2322 if (((int)resdt) >= 0) {
2323 DTYPEP(func, resdt);
2324 }
2325 return func;
2326 }
2327
2328 /***************************************************************/
2329
2330 #define EXP_ISFUNC(s) (STYPEG(s) == ST_PROC)
2331 #define EXP_ISINDIR(s) (SCG(s) == SC_DUMMY)
2332
2333 /***************************************************************/
2334
2335 void
exp_ref(ILM_OP opc,ILM * ilmp,int curilm)2336 exp_ref(ILM_OP opc, ILM *ilmp, int curilm)
2337 {
2338 SPTR sym; /* symbol table entry */
2339 int ili1; /* ili pointer */
2340 int ili2; /* another ili pointer */
2341 int base; /* base ili of reference */
2342 int basenm; /* names entry of base ili */
2343 int dtype;
2344
2345 switch (opc) {
2346
2347 case IM_BASE:
2348 /* get the base symbol entry */
2349 sym = ILM_SymOPND(ilmp, 1);
2350 ili1 = create_ref(sym, &basenm, 0, 0, &ILM_CLEN(curilm), &ILM_MXLEN(curilm),
2351 &ILM_RESTYPE(curilm));
2352 break;
2353
2354 case IM_MEMBER:
2355 base = ILM_OPND(ilmp, 1);
2356 sym = ILM_SymOPND(ilmp, 2);
2357 ili1 =
2358 create_ref(sym, &basenm, NME_OF(base), ILI_OF(base), &ILM_CLEN(curilm),
2359 &ILM_MXLEN(curilm), &ILM_RESTYPE(curilm));
2360 break;
2361
2362 case IM_INLELEM: /* when inlining ftn and dummys/actuals don't match */
2363 case IM_ELEMENT:
2364 exp_array(opc, ilmp, curilm);
2365 return;
2366 default:;
2367 }
2368
2369 ILM_RESULT(curilm) = ili1;
2370 ILM_NME(curilm) = basenm;
2371 }
2372
2373 /* Updates the nme to be an IND (indirection) if the sptr
2374 * is local in the caller of the outlined function.
2375 */
2376 static int
update_local_nme(int nme,int sptr)2377 update_local_nme(int nme, int sptr)
2378 {
2379 const SC_KIND sc = SCG(sptr);
2380
2381 if (((gbl.outlined || ISTASKDUPG(GBL_CURRFUNC)) && PARREFG(sptr)) ||
2382 TASKG(sptr)) {
2383
2384 /* Only consider updating the nme if there is one given and its not ind */
2385 if (!nme || NME_TYPE(nme) == NT_IND)
2386 return nme;
2387
2388 if (sc == SC_EXTERN || sc == SC_STATIC)
2389 return nme;
2390
2391 if (sc == SC_CMBLK)
2392 return nme;
2393
2394 /* We only want to generate indirect if the private is not local to this
2395 * region.
2396 */
2397 if (sc == SC_PRIVATE && is_llvm_local_private(sptr))
2398 return nme;
2399 return addnme(NT_IND, SPTR_NULL, nme, 0);
2400 }
2401 return nme;
2402 }
2403
2404 static int
create_ref(SPTR sym,int * pnmex,int basenm,int baseilix,int * pclen,int * pmxlen,int * prestype)2405 create_ref(SPTR sym, int *pnmex, int basenm, int baseilix, int *pclen,
2406 int *pmxlen, int *prestype)
2407 {
2408 ISZ_T val[2]; /* constant value array */
2409 int ilix; /* result */
2410 int ili1; /* ili pointer */
2411 int ili2; /* another ili pointer */
2412 int base; /* base ili of reference */
2413 int nmex = 0;
2414 DTYPE dtype;
2415 int clen = 0, mxlen = 0, restype = 0;
2416
2417 if (STYPEG(sym) == ST_MEMBER) {
2418 val[1] = ADDRESSG(sym); /* get offset of the ref */
2419 ili2 = ad_aconi(val[1]);
2420
2421 /* (1) AADD base ili2 */
2422
2423 if (baseilix)
2424 ilix = ad3ili(IL_AADD, baseilix, ili2, 0);
2425 else {
2426 /* the second argument of a PARG could be a BASE ilm whose
2427 * symbol is a ST_MEMBER; in this case, baseilix is 0. Need
2428 * to continue since we're not going to use the ili of the
2429 * BASE; all that's need is its length if character (see
2430 * exp_rte.c and its handling of IM_PARG).
2431 */
2432 ;
2433 ilix = ili2;
2434 }
2435
2436 /*
2437 * enter a names entry for the MEMBER ILM - always use the psmem
2438 * field of the member ST item (sym). In most cases, the field is
2439 * sym. The exceptions possibly occur when the member is a field.
2440 */
2441 if (baseilix) {
2442 nmex = addnme(NT_MEM, PSMEMG(sym), basenm, 0);
2443 } else
2444 nmex = NME_UNK;
2445 dtype = DTYPEG(sym);
2446 if (DTY(dtype) == TY_ARRAY)
2447 dtype = DTySeqTyElement(dtype);
2448 if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) {
2449 restype = ILM_ISCHAR;
2450 clen = mxlen = ad_icon(DTyCharLength(dtype));
2451 }
2452 } else {
2453 if (IS_STATIC(sym) ||
2454 (IS_LCL(sym) && (!flg.recursive || DINITG(sym) || SAVEG(sym))))
2455 rcandb.static_cnt++;
2456 dtype = DTYPEG(sym);
2457 if (DTY(dtype) == TY_ARRAY)
2458 dtype = DTySeqTyElement(dtype);
2459 if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) {
2460 restype = ILM_ISCHAR;
2461 nmex = addnme(NT_VAR, sym, 0, 0);
2462 if (SCG(sym) == SC_DUMMY) {
2463
2464 if (dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR) {
2465 if (SDSCG(sym))
2466 clen = exp_get_sdsc_len(sym, 0, 0);
2467 else {
2468 clen = charlen(sym);
2469 #if DEBUG
2470 assert(SDSCG(sym) != 0, "create_ref:Missing descriptor", sym,
2471 ERR_Severe);
2472 #endif /* DEBUG */
2473 }
2474 mxlen = 0;
2475 ADDRCAND(clen, ILI_OPND(clen, 2));
2476 } else
2477 if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR) {
2478 clen = charlen(sym);
2479 mxlen = 0;
2480 ADDRCAND(clen, ILI_OPND(clen, 2));
2481 } else {
2482 clen = mxlen = ad_icon(DTyCharLength(dtype));
2483 }
2484 ilix = charaddr(sym);
2485 ADDRCAND(ilix, ILI_OPND(ilix, 2));
2486 } else {
2487 if (dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR) {
2488 if (SDSCG(sym)) {
2489 clen = exp_get_sdsc_len(sym, 0, 0);
2490 } else {
2491 clen = charlen(sym);
2492 }
2493 mxlen = 0;
2494 ADDRCAND(clen, ILI_OPND(clen, 2));
2495 } else if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR) {
2496 /* nondummy adjustable length character */
2497 if (CLENG(sym)) {
2498 clen = charlen(sym);
2499 mxlen = 0;
2500 ADDRCAND(clen, ILI_OPND(clen, 2));
2501 } else {
2502 clen = mxlen = ad_icon(DTyCharLength(dtype));
2503 }
2504 } else
2505 clen = mxlen = ad_icon(DTyCharLength(dtype));
2506 if (SCG(sym) == SC_CMBLK && ALLOCG(sym)) {
2507 /*
2508 * BASE is of a member which is in an allocatable common.
2509 * generate an indirection using the first member's address
2510 * and then add the offset of this member.
2511 */
2512 SPTR s;
2513 /*
2514 * REVISION: the base of the allocatable common is retrieved
2515 * from a compiler-created temporary. This temporary
2516 * represents the word created by assem for the allocatable
2517 * common. Generate an indirection through this temp.
2518 */
2519 s = getccsym('z', (int)MIDNUMG(sym), ST_VAR);
2520 SCP(s, SC_CMBLK);
2521 ADDRESSP(s, 0);
2522 MIDNUMP(s, MIDNUMG(sym));
2523 DTYPEP(s, __POINT_T);
2524 nmex = addnme(NT_VAR, s, 0, (INT)0);
2525 ili1 = ad_acon(s, (INT)0);
2526 ili1 = ad2ili(IL_LDA, ili1, nmex);
2527 ili2 = ad_aconi(ADDRESSG(sym));
2528 ilix = ad3ili(IL_AADD, ili1, ili2, 0);
2529 }
2530 #if defined(TARGET_WIN)
2531 else if (SCG(sym) == SC_CMBLK && DLLG(sym) == DLL_IMPORT) {
2532 /*
2533 * BASE is of a member which is in a dllimported common.
2534 * generate an indirection using the first member's address
2535 * and then add the offset of this member.
2536 */
2537 int s;
2538 s = mk_impsym(MIDNUMG(sym));
2539 nmex = addnme(NT_VAR, s, 0, (INT)0);
2540 ili1 = ad_acon(s, (INT)0);
2541 ili1 = ad2ili(IL_LDA, ili1, nmex);
2542 ili2 = ad_aconi(ADDRESSG(sym));
2543 ilix = ad3ili(IL_AADD, ili1, ili2, 0);
2544 }
2545 #endif /* TARGET_WIN */
2546 else if (flg.smp && SCG(sym) == SC_CMBLK && IS_THREAD_TP(sym)) {
2547 /*
2548 * BASE is of a member which is in a threadprivate common.
2549 * generate an indirection using the threadprivate common's
2550 * vector and then add the offset of this member. The
2551 * indirection will be of the form:
2552 * vector[_mp_lcpu3()]
2553 */
2554 int nm;
2555 int adr;
2556 ref_threadprivate(sym, &adr, &nm);
2557 ilix = adr;
2558 } else if (IS_THREAD_TP(sym)) {
2559 /*
2560 * BASE is a threadprivate variable; generate an
2561 * indirection using the threadprivate's vector. The
2562 * indirection will be of the form:
2563 * vector[_mp_lcpu3()]
2564 */
2565 int nm;
2566 int adr;
2567 ref_threadprivate_var(sym, &adr, &nm, 1);
2568 ilix = adr;
2569 } else {
2570 ilix = mk_address(sym);
2571 }
2572 }
2573 if (pclen)
2574 *pclen = clen;
2575 if (pmxlen)
2576 *pmxlen = mxlen;
2577 if (prestype)
2578 *prestype = restype;
2579 if (pnmex)
2580 *pnmex = nmex;
2581 return ilix;
2582 }
2583 #if defined(PGF90) && defined(TARGET_WIN)
2584 if (CLASSG(sym) && DESCARRAYG(sym) && SCG(sym) == SC_EXTERN &&
2585 DLLG(sym) == DLL_IMPORT) {
2586 /* generate dll import address for type descriptor */
2587 int asym, anme;
2588 asym = mk_impsym(sym);
2589 ili1 = ad_acon(asym, 0);
2590 anme = addnme(NT_VAR, asym, 0, (INT)0);
2591 ilix = ad2ili(IL_LDA, ili1, anme);
2592 } else
2593 #endif /* PGF90 && TARGET_WIN */
2594 /* create the ACON ILI representing the base symbol */
2595 ilix = mk_address(sym);
2596 if (flg.smp || XBIT(34, 0x200)) {
2597 if (SCG(sym) == SC_STATIC)
2598 sym_is_refd(sym);
2599 }
2600 /* for cuda fortran, if we use an initialized static or local,
2601 * call sym_is_refd */
2602 if (XBIT(137, 1) &&
2603 ((SCG(sym) == SC_STATIC || SCG(sym) == SC_LOCAL) && DINITG(sym)))
2604 sym_is_refd(sym);
2605
2606 /*
2607 * create the names entry for the BASE -- don't care if the symbol is
2608 * a function
2609 */
2610 if (EXP_ISFUNC(sym))
2611 nmex = NME_UNK;
2612 else
2613 /* ST_MEMBERs may be BASE ilm for PARG 2nd argument */
2614 if (STYPEG(sym) != ST_MEMBER)
2615 nmex = addnme(NT_VAR, sym, 0, (INT)0);
2616
2617 /*
2618 * if sym is a dummy (of type (double for 32-bit), struct, or union
2619 * for C) then this is really an indirection. create a symbol which
2620 * represents the address of the dummy and use it to create a new
2621 * names entry.
2622 */
2623
2624 if ((gbl.outlined || ISTASKDUPG(GBL_CURRFUNC)) && PARREFG(sym)) {
2625 if (EXP_ISINDIR(sym)) {
2626 int asym, anme;
2627 asym = mk_argasym(sym);
2628 }
2629 }
2630 else if (gbl.internal > 1 && INTERNREFG(sym)) {
2631 if (EXP_ISINDIR(sym)) {
2632 int asym, anme;
2633 asym = mk_argasym(sym);
2634 }
2635 }
2636 else
2637 if (EXP_ISINDIR(sym)) {
2638 SPTR asym = mk_argasym(sym);
2639 int anme = addnme(NT_VAR, asym, 0, (INT)0);
2640 ilix = ad2ili(IL_LDA, ilix, anme);
2641 ADDRCAND(ilix, anme);
2642 }
2643
2644 if (VOLG(sym))
2645 nmex = NME_VOL;
2646 else if (SCG(sym) == SC_CMBLK && ALLOCG(sym)) {
2647 /*
2648 * BASE is of a member which is in an allocatable common.
2649 * generate an indirection using the first member's address
2650 * and then add the offset of this member.
2651 */
2652 SPTR s;
2653 /*
2654 * REVISION: the base of the allocatable common is retrieved
2655 * from a compiler-created temporary. This temporary
2656 * represents the word created by assem for the allocatable
2657 * common. Generate an indirection through this temp.
2658 */
2659 s = getccsym('z', (int)MIDNUMG(sym), ST_VAR);
2660 SCP(s, SC_CMBLK);
2661 ADDRESSP(s, 0);
2662 MIDNUMP(s, MIDNUMG(sym));
2663 DTYPEP(s, __POINT_T);
2664 nmex = addnme(NT_VAR, s, 0, (INT)0);
2665 ili1 = ad_acon(s, (INT)0);
2666 ili1 = ad2ili(IL_LDA, ili1, nmex);
2667 ili2 = ad_aconi(ADDRESSG(sym));
2668 ilix = ad3ili(IL_AADD, ili1, ili2, 0);
2669 /*
2670 * -x 125 32: if set, indicates that the allocatable common is
2671 * allocated once per execution, in which case, 'precise' nmes
2672 * are generated. Otherwise, create 'via ptr' (indirection) nmes.
2673 */
2674 if (XBIT(125, 0x20))
2675 nmex = addnme(NT_VAR, sym, 0, (INT)0);
2676 else
2677 nmex = addnme(NT_IND, SPTR_NULL, nmex, (INT)0);
2678 }
2679 #if defined(TARGET_WIN)
2680 else if (SCG(sym) == SC_CMBLK && DLLG(sym) == DLL_IMPORT) {
2681 /*
2682 * BASE is of a member which is in a dllimported common.
2683 * generate an indirection using the first member's address
2684 * and then add the offset of this member.
2685 */
2686 int s;
2687 s = mk_impsym(MIDNUMG(sym));
2688 nmex = addnme(NT_VAR, s, 0, (INT)0);
2689 ili1 = ad_acon(s, (INT)0);
2690 ili1 = ad2ili(IL_LDA, ili1, nmex);
2691 ili2 = ad_aconi(ADDRESSG(sym));
2692 ilix = ad3ili(IL_AADD, ili1, ili2, 0);
2693 /*
2694 * -x 125 32: if set, indicates that the allocatable common is
2695 * allocated once per execution, in which case, 'precise' nmes
2696 * are generated. Otherwise, create 'via ptr' (indirection) nmes.
2697 */
2698 if (XBIT(125, 0x20))
2699 nmex = addnme(NT_VAR, sym, 0, (INT)0);
2700 else
2701 nmex = addnme(NT_IND, 0, nmex, (INT)0);
2702 }
2703 #endif
2704 else if (SCG(sym) == SC_CMBLK && IS_THREAD_TP(sym)) {
2705 /*
2706 * BASE is of a member which is in a threadprivate common.
2707 * generate an indirection using the threadprivate common's
2708 * vector and then add the offset of this member. The
2709 * indirection will be of the form:
2710 * vector[_mp_lcpu3()]
2711 */
2712 int nm;
2713 int adr;
2714 ref_threadprivate(sym, &adr, &nm);
2715 ilix = adr;
2716 /*nmex = addnme(NT_IND, 0, nmex, (INT) 0);*/
2717 /* should be safe to just use the nme of the original common
2718 * symbol.
2719 */
2720 nmex = addnme(NT_VAR, sym, 0, (INT)0);
2721 } else if (IS_THREAD_TP(sym)) {
2722 /*
2723 * BASE is a threadprivate variable; generate an indirection using
2724 * the threadprivate's vector. The indirection will be of the form:
2725 * vector[_mp_lcpu3()]
2726 */
2727 int nm;
2728 int adr;
2729 ref_threadprivate_var(sym, &adr, &nm, 1);
2730 ilix = adr;
2731 /*nmex = addnme( NT_IND, 0, nmex, (INT)0 );*/
2732 /* should be safe to just use the nme of the original common
2733 * symbol.
2734 */
2735 nmex = addnme(NT_VAR, sym, 0, (INT)0);
2736 }
2737 }
2738 if (pclen)
2739 *pclen = clen;
2740 if (pmxlen)
2741 *pmxlen = mxlen;
2742 if (prestype)
2743 *prestype = restype;
2744
2745 if (XBIT(183, 0x80000))
2746 nmex = update_local_nme(nmex, sym);
2747 if (pnmex)
2748 *pnmex = nmex;
2749 return ilix;
2750 } /* create_ref */
2751
2752 void
ll_set_new_threadprivate(int oldsptr)2753 ll_set_new_threadprivate(int oldsptr)
2754 {
2755
2756 int newsptr = THPRVTOPTG(oldsptr);
2757 if (!newsptr) {
2758 newsptr = getnewccsym('T', stb.stg_avail, ST_VAR);
2759 DTYPEP(newsptr, DT_CPTR);
2760 THPRVTOPTP(oldsptr, newsptr);
2761 }
2762
2763 /* This is cheating because we want to reuse the same field so we need to
2764 * reset
2765 * SCP and enclfunction to current function
2766 */
2767 if (gbl.outlined || ISTASKDUPG(GBL_CURRFUNC))
2768 SCP(newsptr, SC_PRIVATE);
2769 else
2770 SCP(newsptr, SC_AUTO);
2771 ENCLFUNCP(newsptr, GBL_CURRFUNC);
2772 }
2773
2774 int
llGetThreadprivateAddr(int sptr)2775 llGetThreadprivateAddr(int sptr)
2776 {
2777 int addr;
2778 SPTR cm;
2779 int basenm, tpv;
2780
2781 ll_set_new_threadprivate(sptr);
2782 cm = THPRVTOPTG(sptr);
2783 addr = ad_acon(cm, 0);
2784 basenm = addnme(NT_VAR, cm, 0, (INT)0);
2785 addr = ad2ili(IL_LDA, addr, basenm);
2786
2787 return addr;
2788 }
2789
2790 int
getThreadPrivateTp(int sptr)2791 getThreadPrivateTp(int sptr)
2792 {
2793 int tpv = sptr;
2794
2795 tpv = MIDNUMG(sptr);
2796
2797 if (SCG(sptr) == SC_BASED && POINTERG(sptr)) {
2798 int pv = MIDNUMG(sptr);
2799 if (SCG(pv) == SC_CMBLK) {
2800 tpv = MIDNUMG(MIDNUMG(pv));
2801 } else {
2802 tpv = MIDNUMG(pv);
2803 }
2804 } else if (SCG(sptr) == SC_CMBLK) {
2805 sptr = MIDNUMG(sptr);
2806 tpv = MIDNUMG(sptr);
2807 }
2808
2809 return tpv;
2810 }
2811
2812 /** \brief Have a reference to a member of a threadprivate common.
2813 *
2814 * Generate an indirection using the threadprivate common's vector and
2815 * then add the offset of this member. The actual address computation is:
2816 * vector[_mp_lcpu3()] + offset(member)
2817 */
2818 void
ref_threadprivate(int cmsym,int * addr,int * nm)2819 ref_threadprivate(int cmsym, int *addr, int *nm)
2820 {
2821 SPTR vector;
2822 int size, cm = 0;
2823 int sub;
2824 int basenm;
2825 int ili1;
2826 int ili2;
2827
2828 /* compute the base address of vector */
2829 vector = MIDNUMG(cmsym);
2830 /* at this point, vector locates the common block */
2831 vector = MIDNUMG(vector);
2832 basenm = addnme(NT_VAR, vector, 0, (INT)0);
2833 ili1 = ad_acon(vector, (INT)0);
2834
2835 if (XBIT(69, 0x80)) {
2836 /* compute the base address of vector */
2837 vector = MIDNUMG(cmsym);
2838 /* at this point, vector locates the common block */
2839 vector = MIDNUMG(vector);
2840 basenm = addnme(NT_VAR, vector, 0, (INT)0);
2841 ili1 = ad_acon(vector, (INT)0);
2842 ili1 = ad2ili(IL_LDA, ili1, basenm);
2843 } else {
2844 ili1 = llGetThreadprivateAddr(vector);
2845 }
2846
2847 /* add in the common member's offset */
2848 ili2 = ad_aconi(ADDRESSG(cmsym));
2849 ili1 = ad3ili(IL_AADD, ili1, ili2, 0);
2850
2851 *addr = ili1;
2852 *nm = basenm;
2853 }
2854
2855 /** \brief Have a reference to a Fortran or C threadprivate variable.
2856 *
2857 * Generate an indirection using the threadprivate's vector. The actual
2858 * address computations is:
2859 * vector[_mp_lcpu3()]
2860 * mark : 1 - mark TPLNKP , and add it go gbl.threadprivate : this is normal
2861 * processing. When calling this function later on, during exception fixup,
2862 * call with mark = 0
2863 */
2864 void
ref_threadprivate_var(int cmsym,int * addr,int * nm,int mark)2865 ref_threadprivate_var(int cmsym, int *addr, int *nm, int mark)
2866 {
2867 SPTR vector;
2868 int size;
2869 int sub;
2870 int basenm;
2871 int ili1;
2872 int ili2;
2873 int cm;
2874
2875 /* compute the base address of vector */
2876 vector = MIDNUMG(cmsym);
2877 basenm = addnme(NT_VAR, vector, 0, (INT)0);
2878 ili1 = ad_acon(vector, (INT)0);
2879
2880 if (XBIT(69, 0x80)) {
2881 vector = MIDNUMG(cmsym);
2882 basenm = addnme(NT_VAR, vector, 0, 0);
2883 ili1 = ad_acon(vector, (INT)0);
2884 ili1 = ad2ili(IL_LDA, ili1, basenm);
2885 } else {
2886 ili1 = llGetThreadprivateAddr(vector);
2887 }
2888
2889 if (DESCARRAYG(cmsym)) {
2890 /*
2891 * for a f90 pointer, subscripting of the TP vector gives the address
2892 * of the thread's copy of the internal pointer variable; the
2893 * descriptor is 2 pointer units away from the pointer variable
2894 */
2895 ili2 = ad_acon(SPTR_NULL, 2 * size_of(DT_ADDR));
2896 ili1 = ad3ili(IL_AADD, ili1, ili2, 0);
2897 }
2898
2899 *addr = ili1;
2900 *nm = basenm;
2901
2902 }
2903
2904 void
exp_pure(SPTR extsym,int nargs,ILM * ilmp,int curilm)2905 exp_pure(SPTR extsym, int nargs, ILM *ilmp, int curilm)
2906 {
2907 #define MAX_PUREARGS 2
2908 int args[MAX_PUREARGS];
2909 int cili;
2910 int ilix;
2911 int n, i;
2912 int ilmx;
2913 ILM *ilmpx;
2914 int first_arg_index;
2915
2916 if (nargs > MAX_PUREARGS)
2917 return;
2918
2919 first_arg_index = 1 + ilm_callee_index(ILM_OPC(ilmp));
2920
2921 n = nargs;
2922 i = first_arg_index;
2923 while (n--) {
2924 ilmx = ILM_OPND(ilmp, i); /* locates ARG ilm */
2925 ilmpx = (ILM *)(ilmb.ilm_base + ilmx);
2926 ilmx = ILM_OPND(ilmpx, 2);
2927 args[i - first_arg_index] = ILI_OF(ilmx);
2928 i++;
2929 }
2930 cili = ILI_OF(curilm);
2931 switch (ILI_OPC(cili)) {
2932 case IL_DFRAR:
2933 switch (nargs) {
2934 case 0:
2935 cili = jsr2qjsr(cili);
2936 ilix = ad_acon(extsym, 0);
2937 ilix = ad2ili(IL_APURE, ilix, cili);
2938 ILM_RESULT(curilm) = ilix;
2939 break;
2940 case 1:
2941 switch (IL_RES(ILI_OPC(args[0]))) {
2942 case ILIA_AR:
2943 cili = jsr2qjsr(cili);
2944 ilix = ad_acon(extsym, 0);
2945 ilix = ad3ili(IL_APUREA, ilix, args[0], cili);
2946 ILM_RESULT(curilm) = ilix;
2947 break;
2948 case ILIA_IR:
2949 cili = jsr2qjsr(cili);
2950 ilix = ad_acon(extsym, 0);
2951 ilix = ad3ili(IL_APUREI, ilix, args[0], cili);
2952 ILM_RESULT(curilm) = ilix;
2953 default:
2954 break;
2955 }
2956 default:
2957 break;
2958 }
2959 break;
2960
2961 case IL_DFRIR:
2962 switch (nargs) {
2963 case 0:
2964 cili = jsr2qjsr(cili);
2965 ilix = ad_acon(extsym, 0);
2966 ilix = ad2ili(IL_IPURE, ilix, cili);
2967 ILM_RESULT(curilm) = ilix;
2968 break;
2969 case 1:
2970 switch (IL_RES(ILI_OPC(args[0]))) {
2971 case ILIA_AR:
2972 cili = jsr2qjsr(cili);
2973 ilix = ad_acon(extsym, 0);
2974 ilix = ad3ili(IL_IPUREA, ilix, args[0], cili);
2975 ILM_RESULT(curilm) = ilix;
2976 break;
2977 case ILIA_IR:
2978 cili = jsr2qjsr(cili);
2979 ilix = ad_acon(extsym, 0);
2980 ilix = ad3ili(IL_IPUREI, ilix, args[0], cili);
2981 ILM_RESULT(curilm) = ilix;
2982 default:
2983 break;
2984 }
2985 default:
2986 break;
2987 }
2988 break;
2989
2990 default:
2991 break;
2992 }
2993 }
2994
2995 static int
jsr2qjsr(int dfili)2996 jsr2qjsr(int dfili)
2997 {
2998 int New;
2999 int cl;
3000 #if DEBUG
3001 assert(ILI_OPC(dfili) == IL_DFRIR || ILI_OPC(dfili) == IL_DFRAR,
3002 "jsr2qjsr:dfr ili expected", dfili, ERR_unused);
3003
3004 #endif
3005 New = dfili;
3006 cl = ILI_OPND(dfili, 1);
3007 if (ILI_OPC(cl) == IL_JSR) {
3008 New = ad2ili(IL_QJSR, ILI_OPND(cl, 1), ILI_OPND(cl, 2));
3009 New = ad2ili(ILI_OPC(dfili), New, ILI_OPND(dfili, 2));
3010 }
3011 return New;
3012 }
3013
3014 /***************************************************************/
3015
3016