1 /*
2 * Copyright (c) 2015-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 /**
19 \file
20 \brief Fortran expander routines
21
22 For processing ILMs dealing with the run-time environment, e.g., expanding
23 calls, expanding entries, and handling structure assignments.
24 */
25
26 #include "exp_rte.h"
27 #include "error.h"
28 #include "llassem.h"
29 #include "ll_ftn.h"
30 #include "outliner.h"
31 #include "cgmain.h"
32 #include "expatomics.h"
33 #include "exp_rte.h"
34 #include "exputil.h"
35 #include "regutil.h"
36 #include "machreg.h"
37 #include "exp_ftn.h"
38 #include "expsmp.h"
39 #include "expreg.h"
40 #include "semutil0.h"
41 #include "ilm.h"
42 #include "ilmtp.h"
43 #include "ili.h"
44 #define EXPANDER_DECLARE_INTERNAL
45 #include "expand.h"
46 #include "machar.h"
47 #ifdef TARGET_X86
48 #include "x86.h"
49 #endif
50 #include "rtlRtns.h"
51 #include "dtypeutl.h"
52 #include "upper.h"
53 #include "symfun.h"
54
55 static int exp_strx(int, STRDESC *, STRDESC *);
56 static int exp_strcpy(STRDESC *, STRDESC *);
57 static bool strovlp(STRDESC *, STRDESC *);
58 static STRDESC *getstr(int);
59 static STRDESC *getstrconst(char *, int);
60 static STRDESC *storechartmp(STRDESC *str, int mxlenili, int clenili);
61 static char *getcharconst(STRDESC *);
62 static int ftn_strcmp(char *, char *, int, int);
63 static int getstrlen64(STRDESC *);
64 static void pp_entries(void);
65 static void pp_entries_mixedstrlen(void);
66 static void pp_params(SPTR func);
67 static void pp_params_mixedstrlen(int);
68 static void cp_memarg(int, INT, int);
69 static void cp_byval_mem_arg(SPTR argsptr);
70 static SPTR allochartmp(int lenili);
71 static int block_str_move(STRDESC *, STRDESC *);
72 static int getchartmp(int ili);
73 static void _exp_smove(int, int, int, int, DTYPE);
74
75 static int has_desc_arg(int, int);
76 static int check_desc(int, int);
77 static void check_desc_args(int);
78 static int exp_type_bound_proc_call(int arg, SPTR descno, int vtoff,
79 int arglnk);
80 static bool is_asn_closure_call(int sptr);
81 static bool is_proc_desc_arg(int ili);
82 static bool process_end_of_list(SPTR func, SPTR osym, int *nlens,
83 DTYPE argdtype);
84
85 static int get_chain_pointer_closure(SPTR sdsc);
86 static int add_last_arg(int arglnk, int displnk);
87 static int add_arglnk_closure(SPTR sdsc);
88 static int add_gargl_closure(SPTR sdsc);
89
90 #define CLASS_NONE 0
91 #define CLASS_INT4 4
92 #define CLASS_INT8 8
93 #define CLASS_MEM 13
94
95 #define MAX_PASS_STRUCT_SIZE 16
96
97 #define mk_prototype mk_prototype_llvm
98
99 #define IS_INTERNAL_PROC_CALL(opc) \
100 (opc == IM_PCALLA || opc == IM_PCHFUNCA || opc == IM_PNCHFUNCA || \
101 opc == IM_PKFUNCA || opc == IM_PLFUNCA || opc == IM_PIFUNCA || \
102 opc == IM_PRFUNCA || opc == IM_PDFUNCA || opc == IM_PCFUNCA || \
103 opc == IM_PCDFUNCA || opc == IM_PPFUNCA)
104
105 static SPTR exp_call_sym; /**< sptr subprogram being called */
106 static SPTR fptr_iface; /**< sptr of function pointer's interface */
107 static SPTR allocharhdr;
108 static int *parg; /**< pointer to area for dummy arg processing */
109
110 typedef struct {
111 INT mem_off; /**< next offset in the memory arg area */
112 short retgrp; /**< return group # for a function */
113 /** function ret variable for return group -- there is a sub-table in the
114 finfo table which is indexed by the return group index (0 - retgrp_cnt-1).
115 This field is valid only for the sub-table. */
116 SPTR fval;
117 /** register descriptor for the case where the function is bind(C) and the
118 return value is a small structure returned in memory; 0 otherwise */
119 int ret_sm_struct;
120 int ret_align; /**< if returning small struct, this is its alignment */
121 } finfo_t;
122
123 static finfo_t *pfinfo; /**< table of finfo for the entries */
124 static int nentries; /**< number of entries for the subprogram */
125 static int smove_flag;
126 static int mscall_flag;
127 static int alloca_flag;
128 static int retgrp_cnt; /**< number of return counts */
129 static SPTR retgrp_var; /**< local variable holding return group value */
130
131 /** variable used to locate the beginning of the memory argument area */
132 static SPTR memarg_var;
133
134 #ifdef __cplusplus
convertSPTR(int i)135 inline SPTR convertSPTR(int i) {
136 return static_cast<SPTR>(i);
137 }
sptr_mk_address(SPTR sym)138 inline SPTR sptr_mk_address(SPTR sym) {
139 return static_cast<SPTR>(mk_address(sym));
140 }
GetVTable(SPTR sym)141 inline SPTR GetVTable(SPTR sym) {
142 return static_cast<SPTR>(VTABLEG(sym));
143 }
144 #undef VTABLEG
145 #define VTABLEG GetVTable
GetIface(SPTR sym)146 inline SPTR GetIface(SPTR sym) {
147 return static_cast<SPTR>(IFACEG(sym));
148 }
149 #undef IFACEG
150 #define IFACEG GetIface
151 #else
152 #define convertSPTR(X) X
153 #define sptr_mk_address mk_address
154 #endif
155
156 static bool
strislen1(STRDESC * str)157 strislen1(STRDESC *str)
158 {
159 return str->liscon && str->lval == 1;
160 }
161
162 static bool
strislen0(STRDESC * str)163 strislen0(STRDESC *str)
164 {
165 return str->liscon && str->lval == 0;
166 }
167
168 static int
getstraddr(STRDESC * str)169 getstraddr(STRDESC *str)
170 {
171 if (str->aisvar)
172 return ad1ili(IL_ACON, str->aval);
173 return str->aval;
174 }
175
176 static int
getstrlen(STRDESC * str)177 getstrlen(STRDESC *str)
178 {
179 if (str->liscon)
180 return ad_icon(str->lval);
181 return str->lval;
182 }
183
184 static int
getstrlen64(STRDESC * str)185 getstrlen64(STRDESC *str)
186 {
187 int il;
188 il = getstrlen(str);
189 if (IL_RES(ILI_OPC(il)) != ILIA_KR)
190 il = ad1ili(IL_IKMV, il);
191 return il;
192 }
193
194 /*
195 * Generating GSMOVE ILI is under XBIT(2,0x800000). When the XBIT is not
196 * set, _exp_smove() will proceed as before; in particular, chk_block() is
197 * called to add terminal ILI to the block current to the expander. When
198 * the XBIT is set, the GSMOVE ili are transformed sometime after the expander,
199 * but we still want the code in _exp_smove() to do the work. However, we
200 * cannot call chk_block() to add the terminal ILI; we must use 'addilt'.
201 * So, define and use a function pointer, p_chk_block, which calls either
202 * chk_block() or a new local addilit routine, gsmove_chk_block(). In this
203 * case, the current ilt is saved as the file static, gsmove_ilt.
204 */
205 static void (*p_chk_block)(int) = chk_block;
206 static void gsmove_chk_block(int);
207 static int gsmove_ilt;
208
209 /* aux.curr_entry->flags description:
210 * Initialized to 0 by exp_end
211 * NA 0x1 - need to save argument registers (set by exp_end).
212 * NA 0x2 - r1 is not needed (set by scheduler)
213 * NA 0x4 - function contained varargs or is passed memory arguments
214 * (set by exp_end)
215 * NA 0x8 - fast linkage
216 * 0x100 - must set up the frame (set by exp_end)
217 * 0x200 - AVX only: we can 32-byte align the stack if it is
218 * beneficial to do so (set by exp_end)
219 * 0x400 - AVX only: we MUST 32-byte align the stack, e.g. because
220 * a 32-byte aligned load or store has been generated
221 * which assumes that the stack is 32-byte aligned.
222 * 0x40000000 - mscall seen
223 * 0x80000000 - alloca called.
224 */
225
226 int
is_passbyval_dummy(int sptr)227 is_passbyval_dummy(int sptr)
228 {
229 if (BYVALDEFAULT(GBL_CURRFUNC))
230 return 1;
231 if (PASSBYVALG(sptr))
232 return 1;
233 return 0;
234 }
235
236 /* Visual Studio cDEC$ ATTRIBUTES are very specific about when a character
237 argument is passed by value, passed by ref with a length, passed
238 by ref without a length. This routine returns true if the argument
239 is pass by reference with a length
240 */
241 int
needlen(int sym,int func)242 needlen(int sym, int func)
243 {
244 if (sym <= 0)
245 return false;
246
247 if (func <= 0)
248 return false;
249
250 if (sym == FVALG(func)) {
251
252 /* special case for functions returning character :
253 always need a length This can not be modified
254 any ATTRIBUTES.
255 */
256 return true;
257 }
258
259 if (PASSBYVALG(sym)) {
260 return false;
261 }
262 if (STDCALLG(func) || CFUNCG(func)) {
263 if (PASSBYREFG(sym)) {
264 return false;
265 }
266
267 if (PASSBYREFG(func)) {
268 return true;
269 }
270
271 /* plain func= c/stdcall is pass by value */
272 return false;
273 }
274 return true;
275 }
276
277 static void
create_llvm_display_temp(void)278 create_llvm_display_temp(void)
279 {
280 DTYPE dtype;
281 int size;
282 SPTR display_temp, asym;
283
284 if (!gbl.internal)
285 return;
286
287 display_temp = getccsym('S', expb.gentmps++, ST_VAR);
288
289 if (gbl.outlined) {
290 SCP(display_temp, SC_PRIVATE);
291 if (gbl.internal >= 1)
292 load_uplevel_addresses(display_temp);
293 } else if (gbl.internal == 1) {
294 dtype = DTYPEG(display_temp);
295 if (DTY(dtype) != TY_STRUCT)
296 dtype = make_uplevel_arg_struct();
297 DTYPEP(display_temp, dtype);
298 SCP(display_temp, SC_LOCAL);
299 ADDRTKNP(display_temp, 1);
300 sym_is_refd(display_temp);
301 aux.curr_entry->display = display_temp;
302
303 if (!gbl.outlined) {
304 /* now load address of local variable on to this array */
305 load_uplevel_addresses(display_temp);
306 }
307 return;
308 } else {
309 SCP(display_temp, SC_DUMMY);
310 dtype = DTYPEG(display_temp);
311 if (DTY(dtype) != TY_STRUCT)
312 dtype = make_uplevel_arg_struct();
313 asym = mk_argasym(display_temp);
314 ADDRESSP(asym, ADDRESSG(display_temp)); /* propagate ADDRESS */
315 MEMARGP(asym, 1);
316 }
317 DTYPEP(display_temp, DT_ADDR);
318 sym_is_refd(display_temp);
319 aux.curr_entry->display = display_temp;
320 }
321
322 /***************************************************************/
323
324 /**
325 * Expand entry, main, sub, or func. For an unnamed program, PROGRAM,
326 * SUBROUTINE, or FUNCTION, sym is 0; otherwise, sym is the ENTRY name.
327 */
328 void
exp_header(SPTR sym)329 exp_header(SPTR sym)
330 {
331 int tmp;
332 SPTR sptr;
333
334 if (sym == SPTR_NULL) {
335 smove_flag = 0;
336 mscall_flag = 0;
337 if (WINNT_CALL)
338 mscall_flag = 1;
339 alloca_flag = 0;
340 sym = gbl.currsub;
341 allocharhdr = SPTR_NULL;
342 memarg_var = SPTR_NULL;
343 expb.arglcnt.next = expb.arglcnt.start = expb.arglcnt.max;
344 aux.curr_entry->ent_save = SPTR_NULL;
345 if (gbl.rutype != RU_PROG) {
346 if ((!WINNT_CALL && !CREFG(sym)) || NOMIXEDSTRLENG(sym))
347 pp_entries();
348 else
349 pp_entries_mixedstrlen();
350 }
351 mkrtemp_init();
352 } else {
353 if (flg.smp && OUTLINEDG(sym) && BIHNUMG(sym)) {
354 return;
355 }
356 flsh_block();
357 cr_block();
358 }
359
360 /* get expb.curbih for this entry and save in symtab */
361
362 BIHNUMP(sym, expb.curbih);
363
364 /* generate ILI for entry operator */
365
366 expb.curilt = addilt(0, ad1ili(IL_ENTRY, sym));
367 /*
368 * Store into the bih for this block the entry ST item and define
369 * the pointer to the auxilary Entry information and the BIH index
370 * for the current function.
371 */
372 BIH_LABEL(expb.curbih) = sym;
373 #ifdef OUTLINEDG
374 gbl.outlined = ((OUTLINEDG(sym)) ? true : false);
375 #endif
376
377 if (sym == gbl.currsub)
378 reg_init(sym); /* init reg info and set stb.curr_entry */
379 if (gbl.internal >= 1) {
380 /* always create display variable for gbl.internal */
381 create_llvm_display_temp();
382 }
383
384 if (gbl.outlined) {
385 SPTR asym;
386 int ili_uplevel;
387 SPTR tmpuplevel;
388 int nme, ili;
389 bihb.parfg = 1;
390 aux.curr_entry->uplevel = ll_get_shared_arg(sym);
391 asym = mk_argasym(aux.curr_entry->uplevel);
392 ADDRESSP(asym, ADDRESSG(aux.curr_entry->uplevel)); /* propagate ADDRESS */
393 MEMARGP(asym, 1);
394
395 /* if I am the task_routine(arg1, task*) */
396 if (TASKFNG(sym)) {
397 bihb.taskfg = 1;
398
399 /* Set up local variable and store the address where first shared
400 * variable is stored.
401 */
402 tmpuplevel = getccsym('S', expb.gentmps++, ST_VAR);
403 SCP(tmpuplevel, SC_PRIVATE);
404 DTYPEP(tmpuplevel, DT_ADDR);
405 sym_is_refd(tmpuplevel);
406 ENCLFUNCP(tmpuplevel, GBL_CURRFUNC);
407
408 /* aux.curr_entry->uplevel = arg2[0] */
409 /* 2 levels of indirection.
410 * 1st: Fortran specific where we load address of
411 * argument from address constant variable.
412 * We store the address of argument into
413 * address constant at the beginning of routine.
414 * We should one day revisit if it is applicable anymore.
415 * Or if we should just do the same as C.
416 * We would now have an address of task
417 * 2nd: Load first element from task which should be the
418 * address on task_sptr where first shared var address
419 * is stored.
420 */
421 ili_uplevel = mk_address(aux.curr_entry->uplevel);
422 nme = addnme(NT_VAR, asym, 0, 0);
423 ili_uplevel = ad2ili(IL_LDA, ili_uplevel, nme); /* .Cxxx = (task) */
424 nme = addnme(NT_IND, aux.curr_entry->uplevel, nme, 0);
425 ili_uplevel = ad2ili(IL_LDA, ili_uplevel, nme); /* taskptr = .Cxxx */
426
427 ili = ad_acon(tmpuplevel, 0);
428 nme = addnme(NT_VAR, tmpuplevel, 0, 0);
429 ili = ad3ili(IL_STA, ili_uplevel, ili, nme);
430 chk_block(ili);
431 aux.curr_entry->uplevel = tmpuplevel;
432 }
433 } else if (ISTASKDUPG(sym)) {
434 SPTR asym;
435 int ili_uplevel;
436 SPTR tmpuplevel;
437 int nme, ili;
438 aux.curr_entry->uplevel = ll_get_hostprog_arg(sym, 2);
439 asym = mk_argasym(aux.curr_entry->uplevel);
440 ADDRESSP(asym, ADDRESSG(aux.curr_entry->uplevel)); /* propagate ADDRESS */
441 MEMARGP(asym, 1);
442
443 bihb.taskfg = 1;
444
445 /* Set up local variable and store the address of shared variable
446 * from second argument: taskdup(nexttask, task, lastitr)
447 * So that we don't need to do multiple indirect access when
448 * we want to access shared variable.
449 */
450 tmpuplevel = getccsym('S', expb.gentmps++, ST_VAR);
451 SCP(tmpuplevel, SC_PRIVATE);
452 DTYPEP(tmpuplevel, DT_ADDR);
453 sym_is_refd(tmpuplevel);
454 ENCLFUNCP(tmpuplevel, GBL_CURRFUNC);
455
456 /* now load address from arg2[0] to tmpuplevel */
457 ili_uplevel = mk_address(aux.curr_entry->uplevel);
458 nme = addnme(NT_VAR, asym, 0, 0);
459
460 /* 2 levels of indirection.
461 * 1st: Fortran specific where we load address of
462 * argument from address constant variable.
463 * We store the address of argument into
464 * address constant at the beginning of routine.
465 * We should one day revisit if it is applicable anymore.
466 * Or if we should just do the same as C.
467 * We would now have an address of task
468 * 2nd: Load first element from task which should be the
469 * address on task_sptr where the first shared var
470 * address is stored.
471 */
472 ili_uplevel = ad2ili(IL_LDA, ili_uplevel, nme); /* .Cxxx = (task) */
473 nme = addnme(NT_IND, aux.curr_entry->uplevel, nme, 0);
474 ili_uplevel = ad2ili(IL_LDA, ili_uplevel, nme); /* taskptr = .Cxxx */
475
476 ili = ad_acon(tmpuplevel, 0);
477 nme = addnme(NT_VAR, tmpuplevel, 0, 0);
478 ili = ad3ili(IL_STA, ili_uplevel, ili, nme);
479 chk_block(ili);
480 aux.curr_entry->uplevel = tmpuplevel;
481 } else {
482 bihb.parfg = 0;
483 bihb.taskfg = 0;
484 aux.curr_entry->uplevel = SPTR_NULL;
485 }
486
487 BIH_EN(expb.curbih) = 1;
488 gbl.entbih = expb.curbih;
489 if (gbl.rutype != RU_PROG) {
490 if ((!WINNT_CALL && !CREFG(sym)) || NOMIXEDSTRLENG(sym))
491 pp_params(sym);
492 else
493 pp_params_mixedstrlen(sym);
494 }
495
496 if (gbl.internal && gbl.outlined && aux.curr_entry->display) {
497 /* do this after aux->curr_entry.display is created: */
498 int ili_uplevel;
499 int nme;
500 int ili = ad_acon(aux.curr_entry->display, 0);
501 aux.curr_entry->uplevel = ll_get_shared_arg(sym);
502 ili_uplevel = mk_address(aux.curr_entry->uplevel);
503 nme = addnme(NT_VAR, aux.curr_entry->uplevel, 0, 0);
504 ili_uplevel = ad2ili(IL_LDA, ili_uplevel, nme);
505 ili_uplevel = ad2ili(IL_LDA, ili_uplevel,
506 addnme(NT_IND, aux.curr_entry->display, nme, 0));
507 ili = ad2ili(IL_LDA, ili, addnme(NT_IND, aux.curr_entry->display, nme, 0));
508 nme = addnme(NT_VAR, aux.curr_entry->display, 0, 0);
509 ili = ad3ili(IL_STA, ili_uplevel, ili, nme);
510 chk_block(ili);
511 flg.recursive = true;
512 }
513 if (flg.debug || XBIT(120, 0x1000) || XBIT(123, 0x400)) {
514 /*
515 * Since the debug code is produced, the entry block will have
516 * line number of 0. The block following the entry block will
517 * have the entry's line number. This block represents the entry
518 * to the function as seen by the debugger.
519 */
520 BIH_LINENO(expb.curbih) = 0;
521 wr_block();
522 cr_block();
523 BIH_LINENO(expb.curbih) = gbl.lineno;
524 } else {
525 wr_block(); /* make entry block separate */
526 cr_block();
527 }
528 }
529
530 /*
531 * WARNING: there are nomixedstrlen and mixedstrlen functions to preprocess
532 * entries.
533 */
534 static void
pp_entries(void)535 pp_entries(void)
536 {
537 int func;
538 int nargs;
539 int *dpdscp;
540 int sym;
541 int dtype;
542 int curpos;
543 int pos;
544 int lenpos;
545 int argpos;
546 int finfox;
547 int byvalue;
548 /*
549 * Preprocess the entries in the subprogram to determine for which
550 * entries arguments must be copied due to the arguments occupying
551 * different positions. The entry and the arguments which must
552 * be copied are flagged (COPYPRMS flag). Also, for a character
553 * argument whose length is passed, a symbol table entry is created
554 * to represent its length (the arg's CLEN field will locate the length
555 * ST item).
556 *
557 * A unique list (table) is created (located by parg) of the arguments
558 * and lengths for character arguments which appear in all of the entries.
559 * While a function is processed, a section of the table is divided into
560 * two tables: the first table is used for the arguments and the second
561 * table is used for lengths. argpos is an index into the table and
562 * locates the position of the most recent unique argument; lenpos indicates
563 * the position of the most recent character length.
564 *
565 * Note that the ADDRESS field is temporarily used to record the
566 * argument's position in the list created for all the arguments.
567 * An argument is entered into the list only once even though it
568 * may occur in more than one entry.
569 */
570
571 /* compute number of entries and total number of arguments */
572 finfox = retgrp_cnt = nentries = nargs = 0;
573 for (func = gbl.entries; func != NOSYM; func = SYMLKG(func)) {
574 nargs += PARAMCTG(func);
575 nentries++;
576 }
577 /*
578 * assume all arguments are character arguments; note that the first
579 * argument is in position 1. Allocate space for the table used to
580 * record arguments and lengths and space for the finfo table (to be
581 * used by pp_params).
582 */
583 nargs = 2 * nargs + 1;
584 parg = (int *)getitem(1, sizeof(int) * nargs);
585
586 pfinfo = (finfo_t *)getitem(1, sizeof(finfo_t) * nentries);
587 BZERO(pfinfo, finfo_t, nentries);
588
589 argpos = 0;
590 for (func = gbl.entries; func != NOSYM; func = SYMLKG(func)) {
591 int savlenpos, i, total_words;
592
593 total_words = 0;
594 MIDNUMP(func, finfox++); /* remember index to func's finfo */
595 nargs = PARAMCTG(func);
596 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(func));
597 curpos = 0;
598 if (gbl.rutype != RU_FUNC)
599 goto scan_args;
600 /*
601 * enter the function return variable into the group return table
602 * (table is shared with the finfo table) if not already there.
603 */
604 for (i = 0; i < retgrp_cnt; i++)
605 if (pfinfo[i].fval == FVALG(func)) {
606 pfinfo[MIDNUMG(func)].retgrp = i;
607 if (EXPDBG(8, 256))
608 fprintf(gbl.dbgfil, "%s shares group %d\n", SYMNAME(func), i);
609 goto check_type;
610 }
611 pfinfo[retgrp_cnt].fval = FVALG(func);
612 pfinfo[MIDNUMG(func)].retgrp = retgrp_cnt;
613 if (EXPDBG(8, 256))
614 fprintf(gbl.dbgfil, "%s enters group %d, %s\n", SYMNAME(func), retgrp_cnt,
615 SYMNAME(FVALG(func)));
616 retgrp_cnt++;
617
618 check_type:
619 switch (DTY(DTYPEG(func))) {
620 case TY_CHAR:
621 case TY_NCHAR:
622 /* NOTE: if function returns char, then all entries return char
623 */
624 if (func == gbl.currsub) {
625 sym = dpdscp[nargs - 1];
626 parg[1] = sym;
627 if (needlen(sym, func) &&
628 (DTYPEG(func) == DT_ASSCHAR || DTYPEG(func) == DT_DEFERCHAR ||
629 DTYPEG(func) == DT_DEFERNCHAR || DTYPEG(func) == DT_ASSNCHAR)) {
630 int clen = CLENG(sym);
631 if (clen == 0 || !REDUCG(clen)) {
632 clen = getdumlen();
633 CLENP(sym, clen);
634 }
635 parg[2] = clen;
636 ADDRESSP(clen, 2);
637 } else
638 parg[2] = -sym;
639 ADDRESSP(sym, 1);
640 argpos = 2;
641 }
642 curpos = 2;
643 nargs--;
644 total_words += 2;
645 break;
646 case TY_CMPLX:
647 case TY_DCMPLX:
648 /* for complex functions, an extra argument is the first argument
649 * which is also used to return the result.
650 */
651 if (CFUNCG(func) || CMPLXFUNC_C) {
652 break;
653 }
654 curpos = 1;
655 sym = dpdscp[nargs - 1];
656 pos = ADDRESSG(sym) & 0xffff;
657 if (pos == 0) {
658 parg[++argpos] = sym;
659 ADDRESSP(sym, argpos);
660 pos = argpos;
661 }
662 if (pos != curpos) {
663 COPYPRMSP(func, 1);
664 COPYPRMSP(sym, 1);
665 }
666 nargs--;
667 total_words++;
668 break;
669 default:
670 break;
671 }
672
673 scan_args:
674 savlenpos = lenpos = argpos + nargs;
675
676 while (nargs--) {
677 int osym;
678 DTYPE dt;
679 curpos++;
680 sym = *dpdscp;
681 osym = sym;
682
683 if (((DTY(DTYPEG(sym))) == TY_STRUCT) ||
684 ((DTY(DTYPEG(sym))) == TY_ARRAY) || ((DTY(DTYPEG(sym))) == TY_UNION))
685 /* no passbyvalue arrays, structs */
686 byvalue = 0;
687 else
688 byvalue = BYVALDEFAULT(func);
689
690 if (PASSBYVALG(sym))
691 byvalue = 1;
692 if (PASSBYREFG(sym))
693 byvalue = 0;
694
695 if (SCG(sym) == SC_BASED && MIDNUMG(sym) && XBIT(57, 0x80000) &&
696 SCG(MIDNUMG(sym)) == SC_DUMMY) {
697 /* for char, we put pointee in argument list so as to get
698 * the char length here, but we really pass the pointer
699 * use the actual pointer */
700 sym = MIDNUMG(sym);
701 }
702 dpdscp++;
703 pos = ADDRESSG(sym) & 0xffff;
704 if (pos == 0) {
705 parg[++argpos] = sym;
706 ADDRESSP(sym, argpos);
707 pos = argpos;
708 }
709 if (pos != curpos) {
710 COPYPRMSP(func, 1);
711 COPYPRMSP(sym, 1);
712 }
713 total_words++;
714 dt = DDTG(DTYPEG(osym));
715
716 if (byvalue) {
717 if (DTY(dt) == TY_DBLE || DTY(dt) == TY_INT8 || DTY(dt) == TY_LOG8 ||
718 DTY(dt) == TY_CMPLX)
719 total_words++;
720 else if (DTY(dt) == TY_DCMPLX)
721 total_words += 3;
722 else if (DTY(dt) == TY_STRUCT && (size_of(DTYPEG(osym)) > 4))
723 total_words += size_of(DTYPEG(osym)) / 4 - 1;
724 }
725
726 /*
727 * save length if character
728 */
729 if ((DTYG(DTYPEG(osym)) == TY_CHAR || DTYG(DTYPEG(osym)) == TY_NCHAR) &&
730 needlen(osym, func)) {
731 parg[++lenpos] = osym;
732 total_words++;
733 }
734 }
735 /*
736 * all arguments have been processed for func; process the lengths
737 * which have been saved in the table. Since there could be a gap
738 * between the arguments and the lengths, the lengths which are seen
739 * for the first time are moved up to follow the arguments.
740 */
741 while (savlenpos < lenpos) {
742 int lsym, osym;
743
744 savlenpos++;
745 curpos++;
746 sym = parg[savlenpos];
747 osym = sym;
748 if (SCG(sym) == SC_BASED && MIDNUMG(sym) && XBIT(57, 0x80000) &&
749 SCG(MIDNUMG(sym)) == SC_DUMMY) {
750 /* for char, we put pointee in argument list so as to get
751 * the char length here, but we really pass the pointer
752 * use the actual pointer */
753 sym = MIDNUMG(sym);
754 }
755 pos = (ADDRESSG(sym) >> 16) & 0xffff;
756 if (pos == 0) {
757 ++argpos;
758 ADDRESSP(sym, argpos << 16 | ADDRESSG(sym));
759 if (needlen(sym, func) && (DDTG(DTYPEG(osym)) == DT_ASSCHAR ||
760 DDTG(DTYPEG(osym)) == DT_DEFERCHAR ||
761 DDTG(DTYPEG(osym)) == DT_DEFERNCHAR ||
762 DDTG(DTYPEG(osym)) == DT_ASSNCHAR)) {
763 int clen;
764 clen = CLENG(osym);
765 if (clen == 0) {
766 clen = getdumlen();
767 CLENP(osym, clen);
768 parg[argpos] = clen;
769 } else if (REDUCG(clen)) {
770 parg[argpos] = clen;
771 } else {
772 /* adjustable length dummy */
773 parg[argpos] = -sym;
774 AUTOBJP(osym, 1); /* mark as adjustable length */
775 }
776 } else
777 parg[argpos] = -sym;
778 pos = argpos;
779 }
780 if (pos != curpos &&
781 (DDTG(DTYPEG(osym)) == DT_ASSCHAR ||
782 DDTG(DTYPEG(osym)) == DT_DEFERCHAR ||
783 DDTG(DTYPEG(osym)) == DT_DEFERNCHAR ||
784 DDTG(DTYPEG(osym)) == DT_ASSNCHAR)
785 && !AUTOBJG(osym)
786 ) {
787 sym = CLENG(osym);
788 #if DEBUG
789 assert(sym != 0, "pp_entries: 0 clen", parg[savlenpos], ERR_Severe);
790 #endif
791 parg[pos] = sym;
792 COPYPRMSP(sym, 1);
793 COPYPRMSP(func, 1);
794 }
795 }
796 #if defined(TARGET_WIN)
797 if (MSCALLG(func)) {
798 if (EXPDBG(8, 256))
799 fprintf(gbl.dbgfil, "%s total_words %d\n", SYMNAME(func), total_words);
800 if (total_words > 0) {
801 ARGSIZEP(func, total_words * 4);
802 } else if (total_words == 0)
803 ARGSIZEP(func, -1);
804 }
805 #endif
806 }
807 for (pos = 1; pos <= argpos; pos++) {
808 sym = parg[pos];
809 if (sym > 0) {
810 if (EXPDBG(8, 256))
811 fprintf(gbl.dbgfil, "%4d: %s %s\n", pos, SYMNAME(sym),
812 COPYPRMSG(sym) ? "<copied>" : "");
813 ADDRESSP(sym, 0);
814 } else if (EXPDBG(8, 256))
815 fprintf(gbl.dbgfil, "%4d: length of %s\n", pos, SYMNAME(-sym));
816 }
817
818 if (retgrp_cnt > 1) {
819 retgrp_var = getccsym('F', 0, ST_VAR);
820 SCP(retgrp_var, SC_LOCAL);
821 DTYPEP(retgrp_var, DT_INT);
822 }
823 }
824
825 /*
826 * WARNING: there are nomixedstrlen and mixedstrlen functions to preprocess
827 * entries.
828 */
829 static void
pp_entries_mixedstrlen(void)830 pp_entries_mixedstrlen(void)
831 {
832 int func;
833 int nargs;
834 int *dpdscp;
835 SPTR sym;
836 int curpos;
837 int pos;
838 int argpos;
839 int finfox;
840 int byvalue = 0;
841 /*
842 * Preprocess the entries in the subprogram to determine for which
843 * entries arguments must be copied due to the arguments occupying
844 * different positions. The entry and the arguments which must
845 * be copied are flagged (COPYPRMS flag). Also, for a character
846 * argument whose length is passed, a symbol table entry is created
847 * to represent its length (the arg's CLEN field will locate the length
848 * ST item).
849 *
850 * A unique list (table) is created (located by parg) of the arguments
851 * and lengths for character arguments which appear in all of the entries.
852 * While a function is processed, a section of the table is divided into
853 * two tables: the first table is used for the arguments and the second
854 * table is used for lengths. argpos is an index into the table and
855 * locates the position of the most recent unique argument; lenpos indicates
856 * the position of the most recent character length.
857 *
858 * Note that the ADDRESS field is temporarily used to record the
859 * argument's position in the list created for all the arguments.
860 * An argument is entered into the list only once even though it
861 * may occur in more than one entry.
862 */
863
864 /* compute number of entries and total number of arguments */
865 finfox = retgrp_cnt = nentries = nargs = 0;
866 for (func = gbl.entries; func != NOSYM; func = SYMLKG(func)) {
867 nargs += PARAMCTG(func);
868 nentries++;
869 }
870 if (nentries > 1) {
871 sym = getccsym('Q', expb.gentmps++, ST_VAR);
872 SCP(sym, SC_LOCAL);
873 DTYPEP(sym, DT_INT);
874 aux.curr_entry->ent_save = sym;
875 ADDRTKNP(sym, 1); /* so optimizer won't delete */
876 }
877 /*
878 * assume all arguments are character arguments; note that the first
879 * argument is in position 1. Allocate space for the table used to
880 * record arguments and lengths and space for the finfo table (to be
881 * used by pp_params).
882 */
883 nargs = 2 * nargs + 1;
884 parg = (int *)getitem(1, sizeof(int) * nargs);
885
886 pfinfo = (finfo_t *)getitem(1, sizeof(finfo_t) * nentries);
887 BZERO(pfinfo, finfo_t, nentries);
888
889 argpos = 0;
890 for (func = gbl.entries; func != NOSYM; func = SYMLKG(func)) {
891 int i, total_words;
892
893 total_words = 0;
894 MIDNUMP(func, finfox++); /* remember index to func's finfo */
895 nargs = PARAMCTG(func);
896 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(func));
897 curpos = 0;
898 if (gbl.rutype != RU_FUNC)
899 goto scan_args;
900 /*
901 * enter the function return variable into the group return table
902 * (table is shared with the finfo table) if not already there.
903 */
904 for (i = 0; i < retgrp_cnt; i++)
905 if (pfinfo[i].fval == FVALG(func)) {
906 pfinfo[MIDNUMG(func)].retgrp = i;
907 if (EXPDBG(8, 256))
908 fprintf(gbl.dbgfil, "%s shares group %d\n", SYMNAME(func), i);
909 goto check_type;
910 }
911 pfinfo[retgrp_cnt].fval = FVALG(func);
912 pfinfo[MIDNUMG(func)].retgrp = retgrp_cnt;
913 if (EXPDBG(8, 256))
914 fprintf(gbl.dbgfil, "%s enters group %d, %s\n", SYMNAME(func), retgrp_cnt,
915 SYMNAME(FVALG(func)));
916 retgrp_cnt++;
917
918 check_type:
919 switch (DTY(DTYPEG(func))) {
920 case TY_CHAR:
921 case TY_NCHAR:
922 /* NOTE: if function returns char, then all entries return char
923 */
924 if (func == gbl.currsub) {
925 sym = convertSPTR(dpdscp[nargs - 1]);
926 parg[1] = sym;
927 if ((DTYPEG(func) == DT_ASSCHAR || DTYPEG(func) == DT_DEFERCHAR ||
928 DTYPEG(func) == DT_DEFERNCHAR || DTYPEG(func) == DT_ASSNCHAR)) {
929 int clen = CLENG(sym);
930 if (clen == 0 || !REDUCG(clen)) {
931 clen = getdumlen();
932 CLENP(sym, clen);
933 }
934 parg[2] = CLENG(sym);
935 ADDRESSP(parg[2], 2);
936 } else
937 parg[2] = -sym;
938 ADDRESSP(sym, 1);
939 argpos = 2;
940 }
941 curpos = 2;
942 nargs--;
943 total_words++;
944 /* character length */
945 if (needlen(sym, func)) {
946 total_words++;
947 }
948
949 break;
950 case TY_CMPLX:
951 case TY_DCMPLX:
952 /* for complex functions, an extra argument is the first argument
953 * which is also used to return the result.
954 */
955 curpos = 1;
956 sym = convertSPTR(dpdscp[nargs - 1]);
957 pos = ADDRESSG(sym) & 0xffff;
958 if (pos == 0) {
959 parg[++argpos] = sym;
960 ADDRESSP(sym, argpos);
961 pos = argpos;
962 }
963 if (pos != curpos) {
964 COPYPRMSP(func, 1);
965 COPYPRMSP(sym, 1);
966 }
967 nargs--;
968 total_words++;
969 break;
970 default:
971 break;
972 }
973
974 scan_args:
975 while (nargs--) {
976 int osym;
977 DTYPE dt;
978 curpos++;
979 sym = convertSPTR(*dpdscp);
980 osym = sym;
981
982 if (((DTY(DTYPEG(sym))) == TY_STRUCT) ||
983 ((DTY(DTYPEG(sym))) == TY_ARRAY) || ((DTY(DTYPEG(sym))) == TY_UNION))
984 /* no passbyvalue arrays, structs */
985 byvalue = 0;
986 else
987 byvalue = BYVALDEFAULT(func);
988
989 if (PASSBYVALG(sym))
990 byvalue = 1;
991 if (PASSBYREFG(sym))
992 byvalue = 0;
993
994 if (SCG(sym) == SC_BASED && MIDNUMG(sym) && XBIT(57, 0x80000) &&
995 SCG(MIDNUMG(sym)) == SC_DUMMY) {
996 /* char pointers, we put the pointee on the argument
997 * list so as to get the char length, but we really pass
998 * the pointer.
999 * replace by the actual pointer */
1000 sym = MIDNUMG(sym);
1001 }
1002 dpdscp++;
1003 pos = ADDRESSG(sym) & 0xffff;
1004 if (pos == 0) {
1005 parg[++argpos] = sym;
1006 ADDRESSP(sym, argpos);
1007 pos = argpos;
1008 }
1009 if (pos != curpos) {
1010 COPYPRMSP(func, 1);
1011 COPYPRMSP(sym, 1);
1012 }
1013 total_words++;
1014 dt = DDTG(DTYPEG(osym));
1015
1016 if (byvalue) {
1017 if (DTY(dt) == TY_DBLE || DTY(dt) == TY_INT8 || DTY(dt) == TY_LOG8 ||
1018 DTY(dt) == TY_CMPLX)
1019 total_words++;
1020 else if (DTY(dt) == TY_DCMPLX)
1021 total_words += 3;
1022 else if (DTY(dt) == TY_STRUCT && (size_of(DTYPEG(osym)) > 4))
1023 total_words += size_of(DTYPEG(osym)) / 4 - 1;
1024 }
1025
1026 /*
1027 * save length if character
1028 */
1029 if (DTY(dt) == TY_CHAR || DTY(dt) == TY_NCHAR) {
1030 curpos++;
1031 pos = (ADDRESSG(sym) >> 16) & 0xffff;
1032 if (pos == 0) {
1033 pos = ++argpos;
1034 ADDRESSP(sym, argpos << 16 | ADDRESSG(sym));
1035 if (needlen(sym, func) &&
1036 (dt == DT_ASSCHAR || dt == DT_ASSNCHAR || dt == DT_DEFERCHAR ||
1037 dt == DT_DEFERNCHAR)) {
1038 int clen;
1039 clen = CLENG(osym);
1040 if (clen == 0) {
1041 clen = getdumlen();
1042 CLENP(osym, clen);
1043 parg[argpos] = CLENG(osym);
1044 } else if (REDUCG(clen)) {
1045 parg[argpos] = clen;
1046 } else {
1047 /* adjustable length dummy */
1048 parg[argpos] = -sym;
1049 AUTOBJP(osym, 1); /* mark as adjustable length */
1050 }
1051 } else
1052 parg[argpos] = -sym;
1053 }
1054 if (pos != curpos &&
1055 (dt == DT_ASSCHAR || dt == DT_ASSNCHAR || dt == DT_DEFERCHAR ||
1056 dt == DT_DEFERNCHAR)
1057 && !AUTOBJG(osym)
1058 ) {
1059 sym = CLENG(osym);
1060 #if DEBUG
1061 assert(sym != 0, "pp_entries_mixedstrlen: 0 clen", parg[pos],
1062 ERR_Severe);
1063 #endif
1064 COPYPRMSP(sym, 1);
1065 COPYPRMSP(func, 1);
1066 }
1067 if (needlen(sym, func)) {
1068 total_words++;
1069 }
1070 }
1071 }
1072 if (WINNT_CALL) {
1073 if (EXPDBG(8, 256))
1074 fprintf(gbl.dbgfil, "%s total_words %d\n", SYMNAME(func), total_words);
1075 if (total_words > 0) {
1076 ARGSIZEP(func, total_words * 4);
1077 } else if (total_words == 0)
1078 ARGSIZEP(func, -1);
1079 }
1080 }
1081 for (pos = 1; pos <= argpos; pos++) {
1082 sym = convertSPTR(parg[pos]);
1083 if (sym > 0) {
1084 if (EXPDBG(8, 256))
1085 fprintf(gbl.dbgfil, "%4d: %s %s\n", pos, SYMNAME(sym),
1086 COPYPRMSG(sym) ? "<copied>" : "");
1087 ADDRESSP(sym, 0);
1088 } else if (EXPDBG(8, 256))
1089 fprintf(gbl.dbgfil, "%4d: length of %s\n", pos, SYMNAME(-sym));
1090 }
1091
1092 if (retgrp_cnt > 1) {
1093 retgrp_var = getccsym('F', 0, ST_VAR);
1094 SCP(retgrp_var, SC_LOCAL);
1095 DTYPEP(retgrp_var, DT_INT);
1096 }
1097 }
1098
1099 SPTR
getdumlen(void)1100 getdumlen(void)
1101 {
1102 SPTR sym = getccsym('U', expb.chardtmps++, ST_VAR);
1103 if (CHARLEN_64BIT) {
1104 DTYPEP(sym, DT_INT8);
1105 } else {
1106 DTYPEP(sym, DT_INT);
1107 }
1108 SCP(sym, SC_DUMMY);
1109 REDUCP(sym, 1); /* mark temp as char len dummy */
1110 PASSBYVALP(sym, 1); /* Char len dummies are passed by value */
1111 return sym;
1112 }
1113
1114 SPTR
gethost_dumlen(int arg,ISZ_T address)1115 gethost_dumlen(int arg, ISZ_T address)
1116 {
1117 SPTR sym = getccsym('U', arg, ST_VAR);
1118 if (CHARLEN_64BIT) {
1119 DTYPEP(sym, DT_INT8);
1120 } else {
1121 DTYPEP(sym, DT_INT);
1122 }
1123 SCP(sym, SC_DUMMY);
1124 ADDRESSP(sym, address);
1125 REDUCP(sym, 1); /* mark temp as char len dummy */
1126 UPLEVELP(sym, 1);
1127 PASSBYVALP(sym, 1);
1128 pop_sym(sym); /* don't let this symbol conflict with getdumlen() */
1129 return sym;
1130 }
1131
1132 static int
exp_type_bound_proc_call(int arg,SPTR descno,int vtoff,int arglnk)1133 exp_type_bound_proc_call(int arg, SPTR descno, int vtoff, int arglnk)
1134 {
1135
1136 SPTR sym;
1137 int ili, acon, con;
1138 int type_offset, vft_offset, func_offset, sz;
1139 INT v[2];
1140 int jsra_mscall_flag;
1141
1142 sym = descno;
1143
1144 if (XBIT(68, 0x1)) {
1145 type_offset = 72;
1146 vft_offset = 80;
1147 } else {
1148 type_offset = 40;
1149 vft_offset = 48;
1150 }
1151 func_offset = 8 * (vtoff - 1);
1152 sz = MSZ_I8;
1153 ADDRTKNP(sym, 1);
1154 if (SCG(sym) == SC_EXTERN) {
1155 int ili2;
1156 SPTR tmp = getccsym_sc('Q', expb.gentmps++, ST_VAR, SC_LOCAL);
1157
1158 DTYPEP(tmp, DT_ADDR);
1159
1160 ili = ad1ili(IL_ACON, get_acon(sym, 0));
1161
1162 ili2 = ad1ili(IL_ACON, get_acon(tmp, 0));
1163
1164 ili = ad3ili(IL_STA, ili, ili2, NME_UNK);
1165 chk_block(ili);
1166
1167 ili = ad2ili(IL_LDA, ili2, NME_UNK);
1168 ili = ad3ili(IL_AADD, ili, ad_aconi(vft_offset), 0);
1169 ili = ad2ili(IL_LDA, ili, NME_UNK);
1170 ili = ad3ili(IL_AADD, ili, ad_aconi(func_offset), 0);
1171 ili = ad2ili(IL_LDA, ili, NME_UNK);
1172 } else if (SCG(sym) != SC_DUMMY) {
1173 ili = mk_address(sym);
1174 ili = ad3ili(IL_AADD, ili, ad_aconi(type_offset), 0);
1175 ili = ad2ili(IL_LDA, ili, NME_UNK);
1176 ili = ad3ili(IL_AADD, ili, ad_aconi(vft_offset), 0);
1177 ili = ad2ili(IL_LDA, ili, NME_UNK);
1178 ili = ad3ili(IL_AADD, ili, ad_aconi(func_offset), 0);
1179 ili = ad2ili(IL_LDA, ili, NME_UNK);
1180 } else {
1181 if (!TASKDUPG(gbl.currsub) && CONTAINEDG(gbl.currsub) && INTERNREFG(sym)) {
1182 ili = mk_address(sym);
1183 } else {
1184 const SPTR asym = mk_argasym(sym);
1185 const int addr = mk_address(sym);
1186 ili = ad2ili(IL_LDA, addr, addnme(NT_VAR, asym, 0, 0));
1187 }
1188 ili = ad3ili(IL_AADD, ili, ad_aconi(type_offset), 0);
1189 ili = ad2ili(IL_LDA, ili, NME_UNK);
1190 ili = ad3ili(IL_AADD, ili, ad_aconi(vft_offset), 0);
1191 ili = ad2ili(IL_LDA, ili, NME_UNK);
1192 ili = ad3ili(IL_AADD, ili, ad_aconi(func_offset), 0);
1193 ili = ad2ili(IL_LDA, ili, NME_UNK);
1194 }
1195
1196 if (!MSCALLG(arg))
1197 jsra_mscall_flag = 0;
1198 else
1199 jsra_mscall_flag = 0x1;
1200
1201 return ad4ili(IL_JSRA, ili, arglnk, jsra_mscall_flag, fptr_iface);
1202 }
1203
1204 static int
has_desc_arg(int func,int sptr)1205 has_desc_arg(int func, int sptr)
1206 {
1207
1208 int argsym, nargs, *dpdscp, i;
1209 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(func));
1210 nargs = PARAMCTG(func);
1211
1212 for (i = 0; i < nargs; ++i) {
1213 argsym = dpdscp[i];
1214 if (SDSCG(sptr) == argsym)
1215 return 1;
1216 }
1217 return 0;
1218 }
1219
1220 static int
check_desc(int func,int sptr)1221 check_desc(int func, int sptr)
1222 {
1223 /* Called by check_desc_args() below. Swaps traditional descriptor arguments
1224 * with type descriptor arguments when they're out of order.
1225 */
1226
1227 int nargs, *dpdscp, desc, *scratch;
1228 int pos, pos2, pos3, argsym, i, seenCC, seenDesc, seenSym, seenClass;
1229 int swap_from, swap_to, j, pos4, rslt;
1230
1231 rslt = 0;
1232 desc = SDSCG(sptr);
1233 if (!desc)
1234 return 0;
1235
1236 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(func));
1237 nargs = PARAMCTG(func);
1238
1239 for (seenSym = seenDesc = seenCC = seenClass = pos = pos2 = pos3 = pos4 = i =
1240 0;
1241 i < nargs; ++i) {
1242 argsym = dpdscp[i];
1243
1244 if (!seenSym &&
1245 (!SDSCG(argsym) || (SCG(SDSCG(argsym)) != SC_DUMMY &&
1246 (!CLASSG(argsym) || FVALG(func) == argsym)))) {
1247 ++pos4;
1248 }
1249 if (argsym == sptr) {
1250 pos = i;
1251 seenSym = 1;
1252 } else if (argsym == desc) {
1253 pos2 = i;
1254 seenDesc = 1;
1255 }
1256 if (!pos3 && CCSYMG(argsym) && seenSym) {
1257 pos3 = i;
1258 seenCC = 1;
1259 }
1260 if (CLASSG(argsym)) {
1261 seenClass = 1;
1262 }
1263 }
1264
1265 if (seenCC && seenDesc && seenSym && seenClass) {
1266
1267 NEW(scratch, int, nargs);
1268 assert(scratch, "check_desc: out of memory!", 0, ERR_Fatal);
1269 swap_from = pos2;
1270 swap_to = pos3 + (pos - pos4);
1271 scratch[swap_to] = dpdscp[swap_from];
1272 for (j = i = 0; i < nargs && j < nargs;) {
1273 if (j == swap_to) {
1274 ++j;
1275 continue;
1276 }
1277 if (i == swap_from) {
1278 ++i;
1279 continue;
1280 }
1281 scratch[j] = dpdscp[i];
1282 ++j;
1283 ++i;
1284 }
1285
1286 for (i = 0; i < nargs; ++i) {
1287 dpdscp[i] = scratch[i];
1288 }
1289 FREE(scratch);
1290 rslt = 1;
1291 }
1292 return rslt;
1293 }
1294
1295 static void
check_desc_args(int func)1296 check_desc_args(int func)
1297 {
1298 /* Reorder arguments if we're mixing traditional descriptor arguments w/
1299 * type descriptor arguments since they get emitted at different times
1300 * in the front end.
1301 */
1302 int i, nargs, *dpdscp, argsym, swap;
1303 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(func));
1304 nargs = PARAMCTG(func);
1305
1306 swap = 0;
1307 for (i = 0; i < nargs; ++i) {
1308 argsym = dpdscp[i];
1309 if (0 && CCSYMG(argsym))
1310 break;
1311 if (SDSCG(argsym)) {
1312 DESCARRAYP(SDSCG(argsym), 1); /* needed by type bound procedures */
1313 if (STYPEG(argsym) == ST_PROC) {
1314 /* needed when we have procedure dummy arguments with character
1315 * arguments
1316 */
1317 IS_PROC_DESCRP(SDSCG(argsym), 1);
1318 }
1319
1320 if (check_desc(func, argsym))
1321 swap = 1;
1322 }
1323 }
1324 }
1325
1326 bool
func_has_char_args(SPTR func)1327 func_has_char_args(SPTR func)
1328 {
1329 int i, nargs, *dpdscp;
1330 DTYPE argdtype;
1331
1332 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(func));
1333 nargs = PARAMCTG(func);
1334
1335 for (i = 0; i < nargs; ++i) {
1336 const SPTR argsym = convertSPTR(dpdscp[i]);
1337 argdtype = DTYPEG(argsym);
1338 if (DTYG(argdtype) == TY_CHAR || DTYG(argdtype) == TY_NCHAR)
1339 return true;
1340 }
1341
1342 return false;
1343 }
1344
1345 INLINE static int
check_struct(DTYPE dtype)1346 check_struct(DTYPE dtype)
1347 {
1348 if (ll_check_struct_return(dtype))
1349 return CLASS_INT4; /* something not CLASS_MEM */
1350 return CLASS_MEM;
1351 }
1352
1353 static int
check_return(DTYPE retdtype)1354 check_return(DTYPE retdtype)
1355 {
1356 if (DTY(retdtype) == TY_STRUCT || DTY(retdtype) == TY_UNION ||
1357 DT_ISCMPLX(retdtype))
1358 return check_struct(retdtype);
1359 if (retdtype == DT_INT8) /* could be the fval of a C_PTR function */
1360 return CLASS_INT8;
1361 return CLASS_INT4; /* something not CLASS_MEM */
1362 }
1363
1364 INLINE static void
align_struct_tmp(int sptr)1365 align_struct_tmp(int sptr)
1366 {
1367 #if defined(X86_64)
1368 if (DTY(DTYPEG(sptr)) == TY_STRUCT && PDALNG(sptr) == 4) {
1369 return;
1370 }
1371 #endif
1372
1373 switch (alignment(DTYPEG(sptr))) {
1374 case 0:
1375 case 1:
1376 case 3:
1377 PDALNP(sptr, 2);
1378 break;
1379 case 7:
1380 PDALNP(sptr, 3);
1381 break;
1382 case 15:
1383 PDALNP(sptr, 4);
1384 break;
1385 case 31:
1386 PDALNP(sptr, 5);
1387 break;
1388 default:
1389 #if DEBUG
1390 interr("align_struct_tmp: unexpected alignment", alignment(DTYPEG(sptr)),
1391 ERR_Severe);
1392 #endif
1393 break;
1394 }
1395 }
1396
1397 /**
1398 \brief Does the bind(c) function return the struct in register(s)?
1399 \param func_sym the function's symbol
1400 */
1401 bool
bindC_function_return_struct_in_registers(int func_sym)1402 bindC_function_return_struct_in_registers(int func_sym)
1403 {
1404 DEBUG_ASSERT(CFUNCG(func_sym), "function not bind(c)");
1405 return check_return(DTYPEG(func_sym)) != CLASS_MEM;
1406 }
1407
1408 static void
handle_bindC_func_ret(int func,finfo_t * pf)1409 handle_bindC_func_ret(int func, finfo_t *pf)
1410 {
1411 int retdesc;
1412 int retsym = pf->fval;
1413 const DTYPE retdtype = DTYPEG(retsym);
1414
1415 ADDRTKNP(retsym, 1);
1416 retdesc = check_return(retdtype);
1417 if (retdesc == CLASS_MEM) {
1418 /* Large struct: the address is passed in as an argument */
1419 SCP(retsym, SC_DUMMY);
1420 return;
1421 }
1422 align_struct_tmp(retsym);
1423 pf->ret_sm_struct = retdesc;
1424 pf->ret_align = alignment(retdtype);
1425 }
1426
1427 static bool
process_end_of_list(SPTR func,SPTR osym,int * nlens,DTYPE argdtype)1428 process_end_of_list(SPTR func, SPTR osym, int *nlens, DTYPE argdtype)
1429 {
1430 if (needlen(osym, func) &&
1431 (DTYG(argdtype) == TY_CHAR || DTYG(argdtype) == TY_NCHAR)
1432 ||
1433 (IS_PROC_DESCRG(osym) && !HAS_OPT_ARGSG(func) && func_has_char_args(func))
1434 ) {
1435 parg[*nlens] = osym;
1436 *nlens += 1;
1437 return true;
1438 }
1439
1440 return false;
1441 }
1442
1443 /*
1444 * WARNING: there are nomixedstrlen and mixedstrlen functions to preprocess
1445 * parameters.
1446 */
1447 static void
pp_params(SPTR func)1448 pp_params(SPTR func)
1449 {
1450 int tmp;
1451 int op1;
1452 SPTR argsym;
1453 int asym;
1454 DTYPE argdtype;
1455 int al;
1456 int nargs;
1457 int *dpdscp;
1458 int nlens;
1459 int byvalue;
1460 finfo_t *pf;
1461
1462 check_desc_args(func);
1463
1464 if (EXPDBG(8, 256))
1465 fprintf(gbl.dbgfil, "---pp_params: %s ---\n", SYMNAME(func));
1466 pf = &pfinfo[MIDNUMG(func)]; /* pfinfo alloc'd and init'd by pp_entries */
1467 argdtype = DTYPEG(func);
1468 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(func));
1469 nargs = PARAMCTG(func);
1470 nlens = 0;
1471 byvalue = 0;
1472 pf->mem_off = 8; /* offset for 1st dummy arg */
1473 if (gbl.rutype != RU_FUNC)
1474 goto scan_args;
1475
1476 if (CFUNCG(func) || (CMPLXFUNC_C && DT_ISCMPLX(argdtype))) {
1477 handle_bindC_func_ret(func, &pfinfo[pf->retgrp]);
1478 }
1479
1480 switch (DTY(argdtype)) {
1481 case TY_CHAR:
1482 case TY_NCHAR:
1483 /*
1484 * If this is a function which returns character, the first
1485 * two arguments are for the return length. The last entry in
1486 * the function's dpdsc auxiliary area is the "return" symbol.
1487 */
1488 argsym = convertSPTR(dpdscp[nargs - 1]);
1489 if (EXPDBG(8, 256))
1490 fprintf(gbl.dbgfil, "func returns char, through %s\n", SYMNAME(argsym));
1491 MEMARGP(argsym, 1);
1492 ADDRESSP(argsym, 8);
1493 asym = mk_argasym(argsym);
1494 ADDRESSP(asym, ADDRESSG(argsym)); /* propagate ADDRESS */
1495 MEMARGP(asym, 1);
1496 argsym = CLENG(argsym);
1497 if (argsym) {
1498 if (EXPDBG(8, 256))
1499 fprintf(gbl.dbgfil, "func return len in %s\n", SYMNAME(argsym));
1500 MEMARGP(argsym, 1);
1501 ADDRESSP(argsym, 12);
1502 asym = mk_argasym(argsym);
1503 ADDRESSP(asym, ADDRESSG(argsym)); /* propagate ADDRESS */
1504 MEMARGP(asym, 1);
1505 }
1506 pf->mem_off = 16; /* offset for 1st dummy arg */
1507 nargs--;
1508 break;
1509 case TY_CMPLX:
1510 case TY_DCMPLX:
1511 /*
1512 * If this is a function which returns complex, the first arg is
1513 * also for the return value. The last entry in the function's
1514 * dpdsc auxiliary area is the "return" symbol.
1515 */
1516 if (!CFUNCG(func) && !CMPLXFUNC_C) {
1517 argsym = convertSPTR(dpdscp[nargs - 1]);
1518 MEMARGP(argsym, 1);
1519 ADDRESSP(argsym, 8);
1520 asym = mk_argasym(argsym);
1521 ADDRESSP(asym, ADDRESSG(argsym)); /* propagate ADDRESS */
1522 MEMARGP(asym, 1);
1523 if (EXPDBG(8, 256))
1524 fprintf(gbl.dbgfil, "func also returns complex, through %s\n",
1525 SYMNAME(argsym));
1526 pf->mem_off = 12; /* offset for 1st dummy arg */
1527 nargs--;
1528 }
1529 break;
1530 default:
1531 break;
1532 }
1533 scan_args:
1534 /*
1535 * scan through all of the arguments of the function to compute
1536 * how (register or memory area) and where (reg # or offset) the
1537 * arguments area passed. Also, generate the the ili if the argument
1538 * must be copied. If a register argument is not copied, it is recorded
1539 * in the entry's finfo table; if the arg has been copied, a register
1540 * is still "assigned" but it is not recorded (slot is zero).
1541 *
1542 * The only concern for now is arguments which are addresses; the
1543 * exception is the lengths of character args (actually only those
1544 * which are passed length). If compiler is enhanced to allow value
1545 * parameters, presumably there will be some way to distinguish these
1546 * from reference arguments (i.e., a symbol table flag).
1547 */
1548 while (nargs--) {
1549 SPTR osym;
1550 argsym = convertSPTR(*dpdscp++);
1551 osym = argsym;
1552 argdtype = DTYPEG(osym);
1553 if (IS_PROC_DESCRG(osym) && !HAS_OPT_ARGSG(func) &&
1554 process_end_of_list(func, osym, &nlens, argdtype)) {
1555 continue;
1556 }
1557 if (((DTY(DTYPEG(argsym))) == TY_STRUCT) ||
1558 ((DTY(DTYPEG(argsym))) == TY_ARRAY) ||
1559 ((DTY(DTYPEG(argsym))) == TY_UNION))
1560 /* no passbyvalue arrays, structs */
1561 byvalue = 0;
1562 else
1563 byvalue = BYVALDEFAULT(func);
1564
1565 if (PASSBYVALG(argsym))
1566 byvalue = 1;
1567 if (PASSBYREFG(argsym))
1568 byvalue = 0;
1569 if (SCG(argsym) == SC_BASED && MIDNUMG(argsym) && XBIT(57, 0x80000) &&
1570 SCG(MIDNUMG(argsym)) == SC_DUMMY) {
1571 /* for char, we put pointee in argument list so as to get
1572 * the char length here, but we really pass the pointer
1573 * use the actual pointer */
1574 argsym = MIDNUMG(argsym);
1575 }
1576 if (EXPDBG(8, 256))
1577 fprintf(gbl.dbgfil, "%s in mem area at %d\n", SYMNAME(argsym),
1578 pf->mem_off);
1579 if (COPYPRMSG(argsym))
1580 cp_memarg(argsym, pf->mem_off, DT_ADDR);
1581 else if (DTY(argdtype) == TY_STRUCT) {
1582 REFP(MIDNUMG(argsym), 1);
1583 cp_memarg(argsym, pf->mem_off, DT_ADDR);
1584 } else {
1585 MEMARGP(argsym, 1);
1586 asym = mk_argasym(argsym);
1587 MEMARGP(asym, 1);
1588 }
1589 if (byvalue) {
1590 if (argdtype == DT_DBLE || argdtype == DT_INT8 || argdtype == DT_LOG8 ||
1591 argdtype == DT_CMPLX)
1592 pf->mem_off += 8;
1593 else if (argdtype == DT_DCMPLX)
1594 pf->mem_off += 16;
1595 else if (DTY(argdtype) == TY_STRUCT)
1596 pf->mem_off += size_of(argdtype);
1597 else
1598 pf->mem_off += 4;
1599 if (DTY(DTYPEG(argsym)) == TY_STRUCT) {
1600 int src_addr, n;
1601 int src_nme;
1602 int dest_addr;
1603 int dest_nme;
1604 SPTR newsptr = get_byval_local(argsym);
1605 dest_addr = ad_acon(newsptr, 0);
1606 dest_nme = addnme(NT_VAR, newsptr, 0, 0);
1607 src_addr = ad_acon(argsym, 0);
1608 src_nme = NME_VOL;
1609 n = size_of(DTYPEG(newsptr));
1610 chk_block(ad5ili(IL_SMOVEJ, src_addr, dest_addr, src_nme, dest_nme,
1611 n));
1612 }
1613 } else {
1614 pf->mem_off += 4;
1615 }
1616 process_end_of_list(func, osym, &nlens, argdtype);
1617
1618 if ((!HOMEDG(argsym) && (SCG(argsym) == SC_DUMMY)) &&
1619 (!PASSBYREFG(argsym)) &&
1620 (PASSBYVALG(argsym) ||
1621 (BYVALDEFAULT(func) && (((DTY(DTYPEG(argsym))) != TY_ARRAY) &&
1622 ((DTY(DTYPEG(argsym))) != TY_STRUCT) &&
1623 ((DTY(DTYPEG(argsym))) != TY_UNION))))) {
1624 if (!gbl.outlined && !ISTASKDUPG(GBL_CURRFUNC))
1625 cp_byval_mem_arg(argsym);
1626 PASSBYVALP(argsym, 1);
1627 }
1628 }
1629 /*
1630 * go through the list of character arguments. Here we only care
1631 * about processing those which have passed length; we still need
1632 * to keep track of the registers and the offset into the memory
1633 * argument area for those char arguments which are declared with
1634 * constant lengths.
1635 */
1636 dpdscp = parg;
1637 while (nlens--) {
1638 argsym = convertSPTR(*dpdscp);
1639 if (SCG(argsym) == SC_BASED && MIDNUMG(argsym) && XBIT(57, 0x80000) &&
1640 SCG(MIDNUMG(argsym)) == SC_DUMMY) {
1641 /* for char, we put pointee in argument list so as to get
1642 * the char length here, but we really pass the pointer
1643 * use the actual pointer */
1644 *dpdscp = MIDNUMG(argsym);
1645 }
1646 dpdscp++;
1647 argdtype = DTYPEG(argsym);
1648 if (EXPDBG(8, 256))
1649 fprintf(gbl.dbgfil, "%s.len in mem area at %d\n", SYMNAME(argsym),
1650 pf->mem_off);
1651 if (
1652 (!HAS_OPT_ARGSG(func) && IS_PROC_DESCRG(argsym)) ||
1653 (
1654 !AUTOBJG(argsym) &&
1655 (argsym = CLENG(argsym)))) {
1656 if (COPYPRMSG(argsym))
1657 cp_memarg(argsym, pf->mem_off, expb.charlen_dtype);
1658 else {
1659 MEMARGP(argsym, 1);
1660 asym = mk_argasym(argsym);
1661 MEMARGP(asym, 1);
1662 }
1663 }
1664 pf->mem_off += 4;
1665 }
1666 }
1667
1668 /*
1669 * WARNING: there are nomixedstrlen and mixedstrlen functions to preprocess
1670 * parameters.
1671 */
1672 static void
pp_params_mixedstrlen(int func)1673 pp_params_mixedstrlen(int func)
1674 {
1675 int tmp;
1676 int op1;
1677 SPTR argsym;
1678 int asym;
1679 DTYPE argdtype;
1680 int al;
1681 int nargs;
1682 int *dpdscp;
1683 int nlens;
1684 int byvalue;
1685 finfo_t *pf;
1686
1687 check_desc_args(func);
1688
1689 if (EXPDBG(8, 256))
1690 fprintf(gbl.dbgfil, "---pp_params_mixedstrlen: %s ---\n", SYMNAME(func));
1691 pf = &pfinfo[MIDNUMG(func)]; /* pfinfo alloc'd and init'd by pp_entries */
1692 argdtype = DTYPEG(func);
1693 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(func));
1694 nargs = PARAMCTG(func);
1695 nlens = 0;
1696 byvalue = 0;
1697
1698 pf->mem_off = 8; /* offset for 1st dummy arg */
1699 if (gbl.rutype != RU_FUNC)
1700 goto scan_args;
1701 switch (DTY(argdtype)) {
1702 case TY_CHAR:
1703 case TY_NCHAR:
1704 /*
1705 * If this is a function which returns character, the first
1706 * two arguments are for the return length. The last entry in
1707 * the function's dpdsc auxiliary area is the "return" symbol.
1708 */
1709 argsym = convertSPTR(dpdscp[nargs - 1]);
1710 if (EXPDBG(8, 256))
1711 fprintf(gbl.dbgfil, "func returns char, through %s\n", SYMNAME(argsym));
1712 MEMARGP(argsym, 1);
1713 ADDRESSP(argsym, 8);
1714 asym = mk_argasym(argsym);
1715 ADDRESSP(asym, ADDRESSG(argsym)); /* propagate ADDRESS */
1716 MEMARGP(asym, 1);
1717 argsym = CLENG(argsym);
1718 if (argsym) {
1719 if (EXPDBG(8, 256))
1720 fprintf(gbl.dbgfil, "func return len in %s\n", SYMNAME(argsym));
1721 MEMARGP(argsym, 1);
1722 ADDRESSP(argsym, 12);
1723 asym = mk_argasym(argsym);
1724 ADDRESSP(asym, ADDRESSG(argsym)); /* propagate ADDRESS */
1725 MEMARGP(asym, 1);
1726 }
1727 pf->mem_off = 16; /* offset for 1st dummy arg */
1728 nargs--;
1729 break;
1730 case TY_CMPLX:
1731 case TY_DCMPLX:
1732 /*
1733 * If this is a function which returns complex, the first arg is
1734 * also for the return value. The last entry in the function's
1735 * dpdsc auxiliary area is the "return" symbol.
1736 */
1737 argsym = convertSPTR(dpdscp[nargs - 1]);
1738 MEMARGP(argsym, 1);
1739 ADDRESSP(argsym, 8);
1740 asym = mk_argasym(argsym);
1741 ADDRESSP(asym, ADDRESSG(argsym)); /* propagate ADDRESS */
1742 MEMARGP(asym, 1);
1743 if (EXPDBG(8, 256))
1744 fprintf(gbl.dbgfil, "func also returns complex, through %s\n",
1745 SYMNAME(argsym));
1746 pf->mem_off = 12; /* offset for 1st dummy arg */
1747 nargs--;
1748 break;
1749 default:
1750 break;
1751 }
1752 scan_args:
1753 /*
1754 * scan through all of the arguments of the function to compute
1755 * how (register or memory area) and where (reg # or offset) the
1756 * arguments area passed. Also, generate the the ili if the argument
1757 * must be copied. If a register argument is not copied, it is recorded
1758 * in the entry's finfo table; if the arg has been copied, a register
1759 * is still "assigned" but it is not recorded (slot is zero).
1760 *
1761 * The only concern for now is arguments which are addresses; the
1762 * exception is the lengths of character args (actually only those
1763 * which are passed length). If compiler is enhanced to allow value
1764 * parameters, presumably there will be some way to distinguish these
1765 * from reference arguments (i.e., a symbol table flag).
1766 */
1767 while (nargs--) {
1768 int osym;
1769 argsym = convertSPTR(*dpdscp++);
1770 osym = argsym;
1771 if (((DTY(DTYPEG(argsym))) == TY_STRUCT) ||
1772 ((DTY(DTYPEG(argsym))) == TY_ARRAY) ||
1773 ((DTY(DTYPEG(argsym))) == TY_UNION))
1774 /* no passbyvalue arrays, structs */
1775 byvalue = 0;
1776 else
1777 byvalue = BYVALDEFAULT(func);
1778
1779 if (PASSBYVALG(argsym))
1780 byvalue = 1;
1781 if (PASSBYREFG(argsym))
1782 byvalue = 0;
1783 if (SCG(argsym) == SC_BASED && MIDNUMG(argsym) && XBIT(57, 0x80000) &&
1784 SCG(MIDNUMG(argsym)) == SC_DUMMY) {
1785 /* char pointers, we put the pointee on the argument
1786 * list so as to get the char length, but we really pass
1787 * the pointer.
1788 * replace by the actual pointer */
1789 argsym = MIDNUMG(argsym);
1790 }
1791 argdtype = DTYPEG(osym);
1792 if (EXPDBG(8, 256))
1793 fprintf(gbl.dbgfil, "%s in mem area at %d\n", SYMNAME(argsym),
1794 pf->mem_off);
1795 if (COPYPRMSG(argsym)) {
1796 cp_memarg(argsym, pf->mem_off, DT_ADDR);
1797 } else if (DTY(argdtype) == TY_STRUCT) {
1798 REFP(MIDNUMG(argsym), 1);
1799 cp_memarg(argsym, pf->mem_off, DT_ADDR);
1800 } else {
1801 MEMARGP(argsym, 1);
1802 ADDRESSP(argsym, pf->mem_off);
1803 asym = mk_argasym(argsym);
1804 ADDRESSP(asym, ADDRESSG(argsym)); /* propagate ADDRESS */
1805 MEMARGP(asym, 1);
1806 }
1807 if (byvalue) {
1808 if (argdtype == DT_DBLE || argdtype == DT_INT8 || argdtype == DT_LOG8 ||
1809 argdtype == DT_CMPLX)
1810 pf->mem_off += 8;
1811 else if (argdtype == DT_DCMPLX)
1812 pf->mem_off += 16;
1813 else if (DTY(argdtype) == TY_STRUCT)
1814 pf->mem_off += size_of(argdtype);
1815 else
1816 pf->mem_off += 4;
1817 } else {
1818 pf->mem_off += 4;
1819 }
1820
1821 /*
1822 * character length.
1823 */
1824 if ((DTYG(argdtype) == TY_CHAR || DTYG(argdtype) == TY_NCHAR) &&
1825 needlen(argsym, func)) {
1826 if (EXPDBG(8, 256))
1827 fprintf(gbl.dbgfil, "%s.len in mem area at %d\n", SYMNAME(argsym),
1828 pf->mem_off);
1829 if (
1830 !AUTOBJG(argsym) &&
1831 (argsym = CLENG(osym))) {
1832 if (COPYPRMSG(argsym))
1833 cp_memarg(argsym, pf->mem_off, expb.charlen_dtype);
1834 else {
1835 MEMARGP(argsym, 1);
1836 ADDRESSP(argsym, pf->mem_off);
1837 asym = mk_argasym(argsym);
1838 ADDRESSP(asym, ADDRESSG(argsym)); /* propagate ADDRESS */
1839 MEMARGP(asym, 1);
1840 }
1841 }
1842 pf->mem_off += 4;
1843 }
1844 if ((!HOMEDG(argsym) && (SCG(argsym) == SC_DUMMY)) &&
1845 (!PASSBYREFG(argsym)) &&
1846 (PASSBYVALG(argsym) ||
1847 (BYVALDEFAULT(func) && ((DTY(DTYPEG(argsym))) != TY_ARRAY)))) {
1848 cp_byval_mem_arg(argsym);
1849 PASSBYVALP(argsym, 1);
1850 }
1851
1852 } /* end while */
1853 }
1854
1855 static int
get_frame_off(INT off)1856 get_frame_off(INT off)
1857 {
1858 int ili;
1859
1860 /* Compute the address of the memory argument by relying on
1861 * a dummy symbol whose address is the first memory argument
1862 * immediately upon entry, i.e., after the return address has been pushed
1863 * on the stack by the call instruction but before any manipulation
1864 * of %rbp by the cg.
1865 * The actual address computation will consist of an ACON whose
1866 * symbol is the dummy symbol and whose offset is relative to
1867 * the dummy symbol.
1868 */
1869 if (memarg_var == 0) {
1870 memarg_var = getccsym('Q', expb.gentmps++, ST_VAR);
1871 SCP(memarg_var, SC_DUMMY);
1872 DTYPEP(memarg_var, DT_CPTR);
1873 REDUCP(memarg_var, 1); /* mark sym --> no further indirection */
1874 HOMEDP(memarg_var, 0);
1875 ADDRTKNP(memarg_var, 1);
1876 }
1877 ili = ad_acon(memarg_var, off - MEMARG_OFFSET);
1878 return ili;
1879 }
1880
1881 /* from exp_c.c */
1882 static void
ldst_size(DTYPE dtype,ILI_OP * ldo,ILI_OP * sto,int * siz)1883 ldst_size(DTYPE dtype, ILI_OP *ldo, ILI_OP *sto, int *siz)
1884 {
1885 *ldo = IL_LD;
1886 *sto = IL_ST;
1887
1888 switch (DTY(dtype)) {
1889 case TY_BINT:
1890 case TY_CHAR:
1891 *siz = MSZ_SBYTE;
1892 break;
1893 case TY_SINT:
1894 case TY_SLOG:
1895 case TY_NCHAR:
1896 *siz = MSZ_SHWORD;
1897 break;
1898 case TY_FLOAT:
1899 case TY_CMPLX:
1900 *siz = MSZ_F4;
1901 *ldo = IL_LDSP;
1902 *sto = IL_STSP;
1903 break;
1904 case TY_INT8:
1905 *siz = MSZ_I8;
1906 *ldo = IL_LDKR;
1907 *sto = IL_STKR;
1908 break;
1909 case TY_QUAD:
1910 case TY_DBLE:
1911 case TY_DCMPLX:
1912 *siz = MSZ_F8;
1913 *ldo = IL_LDDP;
1914 *sto = IL_STDP;
1915 break;
1916 case TY_PTR:
1917 *siz = MSZ_WORD;
1918 *ldo = IL_LDA;
1919 *sto = IL_STA;
1920 break;
1921 case TY_STRUCT:
1922 switch (DTyAlgTySize(dtype)) {
1923 case 1:
1924 *siz = MSZ_BYTE;
1925 break;
1926 case 2:
1927 *siz = MSZ_SHWORD;
1928 break;
1929 case 8:
1930 *siz = MSZ_F8;
1931 break;
1932 case 16:
1933 *siz = MSZ_F16;
1934 break;
1935 case 4:
1936 default:
1937 *siz = MSZ_WORD;
1938 }
1939 break;
1940 case TY_BLOG:
1941 *siz = MSZ_SBYTE;
1942 break;
1943 case TY_INT:
1944 default:
1945 *siz = MSZ_WORD;
1946 }
1947 switch (*siz) {
1948 case MSZ_FWORD:
1949 *ldo = IL_LDSP;
1950 *sto = IL_STSP;
1951 break;
1952 case MSZ_DFLWORD:
1953 *ldo = IL_LDDP;
1954 *sto = IL_STDP;
1955 break;
1956 }
1957 } /* ldst_size */
1958
1959 /***************************************************************/
1960 /* F o r t r a n S t r i n g S u p p o r t */
1961 /***************************************************************/
1962
1963 /* for the character*1 load/store optimization, need a names entry
1964 * for use in the load/store ili which is sufficient for cg to
1965 * correctly schedule the loads/stores when loads/stores of overlaid
1966 * data (MAPs, see tpr 564) are present. NME_UNK is insufficient
1967 * since cg does not always consider NME_UNK to conflict with all
1968 * others. The macro NME_STR1 is used when the optimization occurs;
1969 * it's defined to be the actual nme which is used. 'Precise' nmes
1970 * aren't used since the optimization phases do not expect to see
1971 * Fortran character variables.
1972 */
1973 #define NME_STR1 NME_VOL
1974
1975 /* copy an argument passed by value to it's identically named
1976 compiler created SC_LOCAL
1977 this is used only for args not passed in registers
1978 */
1979 static void
cp_byval_mem_arg(SPTR argsptr)1980 cp_byval_mem_arg(SPTR argsptr)
1981 {
1982 SPTR newsptr;
1983 ILI_OP ldo, sto;
1984 int ms_siz;
1985 int ilix;
1986 int val, val_nme;
1987 int addr, addr_nme;
1988 DTYPE dtype = DTYPEG(argsptr);
1989
1990 ldst_size(dtype, &ldo, &sto, &ms_siz);
1991 newsptr = get_byval_local(argsptr);
1992 HOMEDP(argsptr, 1);
1993 MEMARGP(argsptr, 0);
1994
1995 if (DTY(dtype) != TY_STRUCT) {
1996 if (dtype != DT_CMPLX && dtype != DT_DCMPLX) {
1997 val = ad_acon(argsptr, 0);
1998 val_nme = addnme(NT_VAR, argsptr, 0, 0);
1999 ilix = ad3ili(ldo, val, val_nme, ms_siz);
2000 addr = ad_acon(newsptr, 0);
2001 if (dtype == DT_CHAR || dtype == DT_NCHAR) {
2002 addr_nme = NME_STR1;
2003 } else {
2004 addr_nme = addnme(NT_VAR, newsptr, 0, 0);
2005 }
2006 ilix = ad4ili(sto, ilix, addr, addr_nme, ms_siz);
2007 chk_block(ilix);
2008 } else {
2009 int val_nme2, addr_nme2, sz;
2010 sz = size_of(dtype);
2011 /* copy the real part */
2012 val = ad_acon(argsptr, 0);
2013 val_nme = addnme(NT_VAR, argsptr, 0, 0);
2014 val_nme2 = addnme(NT_MEM, SPTR_NULL, val_nme, 0);
2015 ilix = ad3ili(ldo, val, val_nme2, ms_siz);
2016 addr = ad_acon(newsptr, 0);
2017 addr_nme = addnme(NT_VAR, newsptr, 0, 0);
2018 addr_nme2 = addnme(NT_MEM, SPTR_NULL, addr_nme, 0);
2019 ilix = ad4ili(sto, ilix, addr, addr_nme2, ms_siz);
2020 chk_block(ilix);
2021 val = ad_acon(argsptr, sz / 2);
2022 val_nme2 = addnme(NT_MEM, NOSYM, val_nme, sz / 2);
2023 ilix = ad3ili(ldo, val, val_nme2, ms_siz);
2024 addr = ad_acon(newsptr, sz / 2);
2025 addr_nme2 = addnme(NT_MEM, NOSYM, addr_nme, sz / 2);
2026 ilix = ad4ili(sto, ilix, addr, addr_nme2, ms_siz);
2027 chk_block(ilix);
2028 }
2029 }
2030 if (gbl.internal == 1) {
2031 sym_is_refd(argsptr);
2032 HOMEDP(argsptr, 0);
2033 }
2034 }
2035
2036 /** \brief Copy an argument from the memory area to the local area; this
2037 * routine is only called from pp_params (the arg needs to be copied).
2038 */
2039 static void
cp_memarg(int sym,INT off,int dtype)2040 cp_memarg(int sym, INT off, int dtype)
2041 {
2042 int ili;
2043 int asym;
2044 int msz;
2045
2046 HOMEDP(sym, 1);
2047 MEMARGP(sym, 0);
2048 switch (dtype) {
2049 case DT_INT:
2050 /* TODO: store by value arg into memory */
2051 break;
2052 case DT_INT8:
2053 /* TODO: store by value arg into memory */
2054 break;
2055 case DT_ADDR:
2056 /* TODO: store by value arg into memory */
2057 asym = mk_argasym(sym);
2058 HOMEDP(asym, 1);
2059 MEMARGP(asym, 0);
2060 break;
2061 default:
2062 asym = 0;
2063 interr("unrec dtype in cp_memarg", dtype, ERR_Severe);
2064 break;
2065 }
2066 if (gbl.internal == 1 && asym != 0)
2067 arg_is_refd(asym);
2068 if (EXPDBG(8, 256))
2069 fprintf(gbl.dbgfil, "%s must be copied from MEM+%d\n", SYMNAME(sym), off);
2070 }
2071
2072 /***************************************************************/
2073
2074 int
exp_alloca(ILM * ilmp)2075 exp_alloca(ILM *ilmp)
2076 {
2077 int op1, op2;
2078
2079 alloca_flag = 1;
2080 op1 = ILI_OF(ILM_OPND(ilmp, 1)); /* nelems */
2081 op2 = ILI_OF(ILM_OPND(ilmp, 2)); /* nbytes */
2082 /** sptr = ILM_OPND(ilmp, 3); sym and currently ignored **/
2083 /** tmp = ILM_OPND(ilmp, 4); stc and currently ignored **/
2084 /*
2085 * final size must be a multiple of 16:
2086 * (nelems*nbytes + 15) & ~0xfL
2087 */
2088 op2 = ikmove(op2);
2089 op1 = ad2ili(IL_KMUL, op1, op2);
2090 if (!XBIT(54, 0x10)) {
2091 /** runtime adjusts the size **/
2092 (void)mk_prototype("__builtin_aa", "pure", DT_ADDR, 1, DT_INT8);
2093 } else {
2094 op1 = ad2ili(IL_KADD, op1, ad_kconi(15));
2095 op1 = ad2ili(IL_KAND, op1, ad_kcon(0xffffffff, 0xfffffff0));
2096 }
2097 op2 = ad1ili(IL_NULL, 0);
2098 op2 = ad2ili(IL_ARGKR, op1, op2);
2099 if (!XBIT(54, 0x10))
2100 op1 = ad2ili(IL_JSR, mkfunc("__builtin_aa"), op2);
2101 else
2102 op1 = ad2ili(IL_JSR, mkfunc("__builtin_alloca"), op2);
2103 return ad2ili(IL_DFRAR, op1, AR_RETVAL);
2104 }
2105
2106 /***************************************************************/
2107
2108 static void gen_funcret(finfo_t *);
2109
2110 void
exp_end(ILM * ilmp,int curilm,bool is_func)2111 exp_end(ILM *ilmp, int curilm, bool is_func)
2112 {
2113 int tmp;
2114 int op1;
2115 int i;
2116 int func;
2117 int sym;
2118 finfo_t *pf;
2119 int exit_bih;
2120
2121 if (expb.retlbl != 0) {
2122 exp_label(expb.retlbl);
2123 expb.retlbl = SPTR_NULL;
2124 }
2125 if (allocharhdr) {
2126 /* if character temps were allocated, need to free the
2127 * list of allocated areas created by the run-time.
2128 */
2129 int ld;
2130
2131 /* ftn_str_free(allocharhdr) */
2132 ld = ad_acon(allocharhdr, 0);
2133 ld = ad2ili(IL_LDA, ld, addnme(NT_VAR, allocharhdr, 0, 0));
2134 sym = frte_func(mkfunc, mkRteRtnNm(RTE_str_free));
2135 tmp = ad1ili(IL_NULL, 0);
2136 tmp = ad3ili(IL_ARGAR, ld, tmp, 0);
2137 tmp = ad2ili(IL_JSR, sym, tmp);
2138 iltb.callfg = 1;
2139 chk_block(tmp);
2140 }
2141
2142 exp_restore_mxcsr();
2143
2144 if (is_func) {
2145 SPTR exit_lab;
2146 SPTR next_lab;
2147 int load_retgrp;
2148 int currgrp;
2149
2150 if (retgrp_cnt > 1) {
2151 load_retgrp = ad3ili(IL_LD, ad_acon(retgrp_var, 0),
2152 addnme(NT_VAR, retgrp_var, 0, 0), MSZ_WORD);
2153 exit_lab = getlab();
2154 } else {
2155 exit_lab = SPTR_NULL;
2156 }
2157 /*
2158 * generate test, move, branch for all but the first return
2159 * group.
2160 */
2161 for (currgrp = 1; currgrp < retgrp_cnt; currgrp++) {
2162 /* generate code sequence for a group as follows:
2163 * if (load_retgrp != currgrp) got to next_lab;
2164 * result <--- load currgrp's fval;
2165 * goto exit_lab;
2166 * next_lab:
2167 */
2168 next_lab = getlab();
2169 RFCNTI(next_lab);
2170 tmp = ad4ili(IL_ICJMP, load_retgrp, ad_icon(currgrp), 2, next_lab);
2171 chk_block(tmp);
2172 gen_funcret(&pfinfo[currgrp]);
2173 RFCNTI(exit_lab);
2174 tmp = ad1ili(IL_JMP, exit_lab);
2175 chk_block(tmp);
2176 exp_label(next_lab);
2177 }
2178 /* generate move for last block */
2179 gen_funcret(&pfinfo[0]);
2180 if (exit_lab)
2181 exp_label(exit_lab);
2182 }
2183 if (gbl.arets) {
2184 int addr;
2185 int nme;
2186 int move;
2187
2188 addr = ad_acon(expb.aret_tmp, 0);
2189 nme = addnme(NT_VAR, expb.aret_tmp, 0, 0);
2190 tmp = ad3ili(IL_LD, addr, nme, MSZ_WORD);
2191 move = ad2ili(IL_MVIR, tmp, IR_ARET);
2192 chk_block(move);
2193 }
2194 if (flg.opt >= 1 && expb.curilt != 0) {
2195 flsh_block(); /* at the higher opt levels, the exit */
2196 cr_block(); /* block is a stand-alone block */
2197 }
2198 /* xon/xoff stuff goes here */
2199
2200 /* exit debug stuff goes here */
2201
2202 tmp = ad1ili(IL_EXIT, gbl.currsub);
2203 expb.curilt = addilt(expb.curilt, tmp);
2204 BIH_XT(expb.curbih) = 1;
2205 BIH_LAST(expb.curbih) = 1;
2206 exit_bih = expb.curbih;
2207 wr_block();
2208 BIH_EX(gbl.entbih) = expb.flags.bits.callfg;
2209 BIH_SMOVE(gbl.entbih) = smove_flag;
2210 aux.curr_entry->flags = 0;
2211 if (mscall_flag)
2212 aux.curr_entry->flags |= 0x40000000;
2213 if (alloca_flag)
2214 aux.curr_entry->flags |= 0x80000000;
2215 /*
2216 * scan through all the entries to store return group value if necessary.
2217 */
2218 if (gbl.rutype == RU_PROG)
2219 goto exp_end_ret;
2220 for (func = gbl.entries; func != NOSYM; func = SYMLKG(func)) {
2221 if (EXPDBG(8, 256))
2222 fprintf(gbl.dbgfil, "---exp_end: %s ---\n", SYMNAME(func));
2223 expb.curbih = BIHNUMG(func);
2224 BIH_EX(expb.curbih) = expb.flags.bits.callfg; /* ALL entry bihs */
2225 BIH_SMOVE(expb.curbih) = smove_flag;
2226 if (retgrp_cnt > 1) {
2227 pf = &pfinfo[MIDNUMG(func)];
2228 rdilts(expb.curbih); /* get entry block */
2229 expb.curilt = ILT_PREV(0);
2230 tmp = ad_icon(pf->retgrp);
2231 tmp = ad4ili(IL_ST, tmp, ad_acon(retgrp_var, 0),
2232 addnme(NT_VAR, retgrp_var, 0, 0), MSZ_WORD);
2233 chk_block(tmp);
2234 wrilts(expb.curbih);
2235 }
2236 }
2237 /*
2238 * For multiple entries using the WINNT calling convention, must store
2239 * the number of bytes passed to each entry in a temporary. This store
2240 * must appear in the prologue of each entry -- the code generator will
2241 * load the temporary and use its value to pop the arguments from the
2242 * stack. A sufficient test for generating the store is if the temporary
2243 * was created (saved in aux.curr_entry->ent_save),
2244 */
2245 if (aux.curr_entry->ent_save) {
2246 int addr, nme;
2247 addr = ad_acon(aux.curr_entry->ent_save, 0);
2248 nme = addnme(NT_VAR, aux.curr_entry->ent_save, 0, 0);
2249 for (func = gbl.entries; func != NOSYM; func = SYMLKG(func)) {
2250 expb.curbih = BIHNUMG(func);
2251 rdilts(expb.curbih); /* get entry block */
2252 expb.curilt = ILT_PREV(0);
2253 if (ARGSIZEG(func) < 0)
2254 tmp = ad_icon(0);
2255 else
2256 tmp = ad_icon(ARGSIZEG(func));
2257 if (EXPDBG(8, 256))
2258 fprintf(gbl.dbgfil, "---storing %d in %s ---\n",
2259 CONVAL2G(ILI_OPND(tmp, 1)), SYMNAME(aux.curr_entry->ent_save));
2260 tmp = ad4ili(IL_ST, tmp, addr, nme, MSZ_WORD);
2261 chk_block(tmp);
2262 wrilts(expb.curbih);
2263 }
2264 }
2265
2266 freearea(1); /* duumy arg processing (alloc'd in pp_entries) */
2267
2268 exp_end_ret:
2269 if (allocharhdr) {
2270 /* if character temps were allocated, need to initialize the
2271 * head of a list of allocated areas created by the run-time.
2272 */
2273 int st;
2274
2275 tmp = ad_acon(SPTR_NULL, 0);
2276 st = ad_acon(allocharhdr, 0);
2277 st = ad3ili(IL_STA, tmp, st, addnme(NT_VAR, allocharhdr, 0, 0));
2278 for (func = gbl.entries; func != NOSYM; func = SYMLKG(func)) {
2279 if (EXPDBG(8, 256))
2280 fprintf(gbl.dbgfil, "---init allocharhdr: %s in %s---\n",
2281 SYMNAME(allocharhdr), SYMNAME(func));
2282 expb.curbih = BIH_NEXT(BIHNUMG(func));
2283 rdilts(expb.curbih); /* get block after entry block */
2284 expb.curilt = 0;
2285 /* allocharhdr = NULL; */
2286 chk_block(st);
2287 wrilts(expb.curbih);
2288 }
2289 }
2290
2291 /* emit any mp initialization for the function & its entries */
2292 exp_mp_func_prologue(true);
2293
2294 if (!XBIT(121, 0x01) || /* -Mnoframe isn't specified */
2295 (flg.debug && !XBIT(123, 0x400)) || /* -debug is set */
2296 (flg.profile && XBIT(129, 0x800)) || /* -Minstrument */
2297 XBIT(34, 0x200) || /* -Mconcur */
2298 flg.smp || /* -mp */
2299 alloca_flag || /* alloca present */
2300 (gbl.internal /* contains an internal subprogram or is an
2301 * internal subprogram. */
2302 && !gbl.cudaemu) || /* Don't use a frame pointer when emulating
2303 * CUDA device code. */
2304 gbl.vfrets || /* contains variable format expressions */
2305 /* linux main now aligns the stack - so can't allow -Mnoframe */
2306 (XBIT(119, 0x8000000) && gbl.rutype == RU_PROG) ||
2307 /* -Msmartalloc=huge[:n] */
2308 (XBIT(129, 0x10000000) && gbl.rutype == RU_PROG) ||
2309 aux.curr_entry->ent_save > 0 /* is this a fortran routine with
2310 * multiple entries and mscall */
2311 )
2312 aux.curr_entry->flags |= 0x100; /* bit set ==> must use frame pointer */
2313
2314 /* we can't afford a third global register unless -Mnoframe is allowed */
2315 if (aux.curr_entry->flags & 0x100)
2316 mr_reset_numglobals(1); /* must use frame - reduce nglobals by 1 */
2317 else
2318 mr_reset_numglobals(0); /* -Mnoframe ok */
2319
2320 /* only perform floating-point caching at -O2 or higher */
2321 if (flg.opt < 2 || XBIT(8, 0x400) || XBIT(8, 0x1000) || flg.ieee ||
2322 XBIT(6, 0x100) || XBIT(6, 0x200))
2323 mr_reset_frglobals();
2324
2325 if (DOREG1) { /* assign registers for opt level 1 */
2326 expb.curbih = exit_bih;
2327 reg_assign1();
2328 }
2329 /*
2330 * for opt levels 0 and 1, check if this function is a terminal
2331 * routine.
2332 */
2333 if (flg.opt <= 1)
2334 chk_terminal_func(gbl.entbih, expb.curbih);
2335
2336 /* chk_savears(expb.curbih) needed? */
2337
2338 /* final stuff to cleanup at the end of a function */
2339 expb.arglist = 0;
2340 expb.flags.bits.callfg = 0;
2341 mkrtemp_end();
2342 }
2343
2344 static void
gen_bindC_retval(finfo_t * fp)2345 gen_bindC_retval(finfo_t *fp)
2346 {
2347 const SPTR fval = fp->fval;
2348 const int fvaldtyp = DTY(DTYPEG(fval));
2349 const int retv = ad_acon(fval, 0);
2350 const int nme = addnme(NT_VAR, fval, 0, 0);
2351 int ilix = retv;
2352
2353 if (fp->ret_sm_struct) {
2354 ilix = ad2ili(IL_MVAR, retv, RES_IR(0));
2355 ADDRTKNP(fval, 1);
2356 } else {
2357 switch (IL_RES(ILI_OPC(ilix))) {
2358 case ILIA_AR:
2359 ilix = ad2ili(IL_LDA, ilix, nme);
2360 ilix = ad2ili(IL_MVAR, ilix, RES_IR(0));
2361 break;
2362 case ILIA_IR:
2363 ilix = ad2ili(IL_MVIR, ilix, RES_IR(0));
2364 break;
2365 case ILIA_SP:
2366 if (ILI_OPC(ilix) != IL_LDSP && ILI_OPC(ilix) != IL_FCON) {
2367 const SPTR sfval = fp->fval;
2368 ilix = ad4ili(IL_STSP, ilix, ad_acon(sfval, 0),
2369 addnme(NT_VAR, sfval, 0, 0), MSZ_F4);
2370 chk_block(ilix);
2371 ilix = ad3ili(IL_LDSP, ad_acon(sfval, 0),
2372 addnme(NT_VAR, sfval, 0, 0), MSZ_F4);
2373 }
2374 ilix = ad2ili(IL_MVSP, ilix, RES_XR(0));
2375 break;
2376 case ILIA_DP:
2377 if (ILI_OPC(ilix) != IL_LDDP && ILI_OPC(ilix) != IL_DCON) {
2378 const SPTR sfval = fp->fval;
2379 ilix = ad4ili(IL_STDP, ilix, ad_acon(sfval, 0),
2380 addnme(NT_VAR, sfval, 0, 0), MSZ_F8);
2381 chk_block(ilix);
2382 ilix = ad3ili(IL_LDDP, ad_acon(sfval, 0),
2383 addnme(NT_VAR, sfval, 0, 0), MSZ_F8);
2384 }
2385 if (ILI_OPC(ilix) == IL_LD256) {
2386 ilix = ad2ili(IL_MV256, ilix, RES_XR(0)); /*m256*/
2387 } else if (ILI_OPC(ilix) != IL_LDQ) {
2388 ilix = ad2ili(IL_MVDP, ilix, RES_XR(0));
2389 } else {
2390 ilix = ad2ili(IL_MVQ, ilix, RES_XR(0)); /*m128*/
2391 }
2392 break;
2393 case ILIA_KR:
2394 ilix = ad2ili(IL_MVKR, ilix, RES_IR(0));
2395 break;
2396 default:
2397 interr("expand:illegal return expr", retv, ERR_Severe);
2398 break;
2399 }
2400 }
2401 if (EXPDBG(8, 256))
2402 fprintf(gbl.dbgfil, "gen_retval %d @ %d\n", ilix, gbl.lineno);
2403 /*
2404 * check what is in the current block to see if the block has to be
2405 * written out
2406 */
2407 chk_block(ilix);
2408 }
2409
2410 static void
gen_funcret(finfo_t * fp)2411 gen_funcret(finfo_t *fp)
2412 {
2413 int addr;
2414 int nme;
2415 int ili1, ili2;
2416 int move;
2417 SPTR fval = fp->fval;
2418 int fvaltyp = DTY(DTYPEG(fval));
2419
2420 if (CFUNCG(gbl.currsub) || (CMPLXFUNC_C && TY_ISCMPLX(fvaltyp))) {
2421 gen_bindC_retval(fp);
2422 return;
2423 }
2424 addr = ad_acon(fval, 0);
2425 nme = addnme(NT_VAR, fval, 0, 0);
2426 /*
2427 * if it's possible that fvar has storage SC_DUMMY AND we need
2428 * to generate a load, then we need a LDA:
2429 * if (SCG(fval) == SC_DUMMY)
2430 * addr = ad2ili(IL_LDA, addr, nme);
2431 */
2432 switch (fvaltyp) {
2433 case TY_CHAR:
2434 case TY_NCHAR:
2435 return;
2436 case TY_CMPLX:
2437 case TY_DCMPLX:
2438 if (!CFUNCG(gbl.currsub) && !CMPLXFUNC_C)
2439 return;
2440 move = ad2ili(IL_MVAR, addr, RES_IR(0));
2441 ADDRTKNP(fval, 1);
2442 if (XBIT(121, 0x400)) {
2443 int gret;
2444 gret = ad3ili(IL_RETURN, addr, DTYPEG(fval), nme);
2445 ILI_ALT(move) = gret;
2446 }
2447 break;
2448 case TY_REAL:
2449 ili1 = ad3ili(IL_LDSP, addr, nme, MSZ_F4);
2450 move = ad2ili(IL_MVSP, ili1, FR_RETVAL);
2451 break;
2452 case TY_DBLE:
2453 ili1 = ad3ili(IL_LDDP, addr, nme, MSZ_F8);
2454 move = ad2ili(IL_MVDP, ili1, FR_RETVAL);
2455 break;
2456 case TY_BINT:
2457 case TY_BLOG:
2458 ili1 = ad3ili(IL_LD, addr, nme, MSZ_SBYTE);
2459 move = ad2ili(IL_MVIR, ili1, IR_RETVAL);
2460 break;
2461 case TY_SINT:
2462 case TY_SLOG:
2463 ili1 = ad3ili(IL_LD, addr, nme, MSZ_SHWORD);
2464 move = ad2ili(IL_MVIR, ili1, IR_RETVAL);
2465 break;
2466 case TY_INT:
2467 case TY_LOG:
2468 ili1 = ad3ili(IL_LD, addr, nme, MSZ_WORD);
2469 move = ad2ili(IL_MVIR, ili1, IR_RETVAL);
2470 break;
2471 case TY_INT8:
2472 case TY_LOG8:
2473 ili1 = ad3ili(IL_LDKR, addr, nme, MSZ_I8);
2474 move = ad2ili(IL_MVKR, ili1, KR_RETVAL);
2475 break;
2476 default:
2477 interr("gen_funcret: illegal dtype, sym", fval, ERR_Severe);
2478 return;
2479 }
2480
2481 chk_block(move);
2482 }
2483
2484 /***************************************************************/
2485
2486 static SWEL *sw_array; /**< linear form of the switch list, incl default */
2487 static int sw_temp; /**< acon ili of temp holding value of switch val */
2488 static int sw_val; /**< ili of the original switch value; becomes a load
2489 of a temp if it's necessary to temp store value */
2490 static void genswitch(INT, INT);
2491
2492 /**
2493 \brief expand a computed go to
2494
2495 this processing is similiar to the processing of a switch by pgc. The
2496 exception is that the switch list is already ordered as a table in increasing
2497 order. pgc must first create a table of the switch values.
2498 */
2499 void
exp_cgoto(ILM * ilmp,int curilm)2500 exp_cgoto(ILM *ilmp, int curilm)
2501 {
2502 INT i;
2503 int ilix;
2504 INT n; /* # of cases */
2505 INT cval;
2506
2507 sw_val = ILI_OF(ILM_OPND(ilmp, 1));
2508 sw_temp = 0;
2509 i = ILM_OPND(ilmp, 2); /* index from switch_base locating default */
2510 sw_array = switch_base + i;
2511 n = sw_array[0].val;
2512 #if DEBUG
2513 if (flg.dbg[10] != 0) {
2514 fprintf(gbl.dbgfil,
2515 "\n\n Switch: %-5d line: %-5d n: %-5d default: %-5d\n", curilm,
2516 gbl.lineno, n, sw_array[0].clabel);
2517 for (i = 1; i <= n; i++) {
2518 fprintf(gbl.dbgfil, " %10d %5d~\n", sw_array[i].val,
2519 sw_array[i].clabel);
2520 }
2521 }
2522 #endif
2523 assert(n != 0, "exp_cgoto: cnt is zero, at ilm", curilm, ERR_Severe);
2524 if (ILI_OPC(sw_val) == IL_ICON) {
2525 /*
2526 * switch value is a constant -- search switch list for the equal
2527 * value and generate a jump to that label. If not found, the jump
2528 * to the default will take place
2529 */
2530 cval = CONVAL2G(ILI_OPND(sw_val, 1));
2531 i = 1; /* first in switch list */
2532 do {
2533 if (cval == sw_array[i].val)
2534 chk_block(ad1ili(IL_JMP, sw_array[i].clabel));
2535 else
2536 RFCNTD(sw_array[i].clabel);
2537 } while (++i <= n);
2538 chk_block(ad1ili(IL_JMP, sw_array[0].clabel));
2539 return;
2540 }
2541 genswitch(1, n);
2542 }
2543
2544 /**
2545 \param lb lower bound of switch array
2546 \param ub upper bound of switch array
2547 */
2548 static void
genswitch(INT lb,INT ub)2549 genswitch(INT lb, INT ub)
2550 {
2551 UINT ncases;
2552 UINT range;
2553 int i;
2554
2555 ncases = ub - lb + 1;
2556 range = sw_array[ub].val - sw_array[lb].val + 1;
2557 #if DEBUG
2558 if (flg.dbg[10])
2559 fprintf(gbl.dbgfil, "genswitch: lb: %d, ub: %d\n", lb, ub);
2560 #endif
2561 if (ncases >= 6 && range <= (3 * ncases)) {
2562 /*
2563 * Use a memory table of addresses for the switch. The JMPM
2564 * ili is created which fetches to branch address from a table
2565 * in memory based on the value of the switch expression.
2566 * This value is normalized to 0 (first entry contains the first
2567 * case label)
2568 */
2569 int ilix;
2570 SWEL *swhdr;
2571 /*
2572 * First, locate beginning of the switch list for this range in
2573 * the original area. Also, terminate the last element in the list.
2574 */
2575 swhdr = &sw_array[lb];
2576 sw_array[ub].next = 0;
2577 ilix = ad_icon(range);
2578 /*
2579 * for TARGET_LLVM, pairs of case values and labels are present to
2580 * the llvm switch instruction, we should not be normalizing the
2581 * switch expression to zero.
2582 */
2583 ilix = ad4ili(IL_JMPM, sw_val, ilix,
2584 mk_swtab(range, swhdr, sw_array[0].clabel, 1),
2585 sw_array[0].clabel);
2586 chk_block(ilix);
2587 if (ILT_ILIP(expb.curilt) != ilix) {
2588 /*
2589 * An ILT was not created for the JMPM -- the previous ILT is an
2590 * unconditional branch. go through and decrement all of the
2591 * use counts for the switch labels
2592 */
2593 RFCNTD(sw_array[0].clabel);
2594 for (i = lb; i <= ub; i++)
2595 RFCNTD(sw_array[i].clabel);
2596 wr_block(); /* end this ilt block */
2597 }
2598 } else if (ncases > 4) {
2599 int m, first;
2600 SPTR label;
2601 /*
2602 * perform a binary search of the switch array:
2603 * generate ili of the form
2604 *
2605 * if (sw_val > sw_array[m].val) goto label;
2606 * switch for table[lb .. m]
2607 * label:
2608 * switch for table[m+1 .. ub]
2609 *
2610 * Note that a new block must be created for the switch on the
2611 * upper half of the table; the switch value must be temp stored
2612 * in the current block.
2613 */
2614 RFCNTI(sw_array[0].clabel); /* default label has another use */
2615 m = (lb + ub) / 2;
2616 if (sw_temp == 0) {
2617 int nme;
2618 /*
2619 * need to temp store the switch value in this block, and the
2620 * first use will be a cse of the original value
2621 */
2622 const SPTR sym = mkrtemp_sc(sw_val, expb.sc);
2623 sw_temp = ad_acon(sym, 0);
2624 nme = addnme(NT_VAR, sym, 0, 0);
2625 chk_block(ad4ili(IL_ST, sw_val, sw_temp, nme, MSZ_WORD));
2626 first = ad1ili(IL_CSEIR, sw_val);
2627 sw_val = ad3ili(IL_LD, sw_temp, nme, MSZ_WORD);
2628 } else /* use the load of the temporary containing the switch value */
2629 first = sw_val;
2630 label = getlab();
2631 RFCNTI(label);
2632 chk_block(ad4ili(IL_ICJMP, first, ad_icon(sw_array[m].val), 6, label));
2633 genswitch(lb, m);
2634 exp_label(label);
2635 genswitch(m + 1, ub);
2636 } else {
2637 int first, next, i;
2638 /*
2639 * generate a sequence of "if (sw_val == case value) goto case label"
2640 * followed by a JMP to the default label.
2641 */
2642 if (sw_temp) {
2643 /*
2644 * since the switch value has been temp stored, use the load
2645 * of the temp for all cases.
2646 */
2647 first = next = sw_val;
2648 } else if (ncases > 1 && flg.opt != 1) {
2649 /*
2650 * for this situation, the switch will generate multiple blocks.
2651 * Therefore, in the block evaluating sw_val, a temp store of
2652 * sw_val must occur and in ensuing blocks, the switch expression
2653 * will be fetched from the temporary.
2654 */
2655 int nme;
2656 const SPTR sym = mkrtemp_sc(sw_val, expb.sc);
2657 sw_temp = ad_acon(sym, 0);
2658 nme = addnme(NT_VAR, sym, 0, 0);
2659 chk_block(ad4ili(IL_ST, sw_val, sw_temp, nme, MSZ_WORD));
2660 /*
2661 * The first case occurs in the same block as the store, so just
2662 * use a cse of the original switch value for the first case.
2663 */
2664 first = ad1ili(IL_CSEIR, sw_val);
2665 next = sw_val = ad3ili(IL_LD, sw_temp, nme, MSZ_WORD);
2666 } else {
2667 /*
2668 * Since all of the conditional branches will fit in the current
2669 * block, the first branch uses sw_val and subsequent branches
2670 * will use a cse of sw_val.
2671 */
2672 first = sw_val;
2673 next = ad1ili(IL_CSEIR, sw_val);
2674 }
2675
2676 /* generate first compare */
2677
2678 chk_block(ad4ili(IL_ICJMP, first, ad_icon(sw_array[lb].val), 1,
2679 sw_array[lb].clabel));
2680
2681 /* generate compares for the remaining cases */
2682
2683 for (i = lb + 1; i <= ub; i++) {
2684 chk_block(ad4ili(IL_ICJMP, next, ad_icon(sw_array[i].val), 1,
2685 sw_array[i].clabel));
2686 }
2687
2688 /* generate the default jump */
2689
2690 chk_block(ad1ili(IL_JMP, sw_array[0].clabel));
2691 }
2692 }
2693
2694 static int agotostart;
2695
2696 void
exp_build_agoto(int * tab,int mx)2697 exp_build_agoto(int *tab, int mx)
2698 {
2699 int i;
2700 SWEL *swelp;
2701
2702 if (mx <= 0)
2703 return;
2704 /*
2705 * AGOTOs will be treated like CGOTOs so an extra entry in the
2706 * switch table is needed for te default label.
2707 */
2708 agotostart = getswel(mx + 1);
2709 /*
2710 * switch_base[agotostart].clabel is reserved for the default
2711 */
2712 switch_base[agotostart].val = mx;
2713 switch_base[agotostart].next = agotostart + 1;
2714 swelp = 0; /* quite possible use before def */
2715 for (i = 1; i <= mx; i++) {
2716 swelp = switch_base + (agotostart + i);
2717 swelp->clabel = convertSPTR(tab[i - 1]);
2718 RFCNTI(swelp->clabel);
2719 swelp->val = i;
2720 swelp->next = (agotostart + i + 1);
2721 }
2722 swelp->next = 0;
2723 }
2724
2725 /** \brief Expand a goto
2726 *
2727 * for TARGET_LLVM, we are not performing an indirect branch, so expand
2728 * an assigned goto into a computed goto -- the labels appearing in the
2729 * ASSIGN statements and their respective computed goto index values have
2730 * already been collected into a switch_base table whose starting index
2731 * is agotostart.
2732 */
2733 void
exp_agoto(ILM * ilmp,int curilm)2734 exp_agoto(ILM *ilmp, int curilm)
2735 {
2736 INT i;
2737 INT n; /* # of cases */
2738
2739 sw_val = kimove(ILI_OF(ILM_OPND(ilmp, 2)));
2740 sw_temp = 0;
2741 i = agotostart; /* index from switch_base locating default */
2742 sw_array = switch_base + i;
2743 n = sw_array[0].val;
2744 sw_array[0].clabel = getlab();
2745 RFCNTI(sw_array[0].clabel);
2746 #if DEBUG
2747 if (flg.dbg[10] != 0) {
2748 fprintf(gbl.dbgfil,
2749 "\n\n Switch: %-5d line: %-5d n: %-5d default: %-5d\n", curilm,
2750 gbl.lineno, n, sw_array[0].clabel);
2751 for (i = 1; i <= n; i++) {
2752 fprintf(gbl.dbgfil, " %10d %5d~\n", sw_array[i].val,
2753 sw_array[i].clabel);
2754 }
2755 }
2756 #endif
2757 assert(n != 0, "exp_agoto: cnt is zero, at ilm", curilm, ERR_Severe);
2758 genswitch(1, n);
2759 exp_label(sw_array[0].clabel);
2760 }
2761
2762 /***************************************************************/
2763
2764 /* structure to hold argument list from which argili chain is
2765 * later built.
2766 */
2767 typedef struct {
2768 int ili_type;
2769 int ili_arg;
2770 int dtype; // currently use only for byvalue struct args
2771 } arg_info;
2772
2773 typedef struct {
2774 int ilix;
2775 int dtype;
2776 int val_flag; /* 0 or 1, aka NME_VOL */
2777 int nme;
2778 } garg_info;
2779
2780 static arg_info *arg_ili; /* pointers to argument chain info */
2781 static int arg_entry; /* # of argument entries in call chain */
2782 static int charargs; /* # of character arguments */
2783 static int *len_ili; /* pointers to character length ili */
2784 static garg_info *garg_ili;
2785
2786 /*
2787 * structure to provide communication between exp_call and the
2788 * routines to generate ili for arguments.
2789 */
2790 typedef struct {
2791 int mem_area; /* sym of memory arg area */
2792 int mem_nme; /* nme of memory arg area */
2793 INT mem_off; /* size and next available offset */
2794 int lnk; /* list of define reg ili of args in regs */
2795 char ireg; /* next integer reg to use for args */
2796 char freg; /* next fp register to use for args */
2797 } ainfo_t;
2798
2799 static void from_addr_and_length(STRDESC *s, ainfo_t *ainfo_ptr);
2800 static void arg_ir(int, ainfo_t *);
2801 static void arg_kr(int, ainfo_t *);
2802 static void arg_ar(int, ainfo_t *, int);
2803 static void arg_hp(int, ainfo_t *);
2804 static void arg_sp(int, ainfo_t *);
2805 static void arg_dp(int, ainfo_t *);
2806 static void arg_charlen(int, ainfo_t *);
2807 static void arg_length(STRDESC *, ainfo_t *);
2808
2809 static void
init_ainfo(ainfo_t * ap)2810 init_ainfo(ainfo_t *ap)
2811 {
2812 ap->lnk = ad1ili(IL_NULL, 0);
2813 }
2814
2815 static void
end_ainfo(ainfo_t * ap)2816 end_ainfo(ainfo_t *ap)
2817 {
2818 }
2819 #define end_ainfo(ap) /* NOTHING TO DO */
2820
2821 void
init_arg_ili(int n)2822 init_arg_ili(int n)
2823 {
2824 /* allocate enough space to accomodate the arguments, character lengths
2825 * if they're passed immediately after their arguments, and any function
2826 * return arguments.
2827 */
2828 NEW(arg_ili, arg_info, 2 * n + 3);
2829 charargs = 0;
2830 BZERO(arg_ili, arg_info, 2 * n + 3);
2831 NEW(len_ili, int, n + 1);
2832 arg_entry = 0;
2833 BZERO(len_ili, int, n + 1);
2834 if (XBIT(121, 0x800)) {
2835 /***** %val(complex) => 2 GARG arguments of component type *****/
2836 NEW(garg_ili, garg_info, 2 * n + 1);
2837 BZERO(garg_ili, garg_info, 2 * n + 1);
2838 }
2839 }
2840
2841 void
end_arg_ili(void)2842 end_arg_ili(void)
2843 {
2844 FREE(arg_ili);
2845 FREE(len_ili);
2846 if (XBIT(121, 0x800)) {
2847 FREE(garg_ili);
2848 }
2849 }
2850
2851 static void
add_to_args(int type,int argili)2852 add_to_args(int type, int argili)
2853 {
2854 arg_ili[arg_entry].ili_type = type;
2855 arg_ili[arg_entry].ili_arg = argili;
2856 ++arg_entry;
2857 }
2858
2859 static void
add_struct_byval_to_args(int type,int argili,int dtype)2860 add_struct_byval_to_args(int type, int argili, int dtype)
2861 {
2862 arg_ili[arg_entry].dtype = dtype;
2863 add_to_args(type, argili);
2864 }
2865
2866 /* for 'by-value' arguments */
2867 void
add_arg_ili(int ilix,int nme,int dtype)2868 add_arg_ili(int ilix, int nme, int dtype)
2869 {
2870 switch (IL_RES(ILI_OPC(ilix))) {
2871 case ILIA_IR:
2872 add_to_args(IL_ARGIR, ilix);
2873 break;
2874 case ILIA_KR:
2875 add_to_args(IL_ARGKR, ilix);
2876 break;
2877 case ILIA_SP:
2878 add_to_args(IL_ARGSP, ilix);
2879 break;
2880 case ILIA_DP:
2881 add_to_args(IL_ARGDP, ilix);
2882 break;
2883 case ILIA_AR:
2884 add_to_args(IL_ARGAR, ilix);
2885 break;
2886 case ILIA_CS:
2887 add_to_args(IL_ARGSP, ilix);
2888 break;
2889 case ILIA_CD:
2890 add_to_args(IL_ARGDP, ilix);
2891 break;
2892
2893 default:
2894 interr("exp_call:bad ili for BYVAL", ilix, ERR_Severe);
2895 }
2896 } /* add_arg_ili */
2897
2898 static void
put_arg_ili(int i,ainfo_t * ainfo)2899 put_arg_ili(int i, ainfo_t *ainfo)
2900 {
2901
2902 switch (arg_ili[i].ili_type) {
2903 case IL_ARGIR:
2904 arg_ir(arg_ili[i].ili_arg, ainfo);
2905 break;
2906 case IL_ARGKR:
2907 arg_kr(arg_ili[i].ili_arg, ainfo);
2908 break;
2909 case IL_ARGAR:
2910 arg_ar(arg_ili[i].ili_arg, ainfo, arg_ili[i].dtype);
2911 break;
2912 case IL_ARGSP:
2913 arg_sp(arg_ili[i].ili_arg, ainfo);
2914 break;
2915 case IL_ARGDP:
2916 arg_dp(arg_ili[i].ili_arg, ainfo);
2917 break;
2918 default:
2919 interr("exp_call: ili arg type not cased", arg_ili[i].ili_arg, ERR_Severe);
2920 break;
2921 }
2922 }
2923
2924 static void
process_desc_args(ainfo_t * ainfo)2925 process_desc_args(ainfo_t *ainfo)
2926 {
2927 int i;
2928 for (i = arg_entry - 1; i >= 0; --i) {
2929 int ili = arg_ili[i].ili_arg;
2930 if (is_proc_desc_arg(ili)) {
2931 put_arg_ili(i, ainfo);
2932 }
2933 }
2934 }
2935
2936 int
gen_arg_ili(void)2937 gen_arg_ili(void)
2938 {
2939 ainfo_t ainfo;
2940 int i;
2941
2942 init_ainfo(&ainfo);
2943
2944 if (charargs > 0 && !HAS_OPT_ARGSG(exp_call_sym))
2945 process_desc_args(&ainfo);
2946
2947 /* go through the list of character length ili which have been
2948 * saved up and add them as arguments to the call.
2949 */
2950 for (i = charargs - 1; i >= 0; --i) {
2951 arg_charlen(len_ili[i], &ainfo);
2952 }
2953
2954 /* now go through the list of all stored arguments and add them
2955 * to the argument chain for this call
2956 */
2957 for (i = arg_entry - 1; i >= 0; --i) {
2958 int ili = arg_ili[i].ili_arg;
2959 if (charargs > 0 && !HAS_OPT_ARGSG(exp_call_sym) && is_proc_desc_arg(ili))
2960 continue;
2961 put_arg_ili(i, &ainfo);
2962 }
2963
2964 end_ainfo(&ainfo);
2965 return ainfo.lnk;
2966 } /* gen_arg_ili */
2967
2968 static void
pass_char_arg(int type,int argili,int lenili)2969 pass_char_arg(int type, int argili, int lenili)
2970 {
2971 int len_opc;
2972
2973 len_opc = IL_ARGKR;
2974 add_to_args(type, argili);
2975
2976 if (!XBIT(125, 0x40000)) {
2977 if (IL_RES(ILI_OPC(lenili)) != ILIA_KR) {
2978 lenili = ad1ili(IL_IKMV, lenili);
2979 }
2980 } else
2981 len_opc = IL_ARGIR;
2982
2983 if ((MSCALLG(exp_call_sym) || CREFG(exp_call_sym)) &&
2984 !NOMIXEDSTRLENG(exp_call_sym))
2985 add_to_args(len_opc, lenili);
2986 else
2987 len_ili[charargs++] = lenili;
2988 }
2989
2990 #define IILM_OPC(i) ilmb.ilm_base[i]
2991 #define IILM_OPND(i, j) ilmb.ilm_base[i + j]
2992 #define FUNCPTR_BINDC 0x1
2993 #ifdef __cplusplus
IILM_DTyOPND(int i,int j)2994 inline DTYPE IILM_DTyOPND(int i, int j) {
2995 return static_cast<DTYPE>(IILM_OPND(i, j));
2996 }
2997 #else
2998 #define IILM_DTyOPND IILM_OPND
2999 #endif
3000
3001 /* Returns the sptr for the tmp representing the SFUNC's return */
3002 static int
struct_ret_tmp(int ilmx)3003 struct_ret_tmp(int ilmx)
3004 {
3005 ILM *ilmpx;
3006 int ilmxt;
3007
3008 ilmpx = (ILM *)(ilmb.ilm_base + ilmx);
3009
3010 assert(ILM_OPC(ilmpx) == IM_LOC || ILM_OPC(ilmpx) == IM_FARG ||
3011 ILM_OPC(ilmpx) == IM_FARGF,
3012 "struct_ret_tmp bad SFUNC", ilmx, ERR_Severe);
3013 ilmxt = ILM_OPND(ilmpx, 1);
3014 ilmpx = (ILM *)(ilmb.ilm_base + ilmxt);
3015 assert(ILM_OPC(ilmpx) == IM_BASE, "struct_ret_tmp bad SFUNC not base", ilmx,
3016 ERR_Severe);
3017 return ILM_OPND(ilmpx, 1); /* get sptr of temp */
3018 }
3019
3020 static int
check_cstruct_return(DTYPE retdtype)3021 check_cstruct_return(DTYPE retdtype)
3022 {
3023 int size;
3024 if (DTY(retdtype) == TY_STRUCT) {
3025 size = size_of(retdtype);
3026 if (size <= MAX_PASS_STRUCT_SIZE)
3027 return 1;
3028 return 0;
3029 }
3030 return 1;
3031 }
3032
3033 static void
cmplx_to_mem(int real,int imag,DTYPE dtype,int * addr,int * nme)3034 cmplx_to_mem(int real, int imag, DTYPE dtype, int *addr, int *nme)
3035 {
3036 int load;
3037 ILI_OP store;
3038 int size, msz;
3039 int r_op1, i_op1, i_op2;
3040 SPTR tmp;
3041
3042 assert(DT_ISCMPLX(dtype), "cmplx_to_mem: not complex dtype", dtype,
3043 ERR_Severe);
3044 if (DTY(dtype) == TY_CMPLX) {
3045 if (XBIT(70, 0x40000000) && !imag) {
3046 load = IL_LDSCMPLX;
3047 store = IL_STSCMPLX;
3048 msz = MSZ_F8;
3049 } else {
3050 load = IL_LDSP;
3051 store = IL_STSP;
3052 msz = MSZ_F4;
3053 }
3054 } else {
3055 if (XBIT(70, 0x40000000) && !imag) {
3056 load = IL_LDDCMPLX;
3057 store = IL_STDCMPLX;
3058 msz = MSZ_F16;
3059 } else {
3060 load = IL_LDDP;
3061 store = IL_STDP;
3062 msz = MSZ_F8;
3063 }
3064 }
3065 if (!XBIT(70, 0x40000000)) {
3066 size = size_of(dtype) / 2;
3067 } else {
3068 if (!imag)
3069 size = size_of(dtype);
3070 else
3071 size = size_of(dtype) / 2;
3072 if (ILI_OPC(real) == load) {
3073 r_op1 = ILI_OPND(real, 1);
3074 if (ILI_OPC(r_op1) == IL_ACON) {
3075 *addr = ILI_OPND(real, 1);
3076 *nme = ILI_OPND(real, 2);
3077 return;
3078 }
3079 }
3080 }
3081
3082 if (ILI_OPC(real) == load && ILI_OPC(imag) == load) {
3083 /* Direct load? */
3084 r_op1 = ILI_OPND(real, 1);
3085 i_op1 = ILI_OPND(imag, 1);
3086 if (ILI_OPC(r_op1) == IL_ACON && ILI_OPC(i_op1) == IL_ACON) {
3087 r_op1 = ILI_OPND(r_op1, 1);
3088 i_op1 = ILI_OPND(i_op1, 1);
3089 if (CONVAL1G(r_op1) == CONVAL1G(i_op1) &&
3090 ACONOFFG(r_op1) + size == ACONOFFG(i_op1)) {
3091 *addr = ILI_OPND(real, 1);
3092 *nme = NME_NM(ILI_OPND(real, 2));
3093 return;
3094 }
3095 }
3096
3097 /* Indirect load? */
3098 r_op1 = ILI_OPND(real, 1);
3099 i_op1 = ILI_OPND(imag, 1);
3100 if (ILI_OPC(i_op1) == IL_AADD) {
3101 i_op2 = ILI_OPND(i_op1, 2);
3102 i_op1 = ILI_OPND(i_op1, 1);
3103 if (i_op1 == r_op1 && ILI_OPC(i_op2) == IL_ACON &&
3104 CONVAL1G(ILI_OPND(i_op2, 1)) == 0 &&
3105 ACONOFFG(ILI_OPND(i_op2, 1)) == size) {
3106 *addr = r_op1;
3107 *nme = NME_NM(ILI_OPND(real, 2));
3108 return;
3109 }
3110 /*
3111 * TBD - can do better to detect subscripted references:
3112 */
3113 }
3114 }
3115 tmp = mkrtemp_cpx_sc(dtype, expb.sc);
3116 *addr = ad_acon(tmp, 0);
3117 *nme = addnme(NT_VAR, tmp, 0, 0);
3118 loc_of(*nme);
3119 if (XBIT(70, 0x40000000) && !imag) {
3120 if (dtype == DT_CMPLX)
3121 chk_block(ad4ili(IL_STSCMPLX, real, *addr, *nme, msz));
3122 else
3123 chk_block(ad4ili(IL_STDCMPLX, real, *addr, *nme, msz));
3124 } else {
3125 chk_block(ad4ili(store, real, *addr, addnme(NT_MEM, SPTR_NULL, *nme, 0), msz));
3126 chk_block(ad4ili(store, imag,
3127 ad3ili(IL_AADD, *addr, ad_aconi(size), 0),
3128 addnme(NT_MEM, NOSYM, *nme, size), msz));
3129 }
3130 }
3131
3132 /**
3133 * \brief get the chain pointer argument from a descriptor.
3134 *
3135 * \param arglnk is a chain of argument ILI for a call-site.
3136 *
3137 * \param sdsc is the descriptor that has the chain pointer.
3138 *
3139 * \return an IL_LDA ili chain that contains the ILI that loads the chain
3140 * pointer from the descriptor.
3141 */
3142 static int
get_chain_pointer_closure(SPTR sdsc)3143 get_chain_pointer_closure(SPTR sdsc)
3144 {
3145 int nme, cp, cp_offset;
3146
3147 if (XBIT(68, 0x1)) {
3148 cp_offset = 72;
3149 } else {
3150 cp_offset = 40;
3151 }
3152 nme = addnme(NT_VAR, sdsc, 0, 0);
3153 if (SCG(sdsc) != SC_DUMMY) {
3154 if (PARREFG(sdsc)) {
3155 /**
3156 * In LLVM, pointer descriptor is not visible in the outlined func.
3157 * Use mk_address() which fetches the uplevel ref
3158 */
3159 int addr = mk_address(sdsc);
3160 int ili = ad2ili(IL_LDA, addr, nme);
3161 cp = ad3ili(IL_AADD, ili, ad_aconi(cp_offset), 0);
3162 } else {
3163 cp = ad_acon(sdsc, cp_offset);
3164 cp = ad2ili(IL_LDA, cp, nme);
3165 }
3166 } else {
3167 SPTR asym = mk_argasym(sdsc);
3168 int addr = mk_address(sdsc);
3169 int ili = ad2ili(IL_LDA, addr, addnme(NT_VAR, asym, 0, 0));
3170 cp = ad3ili(IL_AADD, ili, ad_aconi(cp_offset), 0);
3171 if (!INTERNREFG(sdsc) && !PARREFG(sdsc))
3172 cp = ad2ili(IL_LDA, cp, nme);
3173 }
3174
3175 return cp;
3176 }
3177
3178 static int
add_last_arg(int arglnk,int displnk)3179 add_last_arg(int arglnk, int displnk)
3180 {
3181 int i;
3182
3183 if (ILI_OPC(arglnk) == IL_NULL)
3184 return displnk;
3185
3186 for (i = arglnk; i > 0 && ILI_OPC(ILI_OPND(i, 2)) != IL_NULL;
3187 i = ILI_OPND(i, 2)) {
3188 // do nothing
3189 }
3190
3191 ILI_OPND(i, 2) = displnk;
3192 return arglnk;
3193 }
3194
3195 static int
add_arglnk_closure(SPTR sdsc)3196 add_arglnk_closure(SPTR sdsc)
3197 {
3198 int i;
3199
3200 i = get_chain_pointer_closure(sdsc);
3201 i = ad3ili(IL_ARGAR, i, ad1ili(IL_NULL, 0), ad1ili(IL_NULL, 0));
3202 return i;
3203 }
3204
3205 static int
add_gargl_closure(SPTR sdsc)3206 add_gargl_closure(SPTR sdsc)
3207 {
3208 int i;
3209
3210 i = get_chain_pointer_closure(sdsc);
3211 i = ad4ili(IL_GARG, i, ad1ili(IL_NULL, 0), DT_ADDR, NME_VOL);
3212 return i;
3213 }
3214
3215 static bool
is_asn_closure_call(int sptr)3216 is_asn_closure_call(int sptr)
3217 {
3218 if (sptr > NOSYM && STYPEG(sptr) == ST_PROC && CCSYMG(sptr) &&
3219 strcmp(SYMNAME(sptr), mkRteRtnNm(RTE_asn_closure)) == 0) {
3220 return true;
3221 }
3222 return false;
3223 }
3224
3225 static bool
is_proc_desc_arg(int ili)3226 is_proc_desc_arg(int ili)
3227 {
3228 SPTR sym;
3229 if (ILI_OPC(ili) == IL_ACON) {
3230 sym = SymConval1(ILI_SymOPND(ili, 1));
3231 } else if (IL_TYPE(ILI_OPC(ili)) == ILTY_LOAD) {
3232 int op1 = ILI_OPND(ili,1);
3233 if (ILI_OPC(op1) == IL_ACON) {
3234 sym = SymConval1(ILI_SymOPND(op1, 1));
3235 } else {
3236 sym = NME_SYM(ILI_OPND(ili,2));
3237 }
3238 } else {
3239 sym = SPTR_NULL;
3240 }
3241 if (sym > NOSYM && IS_PROC_DESCRG(sym)) {
3242 return true;
3243 }
3244 return false;
3245 }
3246
3247 void
exp_call(ILM_OP opc,ILM * ilmp,int curilm)3248 exp_call(ILM_OP opc, ILM *ilmp, int curilm)
3249 {
3250 int nargs; /* # args */
3251 int ililnk; /* ili link */
3252 int argili; /* ili for arg */
3253 int argili2; /* ili for arg */
3254 int gargili; /* ili for arg */
3255 int ilix; /* ili pointer */
3256 ILM *ilmlnk; /* current ILM operand */
3257 int ilm1;
3258 SPTR sym; /* symbol pointers */
3259 INT skip; /* distance to imag part of a complex */
3260 int basenm; /* base nm entry */
3261 int i; /* temps */
3262 STRDESC *str1;
3263 int argopc;
3264 int cfunc;
3265 int cfunc_nme;
3266 DTYPE dtype;
3267 int val_flag;
3268 int arglnk;
3269 int retval;
3270 int func_addr;
3271 int vtoff;
3272 int descno = 0;
3273 int gargl, gi, gjsr, ngargs, garg_disp;
3274 int gfch_addr, gfch_len; /* character function return */
3275 int jsra_mscall_flag;
3276 int funcptr_flags;
3277 int retdesc;
3278 int struct_tmp;
3279 int chain_pointer_arg = 0;
3280
3281 nargs = ILM_OPND(ilmp, 1); /* # args */
3282 func_addr = 0;
3283 funcptr_flags = 0;
3284 switch (opc) {
3285 case IM_CALL:
3286 exp_call_sym = ILM_SymOPND(ilmp, 2); /* external reference */
3287 /* Q&D for the absence of prototypes/signatures for our run-time
3288 * routines. -- 9/19/14, do it for user functions too!
3289 */
3290 DTYPEP(exp_call_sym, DT_NONE);
3291 break;
3292 case IM_CHFUNC:
3293 case IM_NCHFUNC:
3294 case IM_KFUNC:
3295 case IM_LFUNC:
3296 case IM_IFUNC:
3297 case IM_RFUNC:
3298 case IM_DFUNC:
3299 case IM_CFUNC:
3300 case IM_CDFUNC:
3301 case IM_PFUNC:
3302 case IM_SFUNC:
3303 exp_call_sym = ILM_SymOPND(ilmp, 2); /* external reference */
3304 break;
3305 case IM_CALLA:
3306 case IM_PCALLA:
3307 case IM_CHFUNCA:
3308 case IM_PCHFUNCA:
3309 case IM_NCHFUNCA:
3310 case IM_PNCHFUNCA:
3311 case IM_KFUNCA:
3312 case IM_PKFUNCA:
3313 case IM_LFUNCA:
3314 case IM_PLFUNCA:
3315 case IM_IFUNCA:
3316 case IM_PIFUNCA:
3317 case IM_RFUNCA:
3318 case IM_PRFUNCA:
3319 case IM_DFUNCA:
3320 case IM_PDFUNCA:
3321 case IM_CFUNCA:
3322 case IM_PCFUNCA:
3323 case IM_CDFUNCA:
3324 case IM_PCDFUNCA:
3325 case IM_PFUNCA:
3326 case IM_PPFUNCA:
3327 funcptr_flags = ILM_OPND(ilmp, 2);
3328 exp_call_sym = SPTR_NULL; /* via procedure ptr */
3329 if (!IS_INTERNAL_PROC_CALL(opc)) {
3330 ilm1 = ILM_OPND(ilmp, 3);
3331 } else {
3332 ilm1 = ILM_OPND(ilmp, 4);
3333 descno = ILM_OPND(ilmp, 3);
3334 }
3335 func_addr = ILI_OF(ilm1);
3336 ilmlnk = (ILM *)(ilmb.ilm_base + ilm1);
3337 switch (ILM_OPC(ilmlnk)) {
3338 case IM_PLD:
3339 exp_call_sym = ILM_SymOPND(ilmlnk, 2);
3340 break;
3341 case IM_BASE:
3342 exp_call_sym = ILM_SymOPND(ilmlnk, 1);
3343 break;
3344 case IM_MEMBER:
3345 exp_call_sym = ILM_SymOPND(ilmlnk, 2);
3346 break;
3347 default:
3348 interr("exp_call: Procedure pointer not found", ilm1, ERR_unused);
3349 break;
3350 }
3351 break;
3352 case IM_VCALLA:
3353 descno = 5;
3354 goto vcalla_common;
3355 case IM_CHVFUNCA:
3356 descno = 5;
3357 goto vcalla_common;
3358 case IM_NCHVFUNCA:
3359 descno = 5;
3360 goto vcalla_common;
3361 case IM_KVFUNCA:
3362 descno = 5;
3363 goto vcalla_common;
3364 case IM_LVFUNCA:
3365 descno = 5;
3366 goto vcalla_common;
3367 case IM_IVFUNCA:
3368 descno = 5;
3369 goto vcalla_common;
3370 case IM_RVFUNCA:
3371 descno = 5;
3372 goto vcalla_common;
3373 case IM_DVFUNCA:
3374 descno = 5;
3375 goto vcalla_common;
3376 case IM_CVFUNCA:
3377 descno = 5;
3378 goto vcalla_common;
3379 case IM_CDVFUNCA:
3380 descno = 5;
3381 goto vcalla_common;
3382 case IM_PVFUNCA:
3383 descno = 5;
3384 vcalla_common:
3385 exp_call_sym = SPTR_NULL; /* via type bound proc */
3386 descno = ILM_OPND(ilmp, descno);
3387 ilm1 = ILM_OPND(ilmp, 3);
3388 /* external reference */
3389 exp_call_sym = ILM_SymOPND(ilmp, 3);
3390 vtoff = VTOFFG(TBPLNKG(exp_call_sym));
3391 if (VTABLEG(exp_call_sym))
3392 exp_call_sym = VTABLEG(exp_call_sym);
3393 else if (IFACEG(exp_call_sym))
3394 exp_call_sym = IFACEG(exp_call_sym);
3395 break;
3396 default:
3397 exp_call_sym = ILM_SymOPND(ilmp, 2); /* external reference */
3398 interr("exp_call: Bad Function opc", opc, ERR_Severe);
3399 }
3400
3401 init_arg_ili(nargs);
3402
3403 if (opc == IM_LFUNC && nargs == 1) {
3404 if (CCSYMG(exp_call_sym) &&
3405 strcmp(SYMNAME(exp_call_sym), mkRteRtnNm(RTE_present)) == 0) {
3406 int opc1;
3407 /* F90 PRESENT() call; is this a missing optional argument? */
3408 ilm1 = ILM_OPND(ilmp, 3);
3409 opc1 = ILM_OPC((ILM *)(ilmb.ilm_base + ilm1));
3410 if (opc1 == IM_BASE) {
3411 if (optional_missing(NME_OF(ilm1))) {
3412 /* treat like zero */
3413 replace_by_zero(opc, ilmp, curilm);
3414 return;
3415 } else if (optional_present(NME_OF(ilm1))) {
3416 /* treat like one */
3417 replace_by_one(opc, ilmp, curilm);
3418 return;
3419 }
3420 } else if (IM_TYPE(opc1) == IMTY_CONS) {
3421 /* inlined optional argument, constant actual argument */
3422 /* treat like zero */
3423 replace_by_one(opc, ilmp, curilm);
3424 return;
3425 }
3426 }
3427 }
3428
3429 gfch_addr = 0;
3430 switch (opc) {
3431 case IM_CHFUNC:
3432 case IM_NCHFUNC:
3433 case IM_CHFUNCA:
3434 case IM_NCHFUNCA:
3435 case IM_PCHFUNCA:
3436 case IM_PNCHFUNCA:
3437 /*
3438 * for a function returning character, the first 2 arguments
3439 * are the address of a char temporary created by the semantic
3440 * analyzer and its length, respectively.
3441 */
3442
3443 if ((opc == IM_CHFUNC) || (opc == IM_NCHFUNC)) {
3444 ilm1 = ILM_OPND(ilmp, 3);
3445 } else if (opc == IM_PCHFUNCA || opc == IM_PNCHFUNCA) {
3446 ilm1 = ILM_OPND(ilmp, 5);
3447 } else {
3448 ilm1 = ILM_OPND(ilmp, 4);
3449 }
3450 if (IILM_OPC(ilm1) == IM_FARG)
3451 ilm1 = IILM_OPND(ilm1, 1);
3452 else if (IILM_OPC(ilm1) == IM_FARGF)
3453 ilm1 = IILM_OPND(ilm1, 1);
3454 gfch_addr = ILM_RESULT(ilm1);
3455 gfch_len = ILM_CLEN(ilm1);
3456 add_to_args(IL_ARGAR, gfch_addr);
3457
3458 /* always add the character function length to the argument list:
3459 do not modify this with STDCALL, REFERENCE, VALUE
3460 the information required to do this has been lost at this
3461 call point : the sptr is different . We don't have
3462 FVALG() or the parameter list
3463 */
3464 if (CHARLEN_64BIT) {
3465 gfch_len = sel_iconv(gfch_len, 1);
3466 add_to_args(IL_ARGKR, gfch_len);
3467 } else {
3468 add_to_args(IL_ARGIR, gfch_len);
3469 }
3470 if ((opc == IM_CHFUNC) || (opc == IM_NCHFUNC)) {
3471 i = 4; /* ilm pointer to first arg */
3472 } else {
3473 i = 5; /* ilm pointer to first arg */
3474 }
3475 break;
3476 case IM_CFUNC:
3477 case IM_CDFUNC:
3478 i = 3;
3479 goto share_cfunc;
3480 case IM_PCFUNCA:
3481 case IM_PCDFUNCA:
3482 i = 5;
3483 goto share_cfunc;
3484 case IM_CFUNCA:
3485 case IM_CDFUNCA:
3486 i = 4;
3487 share_cfunc:
3488 ilm1 = ILM_OPND(ilmp, i);
3489 dtype = IILM_DTyOPND(ilm1, 2);
3490 if (IILM_OPC(ilm1) == IM_FARG || IILM_OPC(ilm1) == IM_FARGF)
3491 ilm1 = IILM_OPND(ilm1, 1);
3492 cfunc = ILM_RESULT(ilm1);
3493 cfunc_nme = NME_OF(ilm1);
3494 if (CFUNCG(exp_call_sym) || (funcptr_flags & FUNCPTR_BINDC) ||
3495 CMPLXFUNC_C) {
3496 ADDRTKNP(IILM_OPND(ilm1, 1), 1);
3497 if (opc == IM_CFUNCA || opc == IM_CDFUNCA) {
3498 ilm1 = ILM_OPND(ilmp, i);
3499 } else {
3500 ilm1 = ILM_OPND(ilmp, (i + 2));
3501 }
3502 if (XBIT(121, 0x800)) {
3503 garg_ili[0].ilix = cfunc;
3504 garg_ili[0].dtype = dtype;
3505 garg_ili[0].nme = cfunc_nme;
3506 }
3507 nargs--;
3508 i++;
3509 }
3510 break;
3511 case IM_CHVFUNCA:
3512 case IM_NCHVFUNCA:
3513 /*
3514 * for a function returning character, the first 2 arguments
3515 * are the address of a char temporary created by the semantic
3516 * analyzer and its length, respectively.
3517 */
3518
3519 ilm1 = ILM_OPND(ilmp, 6);
3520 if (IILM_OPC(ilm1) == IM_FARG)
3521 ilm1 = IILM_OPND(ilm1, 1);
3522 else if (IILM_OPC(ilm1) == IM_FARGF)
3523 ilm1 = IILM_OPND(ilm1, 1);
3524 gfch_addr = ILM_RESULT(ilm1);
3525 gfch_len = ILM_CLEN(ilm1);
3526 add_to_args(IL_ARGAR, ILM_RESULT(ilm1));
3527
3528 /* always add the character function length to the argument list:
3529 do not modify this with STDCALL, REFERENCE, VALUE
3530 the information required to do this has been lost at this
3531 call point : the sptr is different . We don't have
3532 FVALG() or the parameter list
3533 */
3534 if (CHARLEN_64BIT) {
3535 gfch_len = sel_iconv(gfch_len, 1);
3536 add_to_args(IL_ARGKR, gfch_len);
3537 } else {
3538 add_to_args(IL_ARGIR, ILM_CLEN(ilm1));
3539 }
3540 i = 7; /* ilm pointer to first arg */
3541 break;
3542 case IM_CVFUNCA:
3543 case IM_CDVFUNCA:
3544 ilm1 = ILM_OPND(ilmp, 6);
3545 if (IILM_OPC(ilm1) == IM_FARG)
3546 ilm1 = IILM_OPND(ilm1, 1);
3547 else if (IILM_OPC(ilm1) == IM_FARGF)
3548 ilm1 = IILM_OPND(ilm1, 1);
3549 cfunc = ILM_RESULT(ilm1);
3550 cfunc_nme = NME_OF(ilm1);
3551 i = 6; /* ilm pointer to first arg */
3552 if (CMPLXFUNC_C)
3553 goto share_cfunc;
3554 break;
3555 case IM_VCALLA:
3556 case IM_KVFUNCA:
3557 case IM_LVFUNCA:
3558 case IM_IVFUNCA:
3559 case IM_RVFUNCA:
3560 case IM_DVFUNCA:
3561 case IM_PVFUNCA:
3562 i = 6;
3563 break;
3564 case IM_SFUNC:
3565 /* eventually, delete retdesc; XBIT(121,0x800) is the default and there
3566 * is always a return temp.
3567 */
3568 retdesc = check_cstruct_return(DTYPEG(exp_call_sym));
3569 struct_tmp = struct_ret_tmp(ILM_OPND(ilmp, 3));
3570 ilm1 = ILM_OPND(ilmp, 3);
3571 if (IILM_OPC(ilm1) == IM_FARG || IILM_OPC(ilm1) == IM_FARGF)
3572 ilm1 = IILM_OPND(ilm1, 1);
3573 cfunc = ILM_RESULT(ilm1);
3574 cfunc_nme = NME_OF(ilm1);
3575 nargs--;
3576 i = 4;
3577 if (XBIT(121, 0x800)) {
3578 add_struct_byval_to_args(IL_ARGAR, cfunc, DTYPEG(struct_tmp));
3579 garg_ili[0].ilix = cfunc;
3580 garg_ili[0].dtype = DTYPEG(struct_tmp);
3581 garg_ili[0].nme = cfunc_nme;
3582 }
3583 ilm1 = ILM_OPND(ilmp, i);
3584 break;
3585
3586 case IM_IFUNCA:
3587 case IM_RFUNCA:
3588 case IM_DFUNCA:
3589 case IM_QFUNCA:
3590 case IM_M256FUNCA:
3591 case IM_M256VFUNCA:
3592 case IM_LFUNCA:
3593 case IM_PFUNCA:
3594 case IM_KFUNCA:
3595 case IM_CALLA:
3596 i = 4; /* ilm pointer to first arg */
3597 break;
3598 case IM_PCALLA:
3599 case IM_PIFUNCA:
3600 case IM_PRFUNCA:
3601 case IM_PDFUNCA:
3602 case IM_PLFUNCA:
3603 case IM_PPFUNCA:
3604 case IM_PKFUNCA:
3605 descno = ILM_OPND(ilmp, 3);
3606 i = 5;
3607 break; /* ilm pointer to first arg */
3608 default:
3609 i = 3; /* ilm pointer to first arg */
3610 break;
3611 }
3612
3613 ngargs = 0;
3614 if (XBIT(121, 0x800)) {
3615 ngargs = nargs;
3616 }
3617 gi = 1;
3618 while (nargs--) {
3619 bool pass_len = true;
3620 ilm1 = ILM_OPND(ilmp, i);
3621 dtype = DT_ADDR;
3622 val_flag = 0;
3623 if (IILM_OPC(ilm1) == IM_FARG) {
3624 dtype = IILM_DTyOPND(ilm1, 2);
3625 ilm1 = IILM_OPND(ilm1, 1);
3626 } else if (IILM_OPC(ilm1) == IM_FARGF) {
3627 dtype = IILM_DTyOPND(ilm1, 2);
3628 if (IILM_OPND(ilm1, 3) & 0x1) {
3629 /* corresponding formal is a CLASS(*) */
3630 pass_len = false;
3631 }
3632 ilm1 = IILM_OPND(ilm1, 1);
3633 }
3634 gargili = ILM_RESULT(ilm1);
3635 ilmlnk = (ILM *)(ilmb.ilm_base + ilm1);
3636 /* ilmlnk is ith argument */
3637 switch (argopc = ILM_OPC(ilmlnk)) {
3638 case IM_PARG:
3639 /* special ILM for passing an object with the pointer attribute.
3640 * need to pass the address of the object's pointer variable
3641 * and a character length if the scalar/element type is character.
3642 */
3643 ilm1 = ILM_OPND(ilmlnk, 1); /* locate address of object's pointer */
3644 loc_of(NME_OF(ilm1));
3645 argili = ILI_OF(ilm1);
3646 ilm1 = ILM_OPND(ilmlnk, 2); /* BASE ILM of the object */
3647 if (ILM_RESTYPE(ilm1) != ILM_ISCHAR || !pass_len) {
3648 add_to_args(IL_ARGAR, argili);
3649 } else {
3650 pass_char_arg(IL_ARGAR, argili, ILM_CLEN(ilm1));
3651 }
3652 gargili = argili;
3653 break;
3654 case IM_BYVAL:
3655 ilm1 = ILM_OPND(ilmlnk, 1); /* operand of BYVAL */
3656 gargili = ILM_RESULT(ilm1);
3657 /* dtype of by-value argument */
3658 dtype = ILM_DTyOPND(ilmlnk, 2);
3659 val_flag = NME_VOL;
3660 ilmlnk = (ILM *)(ilmb.ilm_base + ilm1);
3661 argopc = ILM_OPC(ilmlnk);
3662 if (IM_TYPE(argopc) == IMTY_REF) {
3663 /* call by reference */
3664 loc_of(NME_OF(ilm1));
3665 }
3666 if (!DT_ISBASIC(dtype)) {
3667 argili = ILI_OF(ilm1);
3668 switch (IL_RES(ILI_OPC(argili))) {
3669 case ILIA_IR:
3670 argili = ad1ili(IL_IAMV, argili);
3671 add_to_args(IL_ARGAR, argili);
3672 break;
3673 case ILIA_KR:
3674 argili = ad1ili(IL_KAMV, argili);
3675 add_to_args(IL_ARGAR, argili);
3676 break;
3677 default:
3678 if (DTY(dtype) == TY_STRUCT) {
3679 add_struct_byval_to_args(IL_ARGAR, argili, dtype);
3680 } else {
3681 add_to_args(IL_ARGAR, argili);
3682 }
3683 break;
3684 }
3685 break;
3686 } else {
3687 if (ILI_OPC(gargili) == IL_DFRAR) {
3688 /* if argument of BYVAL is function call, then don't set val_flag */
3689 int ili = ILI_OPND(gargili, 1);
3690 if (ILI_OPC(ili) == IL_JSR)
3691 val_flag = 0;
3692 }
3693 }
3694 if (ILM_RESTYPE(ilm1) == ILM_ISCMPLX ||
3695 ILM_RESTYPE(ilm1) == ILM_ISDCMPLX || dtype == DT_CMPLX ||
3696 dtype == DT_DCMPLX) {
3697 int res, mem_msz, msz;
3698 ILI_OP st_opc, ld_opc, arg_opc;
3699 argili = ILM_RRESULT(ilm1);
3700 if (ILM_RESTYPE(ilm1) == ILM_ISCMPLX)
3701 arg_opc = IL_ARGSP;
3702 else
3703 arg_opc = IL_ARGDP;
3704
3705 if (XBIT(70, 0x40000000)) {
3706 int rili;
3707 int addr, nme;
3708 /* llvm doesn't care for following arg ilis because it looks at garg.
3709 * we add each component to arg so that we don't get dump ili error
3710 * because we don't have ili for whole complex argument(except
3711 * DASPSP).
3712 */
3713 rili = ILM_RESULT(ilm1);
3714 gargili = rili;
3715 if (dtype == DT_CMPLX) {
3716 arg_opc = IL_ARGSP;
3717 argili = ad1ili(IL_SCMPLX2IMAG, rili);
3718 add_to_args(arg_opc, argili);
3719 argili = ad1ili(IL_SCMPLX2REAL, rili);
3720 add_to_args(arg_opc, argili);
3721 } else {
3722 arg_opc = IL_ARGDP;
3723 argili = ad1ili(IL_DCMPLX2IMAG, rili);
3724 add_to_args(arg_opc, argili);
3725 argili = ad1ili(IL_DCMPLX2REAL, rili);
3726 add_to_args(arg_opc, argili);
3727 }
3728 cmplx_to_mem(ILM_RESULT(ilm1), 0, dtype, &addr, &nme);
3729 gargili = addr;
3730 loc_of(nme);
3731 break;
3732 }
3733
3734 add_to_args(arg_opc, argili);
3735 #if defined(IL_GJSR) && defined(USE_LLVM_CMPLX) /* New functionality */
3736 res = ILI_OPND(ILM_RESULT(ilm1), 1);
3737 basenm = 0;
3738 dtype = ILM_RESTYPE(ilm1) == ILM_ISCMPLX ? DT_CMPLX : DT_DCMPLX;
3739 ld_opc = dtype == DT_CMPLX ? IL_LDSCMPLX : IL_LDDCMPLX;
3740 msz = dtype == DT_CMPLX ? MSZ_F8 : MSZ_F16;
3741 mem_msz = dtype == DT_CMPLX ? MSZ_F4 : MSZ_F8;
3742 if (!ILIA_ISAR(IL_RES(ILI_OPC(res)))) {
3743 /* Not an address, so we need to add a temp store */
3744 st_opc = dtype == DT_CMPLX ? IL_STSP : IL_STDP;
3745 skip = dtype == DT_CMPLX ? size_of(DT_FLOAT) : size_of(DT_DBLE);
3746 sym = mkrtemp_cpx_sc(dtype, expb.sc);
3747 ADDRTKNP(sym, 1);
3748 basenm = addnme(NT_VAR, sym, 0, 0);
3749
3750 /* Real component */
3751 res = ad_acon(sym, 0);
3752 ilix = ILM_RRESULT(ilm1);
3753 ilix = ad4ili(st_opc, ilix, res,
3754 addnme(NT_MEM, SPTR_NULL, basenm, 0), mem_msz);
3755 chk_block(ilix);
3756
3757 /* Imag component */
3758 ilix = ILM_IRESULT(ilm1);
3759 ilix = ad4ili(st_opc, ilix, ad_acon(sym, skip),
3760 addnme(NT_MEM, NOSYM, basenm, skip), mem_msz);
3761 chk_block(ilix);
3762 }
3763 gargili = ad3ili(ld_opc, res, basenm, msz);
3764 #endif /* GJSR && USE_LLVM_CMPLX (End of new functionality) */
3765 argili = ILM_IRESULT(ilm1);
3766 add_to_args(arg_opc, argili);
3767 break;
3768 }
3769 if (DTY(dtype) == TY_CHAR) {
3770 /*
3771 * NOTE that character scalar arguments may appear
3772 * as the operand to BYVAL -- need to ensure the
3773 * argument is in memory.
3774 */
3775 str1 = getstr(ilm1);
3776 if (str1->next)
3777 str1 = storechartmp(str1, ILM_MXLEN(ilm1), ILM_CLEN(ilm1));
3778 argili = getstraddr(str1);
3779 argili = ad3ili(IL_LD, argili, NME_STR1, MSZ_BYTE);
3780 gargili = argili;
3781 }
3782 else if (DTY(dtype) == TY_NCHAR) {
3783 /*
3784 * NOTE that character scalar arguments may appear
3785 * as the operand to BYVAL -- need to ensure the
3786 * argument is in memory.
3787 */
3788 str1 = getstr(ilm1);
3789 if (str1->next)
3790 str1 = storechartmp(str1, ILM_MXLEN(ilm1), ILM_CLEN(ilm1));
3791 argili = getstraddr(str1);
3792 argili = ad3ili(IL_LD, argili, NME_STR1, MSZ_UHWORD);
3793 gargili = argili;
3794 }
3795 else {
3796 /*
3797 * SIMPLE scalar types!
3798 * NOTE that character scalar arguments may already bei
3799 * passed as an integer via ICHAR.
3800 */
3801 /* word expression by value */
3802 argili = ILM_RESULT(ilm1);
3803 }
3804 add_arg_ili(argili, 0, 0);
3805 break;
3806
3807 case IM_DPSCON: /* short constant by value */
3808 dtype = DT_INT;
3809 argili = ad_icon(ILM_OPND(ilmlnk, 1));
3810 /* store all the argument entries so we can process
3811 * them in the same order as C
3812 */
3813 add_to_args(IL_ARGIR, argili);
3814 gargili = argili;
3815 break;
3816
3817 case IM_DPNULL: /* null character string */
3818 dtype = DT_CHAR;
3819 argili = ad_acon(SPTR_NULL, 0);
3820 if (pass_len) {
3821 argili2 = ad_icon(0);
3822 pass_char_arg(IL_ARGAR, argili, argili2);
3823 } else
3824 add_to_args(IL_ARGAR, argili);
3825 gargili = argili;
3826 break;
3827
3828 case IM_DPVAL:
3829 ilm1 = ILM_OPND(ilmlnk, 1); /* operand of DPVAL */
3830 gargili = ILM_RESULT(ilm1);
3831 val_flag = NME_VOL;
3832 if (ILM_RESTYPE(ilm1) == ILM_ISCMPLX) {
3833 dtype = DT_REAL;
3834 argili = ILM_RRESULT(ilm1);
3835 add_to_args(IL_ARGSP, argili);
3836 if (XBIT(121, 0x800)) {
3837 garg_ili[gi].ilix = gargili;
3838 garg_ili[gi].dtype = dtype;
3839 garg_ili[gi].val_flag = NME_VOL;
3840 gi++;
3841 ngargs++;
3842 }
3843 argili = ILM_IRESULT(ilm1);
3844 gargili = argili;
3845 add_to_args(IL_ARGSP, argili);
3846 break;
3847 }
3848 if (ILM_RESTYPE(ilm1) == ILM_ISDCMPLX) {
3849 dtype = DT_DBLE;
3850 argili = ILM_RRESULT(ilm1);
3851 add_to_args(IL_ARGDP, argili);
3852 if (XBIT(121, 0x800)) {
3853 garg_ili[gi].ilix = gargili;
3854 garg_ili[gi].dtype = dtype;
3855 garg_ili[gi].val_flag = NME_VOL;
3856 gi++;
3857 ngargs++;
3858 }
3859 argili = ILM_IRESULT(ilm1);
3860 gargili = argili;
3861 add_to_args(IL_ARGDP, argili);
3862 break;
3863 }
3864 /* word expression by value */
3865 argili = ILM_RESULT(ilm1);
3866 switch (IL_RES(ILI_OPC(argili))) {
3867 case ILIA_IR:
3868 add_to_args(IL_ARGIR, argili);
3869 dtype = DT_INT;
3870 break;
3871 case ILIA_KR:
3872 add_to_args(IL_ARGKR, argili);
3873 dtype = DT_INT8;
3874 break;
3875 case ILIA_SP:
3876 add_to_args(IL_ARGSP, argili);
3877 dtype = DT_REAL;
3878 break;
3879 case ILIA_DP:
3880 add_to_args(IL_ARGDP, argili);
3881 dtype = DT_DBLE;
3882 break;
3883 case ILIA_AR:
3884 add_to_args(IL_ARGAR, argili);
3885 dtype = DT_ADDR;
3886 break;
3887 case ILIA_CS:
3888 /* this happens when frontend put DPVAL on top of COMPLEX ILM
3889 * For example: print *, complex
3890 * Not really sure if we have any other cases.
3891 */
3892 dtype = DT_REAL;
3893 argili = ad1ili(IL_SCMPLX2REAL, ILM_RESULT(ilm1));
3894 add_to_args(IL_ARGSP, argili);
3895 if (XBIT(121, 0x800)) {
3896 garg_ili[gi].ilix = argili;
3897 garg_ili[gi].dtype = dtype;
3898 gi++;
3899 ngargs++;
3900 }
3901 argili = ad1ili(IL_SCMPLX2IMAG, ILM_RESULT(ilm1));
3902 gargili = argili;
3903 add_to_args(IL_ARGSP, argili);
3904 break;
3905 case ILIA_CD:
3906 dtype = DT_DBLE;
3907 argili = ad1ili(IL_DCMPLX2REAL, ILM_RESULT(ilm1));
3908 add_to_args(IL_ARGDP, argili);
3909 if (XBIT(121, 0x800)) {
3910 garg_ili[gi].ilix = argili;
3911 garg_ili[gi].dtype = dtype;
3912 gi++;
3913 ngargs++;
3914 }
3915 argili = ad1ili(IL_DCMPLX2IMAG, ILM_RESULT(ilm1));
3916 gargili = argili;
3917 add_to_args(IL_ARGDP, argili);
3918 break;
3919 default:
3920 interr("exp_call:bad ili for DPVAL", argili, ERR_Severe);
3921 }
3922 break;
3923
3924 case IM_DPREF: /* %REF(expression) */
3925 ilm1 = ILM_OPND(ilmlnk, 1); /* operand of DPREF */
3926 gargili = ILM_RESULT(ilm1);
3927 ilmlnk = (ILM *)(ilmb.ilm_base + ilm1);
3928 /*
3929 * If the argument to %ref is character, only the address
3930 * of the expression is used (no length is needed).
3931 * Otherwise, DPREF is handled just like the default case.
3932 */
3933 if (ILM_RESTYPE(ilm1) == ILM_ISCHAR) {
3934 str1 = getstr(ilm1);
3935 if (str1->next)
3936 str1 = storechartmp(str1, ILM_MXLEN(ilm1), ILM_CLEN(ilm1));
3937 argili = getstraddr(str1);
3938 add_to_args(IL_ARGAR, argili);
3939 break;
3940 }
3941 argopc = ILM_OPC(ilmlnk);
3942 if (argopc == IM_PLD) {
3943 argili = ILM_RESULT(ilm1);
3944 add_to_args(IL_ARGAR, argili);
3945 break;
3946 }
3947 goto argdefault;
3948
3949 case IM_DPREF8: /* pass integer*8 as integer*4 */
3950 ilm1 = ILM_OPND(ilmlnk, 1); /* operand of DPREF8 */
3951 gargili = ILM_RESULT(ilm1);
3952 ilmlnk = (ILM *)(ilmb.ilm_base + ilm1);
3953 argopc = ILM_OPC(ilmlnk);
3954 goto argdefault;
3955
3956 case IM_PLD:
3957 if (ILM_RESTYPE(ilm1) != ILM_ISCHAR) {
3958 argili = ILM_RESULT(ilm1);
3959 add_to_args(IL_ARGAR, argili);
3960 break;
3961 }
3962 /* else fall thru for handling character */
3963
3964 default:
3965 gargili = ILM_RESULT(ilm1);
3966 if (ILM_RESTYPE(ilm1) == ILM_ISCHAR) {
3967 str1 = getstr(ilm1);
3968 if (str1->next)
3969 str1 = storechartmp(str1, ILM_MXLEN(ilm1), ILM_CLEN(ilm1));
3970 argili = getstraddr(str1);
3971 if (pass_len) {
3972 pass_char_arg(IL_ARGAR, argili, getstrlen(str1));
3973 } else {
3974 add_to_args(IL_ARGAR, argili);
3975 }
3976 gargili = argili;
3977 break;
3978 }
3979 argdefault:
3980 if (IM_TYPE(argopc) == IMTY_REF) {
3981 /* call by reference */
3982 loc_of(NME_OF(ilm1));
3983 argili = ILI_OF(ilm1);
3984 } else if (IM_TYPE(argopc) == IMTY_CONS) {
3985 argili = ad_acon(ILM_SymOPND(ilmlnk, 1), 0);
3986 } else {
3987 /* general expression */
3988 if (ILM_RESTYPE(ilm1) == ILM_ISCMPLX) {
3989 sym = mkrtemp_cpx_sc(DT_CMPLX, expb.sc);
3990 } else if (ILM_RESTYPE(ilm1) == ILM_ISDCMPLX) {
3991 sym = mkrtemp_cpx_sc(DT_DCMPLX, expb.sc);
3992 } else
3993 sym = mkrtemp_sc(ILM_RESULT(ilm1), expb.sc);
3994 ADDRTKNP(sym, 1);
3995 /* generate store into temp */
3996 argili = ad_acon(sym, 0);
3997 basenm = addnme(NT_VAR, sym, 0, 0);
3998 if (ILM_RESTYPE(ilm1) == ILM_ISCMPLX) {
3999 skip = size_of(DT_FLOAT);
4000 ilix = ILM_RRESULT(ilm1);
4001 ilix = ad4ili(IL_STSP, ilix, argili,
4002 addnme(NT_MEM, SPTR_NULL, basenm, 0), MSZ_F4);
4003 chk_block(ilix);
4004 ilix = ILM_IRESULT(ilm1);
4005 ilix = ad4ili(IL_STSP, ilix, ad_acon(sym, skip),
4006 addnme(NT_MEM, NOSYM, basenm, skip), MSZ_F4);
4007 chk_block(ilix);
4008 } else if (ILM_RESTYPE(ilm1) == ILM_ISDCMPLX) {
4009 skip = size_of(DT_DBLE);
4010 ilix = ILM_RRESULT(ilm1);
4011 ilix = ad4ili(IL_STDP, ilix, argili,
4012 addnme(NT_MEM, SPTR_NULL, basenm, 0), MSZ_F8);
4013 chk_block(ilix);
4014 ilix = ILM_IRESULT(ilm1);
4015 ilix = ad4ili(IL_STDP, ilix, ad_acon(sym, skip),
4016 addnme(NT_MEM, NOSYM, basenm, skip), MSZ_F8);
4017 chk_block(ilix);
4018 } else {
4019 ilix = ILM_RESULT(ilm1);
4020 switch (IL_RES(ILI_OPC(ilix))) {
4021 case ILIA_IR:
4022 ilix = ad4ili(IL_ST, ilix, argili, basenm, MSZ_WORD);
4023 break;
4024 case ILIA_KR:
4025 ilix = ad4ili(IL_STKR, ilix, argili, basenm, MSZ_I8);
4026 break;
4027 case ILIA_AR:
4028 ilix = ad3ili(IL_STA, ilix, argili, basenm);
4029 break;
4030 case ILIA_SP:
4031 ilix = ad4ili(IL_STSP, ilix, argili, basenm, MSZ_F4);
4032 break;
4033 case ILIA_DP:
4034 ilix = ad4ili(IL_STDP, ilix, argili, basenm, MSZ_F8);
4035 break;
4036 case ILIA_CS:
4037 ilix = ad4ili(IL_STSCMPLX, ilix, argili, basenm, MSZ_F8);
4038 break;
4039 case ILIA_CD:
4040 ilix = ad4ili(IL_STDCMPLX, ilix, argili, basenm, MSZ_F16);
4041 break;
4042 default:
4043 // in exp_call for IM_SFUNC, we decide to save IL_JSR
4044 // in the ILI_OF(or ILM_RESULT) field.
4045 // Check here if that is the case
4046 if (ILI_ALT(ilix)) {
4047 int alt_call = ILI_ALT(ilix);
4048 int ili_opnd = ILI_OPND(alt_call, 2);
4049 if (ILI_OPC(ili_opnd) == IL_GARGRET) {
4050 DTYPE dtype = ILI_DTyOPND(ili_opnd, 3);
4051 int nme = ILI_OPND(ili_opnd, 4);
4052 chk_block(ilix);
4053 ilix = ILI_OPND(ili_opnd, 1);
4054 /* copy from ilix to argili */
4055 _exp_smove(basenm, nme, argili, ilix, dtype);
4056 ilix = 0;
4057 break;
4058 }
4059 }
4060 interr("exp_call: ili ret type not cased", argili, ERR_Severe);
4061 }
4062 if (ilix > 0)
4063 chk_block(ilix);
4064 }
4065 } /* else general expression */
4066 if (CSTRUCTRETG(exp_call_sym) && nargs + 1 == ILM_OPND(ilmp, 1)) {
4067 /* if this is call to a bind C rtn that returns a C struct on the
4068 * stack, the dtype needs to be set to 1 or prevent the code
4069 * generator from aligning the stack argument area. This happens
4070 * only for 32 bit compiles. The CSTRUCTRETG is ignored by the
4071 * 64 bit compilers.
4072 */
4073 add_struct_byval_to_args(IL_ARGAR, argili, 1);
4074 } else
4075 {
4076 add_to_args(IL_ARGAR, argili);
4077 }
4078 gargili = argili;
4079 break;
4080 } /* switch */
4081 if (XBIT(121, 0x800)) {
4082 garg_ili[gi].ilix = gargili;
4083 garg_ili[gi].dtype = dtype;
4084 garg_ili[gi].val_flag = val_flag;
4085 }
4086 i++;
4087 gi++;
4088 } /* for each arg */
4089
4090 arglnk = gen_arg_ili();
4091 garg_disp = 0;
4092
4093 if (gbl.internal &&
4094 (CONTAINEDG(exp_call_sym) || is_asn_closure_call(exp_call_sym))) {
4095 int disp;
4096 int nme;
4097 /* calling contained procedure from
4098 * outlined program
4099 * host program
4100 * another internal procedure
4101 */
4102 if (gbl.outlined) {
4103 nme = addnme(NT_VAR, aux.curr_entry->display, 0, 0);
4104 disp = mk_address(aux.curr_entry->display);
4105 disp = ad2ili(IL_LDA, disp, nme);
4106 } else if (gbl.internal == 1) {
4107 disp = ad_acon(aux.curr_entry->display, 0);
4108 } else {
4109 if (SCG(aux.curr_entry->display) == SC_DUMMY) {
4110 const SPTR sdisp = mk_argasym(aux.curr_entry->display);
4111 nme = addnme(NT_VAR, sdisp, 0, 0);
4112 disp = mk_address(sdisp);
4113 disp = ad2ili(IL_LDA, disp, nme);
4114 } else {
4115 /* Should not get here - something is wrong */
4116 const SPTR sdisp = sptr_mk_address(aux.curr_entry->display);
4117 disp = ad2ili(IL_LDA, sdisp, addnme(NT_VAR, sdisp, 0, 0));
4118 }
4119 }
4120 if (!XBIT(121, 0x800)) {
4121 chain_pointer_arg =
4122 ad3ili(IL_ARGAR, disp, ad1ili(IL_NULL, 0), ad1ili(IL_NULL, 0));
4123 }
4124
4125 if (XBIT(121, 0x800))
4126 garg_disp = disp;
4127 }
4128
4129 /* generate call */
4130 if (XBIT(121, 0x800)) {
4131 int dt;
4132 gargl = ad1ili(IL_NULL, 0);
4133 if (charargs) {
4134 /* when character arguments are present, place any procedure descriptor
4135 * arguments at the end of the argument list.
4136 */
4137 for (gi = ngargs; gi >= 1; gi--) {
4138 if (!HAS_OPT_ARGSG(exp_call_sym) &&
4139 is_proc_desc_arg(garg_ili[gi].ilix)) {
4140 ilix = ad4ili(IL_GARG, garg_ili[gi].ilix, gargl, garg_ili[gi].dtype,
4141 garg_ili[gi].val_flag);
4142 gargl = ilix;
4143 }
4144 }
4145 if (IL_RES(ILI_OPC(len_ili[0])) != ILIA_KR)
4146 dt = DT_INT;
4147 else
4148 dt = DT_INT8;
4149 for (i = charargs - 1; i >= 0; i--) {
4150 ilix = ad4ili(IL_GARG, len_ili[i], gargl, dt, NME_VOL);
4151 gargl = ilix;
4152 }
4153 }
4154 for (gi = ngargs; gi >= 1; gi--) {
4155 if (charargs && !HAS_OPT_ARGSG(exp_call_sym) &&
4156 is_proc_desc_arg(garg_ili[gi].ilix)) {
4157 /* already processed the procedure descriptor argument in this case */
4158 continue;
4159 }
4160 ilix = ad4ili(IL_GARG, garg_ili[gi].ilix, gargl, garg_ili[gi].dtype,
4161 garg_ili[gi].val_flag);
4162 gargl = ilix;
4163 }
4164 if (gfch_addr) {
4165 if (IL_RES(ILI_OPC(gfch_len)) != ILIA_KR)
4166 dt = DT_INT;
4167 else
4168 dt = DT_INT8;
4169 ilix = ad4ili(IL_GARG, gfch_len, gargl, dt, NME_VOL);
4170 gargl = ilix;
4171 ilix = ad4ili(IL_GARG, gfch_addr, gargl, DT_ADDR, 0);
4172 gargl = ilix;
4173 }
4174 if (garg_ili[0].ilix) {
4175 ilix = ad4ili(IL_GARGRET, garg_ili[0].ilix, gargl, garg_ili[0].dtype,
4176 garg_ili[0].nme);
4177 gargl = ilix;
4178 }
4179 if (garg_disp) {
4180 ilix = ad4ili(IL_GARG, garg_disp, ad1ili(IL_NULL, 0), DT_ADDR, 0);
4181 if (ILI_OPC(gargl) == IL_NULL)
4182 gargl = ilix;
4183 else
4184 add_last_arg(gargl, ilix);
4185 }
4186 }
4187 if (chain_pointer_arg != 0) {
4188 if (ILI_OPC(arglnk) == IL_NULL)
4189 arglnk = chain_pointer_arg;
4190 else
4191 add_last_arg(arglnk, chain_pointer_arg);
4192 }
4193 fptr_iface = SPTR_NULL;
4194 if (exp_call_sym) {
4195 DTYPE dt;
4196 fptr_iface = exp_call_sym;
4197 switch (STYPEG(fptr_iface)) {
4198 case ST_ENTRY:
4199 case ST_PROC:
4200 break;
4201 default:
4202 dt = DTYPEG(fptr_iface);
4203 if (DTY(dt) == TY_PTR && DTY(DTySeqTyElement(dt)) == TY_PROC) {
4204 fptr_iface = DTyInterface(DTySeqTyElement(dt));
4205 } else {
4206 fptr_iface = SPTR_NULL;
4207 }
4208 break;
4209 }
4210 }
4211 if (func_addr) {
4212 if (!MSCALLG(exp_call_sym))
4213 jsra_mscall_flag = 0;
4214 else
4215 jsra_mscall_flag = 0x1;
4216 if (IS_INTERNAL_PROC_CALL(opc)) {
4217 SPTR sptr_descno = (SPTR) descno;
4218 arglnk = add_last_arg(arglnk, add_arglnk_closure(sptr_descno));
4219 if (XBIT(121, 0x800)) {
4220 gargl = add_last_arg(gargl, add_gargl_closure(sptr_descno));
4221 }
4222 }
4223 ililnk = ad4ili(IL_JSRA, func_addr, arglnk, jsra_mscall_flag, fptr_iface);
4224 if (XBIT(121, 0x800)) {
4225 gjsr = ad4ili(IL_GJSRA, func_addr, gargl, jsra_mscall_flag, fptr_iface);
4226 ILI_ALT(ililnk) = gjsr;
4227 }
4228 } else if (SCG(exp_call_sym) != SC_DUMMY) {
4229 switch (opc) {
4230 case IM_VCALLA:
4231 case IM_CHVFUNCA:
4232 case IM_NCHVFUNCA:
4233 case IM_KVFUNCA:
4234 case IM_LVFUNCA:
4235 case IM_IVFUNCA:
4236 case IM_RVFUNCA:
4237 case IM_DVFUNCA:
4238 case IM_CVFUNCA:
4239 case IM_CDVFUNCA:
4240 case IM_PVFUNCA: {
4241 SPTR sptr_descno = (SPTR) descno;
4242 ililnk = exp_type_bound_proc_call(exp_call_sym, sptr_descno, vtoff, arglnk);
4243 if (XBIT(121, 0x800)) {
4244 if (!MSCALLG(exp_call_sym))
4245 jsra_mscall_flag = 0;
4246 else
4247 jsra_mscall_flag = 0x1;
4248 gjsr = ad4ili(IL_GJSRA, ILI_OPND(ililnk, 1), gargl, jsra_mscall_flag,
4249 fptr_iface);
4250 ILI_ALT(ililnk) = gjsr;
4251 }
4252 } break;
4253 default:
4254 ililnk = ad2ili(IL_JSR, exp_call_sym, arglnk);
4255 if (XBIT(121, 0x800)) {
4256 gjsr = ad2ili(IL_GJSR, exp_call_sym, gargl);
4257 ILI_ALT(ililnk) = gjsr;
4258 }
4259 }
4260 } else {
4261 SPTR asym = mk_argasym(exp_call_sym);
4262 int addr = mk_address(exp_call_sym);
4263 /* Currently we don't set CONTAINEDG for outlined function - no need too */
4264 if (!((INTERNREFG(exp_call_sym) && CONTAINEDG(gbl.currsub)) ||
4265 (gbl.outlined && PARREFG(exp_call_sym))))
4266 addr = ad2ili(IL_LDA, addr, addnme(NT_VAR, asym, 0, 0));
4267 if (!MSCALLG(exp_call_sym))
4268 jsra_mscall_flag = 0;
4269 else
4270 jsra_mscall_flag = 0x1;
4271
4272 ililnk = ad4ili(IL_JSRA, addr, arglnk, jsra_mscall_flag, fptr_iface);
4273 if (XBIT(121, 0x800)) {
4274 gjsr = ad4ili(IL_GJSRA, addr, gargl, jsra_mscall_flag, fptr_iface);
4275 ILI_ALT(ililnk) = gjsr;
4276 }
4277 }
4278 iltb.callfg = 1;
4279 switch (opc) {
4280 case IM_CALL:
4281 case IM_CHFUNC:
4282 case IM_NCHFUNC:
4283 case IM_CALLA:
4284 case IM_PCALLA:
4285 case IM_VCALLA:
4286 case IM_CHVFUNCA:
4287 case IM_NCHVFUNCA:
4288 case IM_CHFUNCA:
4289 case IM_NCHFUNCA:
4290 case IM_PCHFUNCA:
4291 case IM_PNCHFUNCA:
4292 chk_block(ililnk);
4293 break;
4294 case IM_KFUNC:
4295 case IM_KFUNCA:
4296 case IM_PKFUNCA:
4297 case IM_KVFUNCA:
4298 ililnk = ad2ili(IL_DFRKR, ililnk, KR_RETVAL);
4299 ILI_OF(curilm) = ililnk;
4300 break;
4301 case IM_LFUNC:
4302 case IM_IFUNC:
4303 case IM_LFUNCA:
4304 case IM_IFUNCA:
4305 case IM_PLFUNCA:
4306 case IM_PIFUNCA:
4307 case IM_LVFUNCA:
4308 case IM_IVFUNCA:
4309 ILI_OF(curilm) = ad2ili(IL_DFRIR, ililnk, IR_RETVAL);
4310 break;
4311 case IM_RFUNC:
4312 case IM_RFUNCA:
4313 case IM_PRFUNCA:
4314 case IM_RVFUNCA:
4315 ILI_OF(curilm) = ad2ili(IL_DFRSP, ililnk, FR_RETVAL);
4316 break;
4317 case IM_DFUNC:
4318 case IM_DFUNCA:
4319 case IM_PDFUNCA:
4320 case IM_DVFUNCA:
4321 ILI_OF(curilm) = ad2ili(IL_DFRDP, ililnk, FR_RETVAL);
4322 break;
4323 case IM_CFUNC:
4324 case IM_CFUNCA:
4325 case IM_PCFUNCA:
4326 case IM_CVFUNCA:
4327 chk_block(ililnk);
4328 if (XBIT(70, 0x40000000)) {
4329 ILM_RESULT(curilm) = ad3ili(IL_LDSCMPLX, cfunc, cfunc_nme, MSZ_F8);
4330 } else {
4331 ILM_RRESULT(curilm) = ad3ili(IL_LDSP, cfunc, addnme(NT_MEM, SPTR_NULL, cfunc_nme, 0), MSZ_F4);
4332 ILM_IRESULT(curilm) = ad3ili(IL_LDSP, ad3ili(IL_AADD, cfunc, ad_aconi(4), 0), addnme(NT_MEM, NOSYM, cfunc_nme, 4), MSZ_F4);
4333 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
4334 }
4335
4336 break;
4337 case IM_CDFUNC:
4338 case IM_CDFUNCA:
4339 case IM_PCDFUNCA:
4340 case IM_CDVFUNCA:
4341 chk_block(ililnk);
4342 if (XBIT(70, 0x40000000)) {
4343 ILM_RESULT(curilm) = ad3ili(IL_LDDCMPLX, cfunc, cfunc_nme, MSZ_F16);
4344 } else {
4345 ILM_RRESULT(curilm) = ad3ili(IL_LDDP, cfunc, addnme(NT_MEM, SPTR_NULL, cfunc_nme, 0), MSZ_F8);
4346 ILM_IRESULT(curilm) =
4347 ad3ili(IL_LDDP, ad3ili(IL_AADD, cfunc, ad_aconi(8), 0),
4348 addnme(NT_MEM, NOSYM, cfunc_nme, 8), MSZ_F8);
4349 ILM_RESTYPE(curilm) = ILM_ISDCMPLX;
4350 }
4351 break;
4352 case IM_PFUNC:
4353 case IM_PFUNCA:
4354 case IM_PPFUNCA:
4355 case IM_PVFUNCA:
4356 ILI_OF(curilm) = ad2ili(IL_DFRAR, ililnk, AR_RETVAL);
4357 ILM_NME(curilm) = NME_UNK;
4358 break;
4359 case IM_SFUNC:
4360 if (XBIT(121, 0x800)) {
4361 /* set the result to the JSR so that its result (hidden) argument can be
4362 * replaced:
4363 chk_block(ililnk);
4364 ILI_OF(curilm) = cfunc;
4365 */
4366 ILI_OF(curilm) = ililnk;
4367 ILM_NME(curilm) = cfunc_nme;
4368 break;
4369 }
4370 /* the rest will soon be deleted */
4371 if (retdesc == 1) {
4372 if (sizeof(DTYPEG(exp_call_sym)) <= 4) {
4373 ililnk = ad2ili(IL_DFRIR, ililnk, IR_RETVAL);
4374 ililnk = ad4ili(IL_STKR, ililnk, cfunc, cfunc_nme, MSZ_WORD);
4375 } else {
4376 ililnk = ad2ili(IL_DFRKR, ililnk, KR_RETVAL);
4377 ililnk = ad4ili(IL_STKR, ililnk, cfunc, cfunc_nme, MSZ_I8);
4378 }
4379 chk_block(ililnk);
4380
4381 ILI_OF(curilm) = cfunc;
4382 ILM_NME(curilm) = cfunc_nme;
4383
4384 } else {
4385 /* callee should copy result into hidden argument */
4386 ililnk = ad2ili(IL_DFRAR, ililnk, AR_RETVAL);
4387 ILM_NME(curilm) = cfunc_nme;
4388 }
4389 break;
4390 default:
4391 interr("exp_call: bad function opc", opc, ERR_Severe);
4392 }
4393 end_arg_ili();
4394 }
4395
4396 /**
4397 \param ext name of routine to call
4398 \param res_dtype function return type
4399
4400 Generate a sequence of ili for the current ilm which is an "arithmetic".
4401 This sequence essentially looks like a normal call, except where we can,
4402 arguments are passed by value.
4403
4404 The requirements are:
4405 1. The ilm looks like an "arithmetic" ILM where there's a fixed number
4406 of operands (determined by the ilms info).
4407 2. The result is returned in a temporary.
4408 3. The address of the result is the first argument in the call.
4409 4. The operands are fully evaluated (no reference ilms).
4410 5. Character arguments are not seen.
4411
4412 For now this only works for complex/double complex ILMs which are QJSRs in
4413 the "standard" fortran.
4414 */
4415 void
exp_qjsr(char * ext,DTYPE res_dtype,ILM * ilmp,int curilm)4416 exp_qjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm)
4417 {
4418 int nargs;
4419 int ililnk; /* ili link */
4420 int argili; /* ili for arg */
4421 int ilix; /* ili pointer */
4422 ILM *ilmlnk; /* current ILM operand */
4423 int ilm1;
4424 int sym; /* symbol pointers */
4425 int basenm; /* base nm entry */
4426 int i; /* temps */
4427 static ainfo_t ainfo;
4428 SPTR res; /* sptr of function result temporary */
4429 int res_addr;
4430 int res_nme;
4431 int extsym;
4432
4433 if (DT_ISCMPLX(res_dtype)) {
4434 res = mkrtemp_arg1_sc(res_dtype, expb.sc);
4435 res_addr = ad_acon(res, 0);
4436 res_nme = addnme(NT_VAR, res, 0, 0);
4437 ADDRTKNP(res, 1);
4438 } else {
4439 interr("exp_qjsr, illegal dtype", res_dtype, ERR_Severe);
4440 return;
4441 }
4442 nargs = ilms[ILM_OPC(ilmp)].oprs;
4443 extsym = mkfunc(ext);
4444 #ifdef ARG1PTRP
4445 ARG1PTRP(extsym, 1);
4446 #endif
4447 init_ainfo(&ainfo);
4448
4449 i = nargs;
4450 while (nargs--) {
4451 ilm1 = ILM_OPND(ilmp, i);
4452 ilmlnk = (ILM *)(ilmb.ilm_base + ilm1); /* ith operand */
4453 switch (ILM_RESTYPE(ilm1)) {
4454 case ILM_ISCHAR:
4455 interr("exp_qjsr: char arg not allowed", ilm1, ERR_Severe);
4456 break;
4457 case ILM_ISCMPLX:
4458 arg_sp(ILM_IRESULT(ilm1), &ainfo);
4459 arg_sp(ILM_RRESULT(ilm1), &ainfo);
4460 break;
4461 case ILM_ISDCMPLX:
4462 arg_dp(ILM_IRESULT(ilm1), &ainfo);
4463 arg_dp(ILM_RRESULT(ilm1), &ainfo);
4464 break;
4465 default:
4466 ilix = ILM_RESULT(ilm1);
4467 switch (IL_RES(ILI_OPC(ilix))) {
4468 case ILIA_IR:
4469 arg_ir(ilix, &ainfo);
4470 break;
4471 case ILIA_AR:
4472 arg_ar(ilix, &ainfo, 0);
4473 break;
4474 case ILIA_SP:
4475 arg_sp(ilix, &ainfo);
4476 break;
4477 case ILIA_DP:
4478 arg_dp(ilix, &ainfo);
4479 break;
4480 case ILIA_KR:
4481 arg_kr(ilix, &ainfo);
4482 break;
4483 #ifdef ILIA_CS
4484 case ILIA_CS:
4485 ilix = ad1ili(IL_SCMPLX2IMAG, ILM_RESULT(ilm1));
4486 arg_sp(ilix, &ainfo);
4487 ilix = ad1ili(IL_SCMPLX2REAL, ILM_RESULT(ilm1));
4488 arg_sp(ilix, &ainfo);
4489 break;
4490 case ILIA_CD:
4491 ilix = ad1ili(IL_DCMPLX2IMAG, ILM_RESULT(ilm1));
4492 arg_dp(ilix, &ainfo);
4493 ilix = ad1ili(IL_DCMPLX2REAL, ILM_RESULT(ilm1));
4494 arg_dp(ilix, &ainfo);
4495 break;
4496 #endif
4497 default:
4498 interr("exp_qjsr: ili ret type not cased", ilix, ERR_Severe);
4499 break;
4500 }
4501 }
4502 i--;
4503 } /* for each arg */
4504
4505 arg_ar(res_addr, &ainfo, 0);
4506 ililnk = ad2ili(IL_JSR, extsym, ainfo.lnk);
4507 iltb.callfg = 1;
4508 chk_block(ililnk);
4509
4510 if (res_dtype == DT_CMPLX) {
4511 if (XBIT(70, 0x40000000)) {
4512 ILM_RESULT(curilm) = ad3ili(IL_LDSCMPLX, res_addr, res_nme, MSZ_F8);
4513 } else {
4514 ILM_RRESULT(curilm) = ad3ili(IL_LDSP, res_addr, addnme(NT_MEM, SPTR_NULL, res_nme, 0), MSZ_F4);
4515 ILM_IRESULT(curilm) =
4516 ad3ili(IL_LDSP, ad3ili(IL_AADD, res_addr, ad_aconi(4), 0),
4517 addnme(NT_MEM, NOSYM, res_nme, 4), MSZ_F4);
4518 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
4519 }
4520 } else {
4521 if (XBIT(70, 0x40000000)) {
4522 ILM_RESULT(curilm) = ad3ili(IL_LDDCMPLX, res_addr, res_nme, MSZ_F16);
4523 } else {
4524
4525 ILM_RRESULT(curilm) = ad3ili(IL_LDDP, res_addr, addnme(NT_MEM, SPTR_NULL, res_nme, 0), MSZ_F8);
4526 ILM_IRESULT(curilm) =
4527 ad3ili(IL_LDDP, ad3ili(IL_AADD, res_addr, ad_aconi(8), 0),
4528 addnme(NT_MEM, NOSYM, res_nme, 8), MSZ_F8);
4529 ILM_RESTYPE(curilm) = ILM_ISDCMPLX;
4530 }
4531 }
4532
4533 end_ainfo(&ainfo);
4534 }
4535
4536 /**
4537 \param ext name of routine to call
4538 \param res_dtype function return type
4539
4540 Same as exp_qjsr() except that if the result is complex, its pointer argument
4541 is passed as the last argument instead of the first argument. This is
4542 necessary to keep double arguments properly aligned on the stack.
4543
4544 For now this only works for complex/double complex ILMs which are QJSRs in
4545 the "standard" fortran.
4546 */
4547 void
exp_zqjsr(char * ext,DTYPE res_dtype,ILM * ilmp,int curilm)4548 exp_zqjsr(char *ext, DTYPE res_dtype, ILM *ilmp, int curilm)
4549 {
4550 int nargs;
4551 int ililnk; /* ili link */
4552 int argili; /* ili for arg */
4553 int ilix; /* ili pointer */
4554 ILM *ilmlnk; /* current ILM operand */
4555 int ilm1;
4556 int sym; /* symbol pointers */
4557 int basenm; /* base nm entry */
4558 int i; /* temps */
4559 static ainfo_t ainfo;
4560 SPTR res; /* sptr of function result temporary */
4561 int res_addr;
4562 int res_nme;
4563 int extsym;
4564
4565 if (DT_ISCMPLX(res_dtype)) {
4566 res = mkrtemp_cpx_sc(res_dtype, expb.sc);
4567 res_addr = ad_acon(res, 0);
4568 res_nme = addnme(NT_VAR, res, 0, 0);
4569 ADDRTKNP(res, 1);
4570 } else {
4571 interr("exp_zqjsr, illegal dtype", res_dtype, ERR_Severe);
4572 return;
4573 }
4574 nargs = ilms[ILM_OPC(ilmp)].oprs;
4575 extsym = mkfunc(ext);
4576 init_ainfo(&ainfo);
4577 arg_ar(res_addr, &ainfo, 0);
4578
4579 i = nargs;
4580 while (nargs--) {
4581 ilm1 = ILM_OPND(ilmp, i);
4582 ilmlnk = (ILM *)(ilmb.ilm_base + ilm1); /* ith operand */
4583 switch (ILM_RESTYPE(ilm1)) {
4584 case ILM_ISCHAR:
4585 interr("exp_zqjsr: char arg not allowed", ilm1, ERR_Severe);
4586 break;
4587 case ILM_ISCMPLX:
4588 arg_sp(ILM_IRESULT(ilm1), &ainfo);
4589 arg_sp(ILM_RRESULT(ilm1), &ainfo);
4590 break;
4591 case ILM_ISDCMPLX:
4592 arg_dp(ILM_IRESULT(ilm1), &ainfo);
4593 arg_dp(ILM_RRESULT(ilm1), &ainfo);
4594 break;
4595 default:
4596 ilix = ILM_RESULT(ilm1);
4597 switch (IL_RES(ILI_OPC(ilix))) {
4598 case ILIA_IR:
4599 arg_ir(ilix, &ainfo);
4600 break;
4601 case ILIA_AR:
4602 arg_ar(ilix, &ainfo, 0);
4603 break;
4604 case ILIA_SP:
4605 arg_sp(ilix, &ainfo);
4606 break;
4607 case ILIA_DP:
4608 arg_dp(ilix, &ainfo);
4609 break;
4610 case ILIA_KR:
4611 arg_kr(ilix, &ainfo);
4612 break;
4613 #ifdef ILIA_CS
4614 case ILIA_CS:
4615 ilix = ad1ili(IL_SCMPLX2IMAG, ILM_RESULT(ilm1));
4616 arg_sp(ilix, &ainfo);
4617 ilix = ad1ili(IL_SCMPLX2REAL, ILM_RESULT(ilm1));
4618 arg_sp(ilix, &ainfo);
4619 break;
4620 case ILIA_CD:
4621 ilix = ad1ili(IL_DCMPLX2IMAG, ILM_RESULT(ilm1));
4622 arg_dp(ilix, &ainfo);
4623 ilix = ad1ili(IL_DCMPLX2REAL, ILM_RESULT(ilm1));
4624 arg_dp(ilix, &ainfo);
4625 break;
4626 #endif
4627 default:
4628 interr("exp_zqjsr: ili ret type not cased", ilix, ERR_Severe);
4629 break;
4630 }
4631 }
4632 i--;
4633 } /* for each arg */
4634
4635 ililnk = ad2ili(IL_JSR, extsym, ainfo.lnk);
4636 iltb.callfg = 1;
4637 chk_block(ililnk);
4638
4639 if (res_dtype == DT_CMPLX) {
4640 if (XBIT(70, 0x40000000)) {
4641 ILM_RESULT(curilm) = ad3ili(IL_LDSCMPLX, res_addr, res_nme, MSZ_F8);
4642 } else {
4643
4644 ILM_RRESULT(curilm) =
4645 ad3ili(IL_LDSP, res_addr, addnme(NT_MEM, SPTR_NULL, res_nme, 0), MSZ_F4);
4646 ILM_IRESULT(curilm) =
4647 ad3ili(IL_LDSP, ad3ili(IL_AADD, res_addr, ad_aconi(4), 0),
4648 addnme(NT_MEM, NOSYM, res_nme, 4), MSZ_F4);
4649 ILM_RESTYPE(curilm) = ILM_ISCMPLX;
4650 }
4651 } else {
4652 if (XBIT(70, 0x40000000)) {
4653 ILM_RESULT(curilm) = ad3ili(IL_LDDCMPLX, res_addr, res_nme, MSZ_F16);
4654 } else {
4655 ILM_RRESULT(curilm) =
4656 ad3ili(IL_LDDP, res_addr, addnme(NT_MEM, SPTR_NULL, res_nme, 0), MSZ_F8);
4657 ILM_IRESULT(curilm) = ad3ili(IL_LDDP, ad3ili(IL_AADD, res_addr, ad_aconi(8), 0),
4658 addnme(NT_MEM, NOSYM, res_nme, 8), MSZ_F8);
4659 ILM_RESTYPE(curilm) = ILM_ISDCMPLX;
4660 }
4661 }
4662
4663 end_ainfo(&ainfo);
4664 }
4665
4666 static void
arg_ir(int ilix,ainfo_t * ap)4667 arg_ir(int ilix, ainfo_t *ap)
4668 {
4669 ilix = sel_iconv(ilix, 0);
4670 ap->lnk = ad2ili(IL_ARGIR, ilix, ap->lnk);
4671 }
4672
4673 static void
arg_kr(int ilix,ainfo_t * ap)4674 arg_kr(int ilix, ainfo_t *ap)
4675 {
4676 ilix = sel_iconv(ilix, 1);
4677 ap->lnk = ad2ili(IL_ARGKR, ilix, ap->lnk);
4678 }
4679
4680 static void
arg_ar(int ilix,ainfo_t * ap,int dtype)4681 arg_ar(int ilix, ainfo_t *ap, int dtype)
4682 {
4683 ap->lnk = ad3ili(IL_ARGAR, ilix, ap->lnk, dtype);
4684 }
4685
4686 static void
arg_sp(int ilix,ainfo_t * ap)4687 arg_sp(int ilix, ainfo_t *ap)
4688 {
4689 ap->lnk = ad2ili(IL_ARGSP, ilix, ap->lnk);
4690 }
4691
4692 static void
arg_dp(int ilix,ainfo_t * ap)4693 arg_dp(int ilix, ainfo_t *ap)
4694 {
4695 ap->lnk = ad2ili(IL_ARGDP, ilix, ap->lnk);
4696 }
4697
4698 static void
arg_charlen(int ilix,ainfo_t * ap)4699 arg_charlen(int ilix, ainfo_t *ap)
4700 {
4701 if (IL_RES(ILI_OPC(ilix)) != ILIA_KR)
4702 arg_ir(ilix, ap);
4703 else
4704 arg_kr(ilix, ap);
4705 }
4706
4707 static void
arg_length(STRDESC * str,ainfo_t * ap)4708 arg_length(STRDESC *str, ainfo_t *ap)
4709 {
4710 if (!XBIT(125, 0x40000))
4711 arg_kr(getstrlen64(str), ap);
4712 else
4713 arg_ir(getstrlen(str), ap);
4714 }
4715
4716 /***************************************************************/
4717
4718 /** Expand an smove ILM.
4719 \param destilm: ilm of receiving struct/union
4720 \param srcilm: ilm of sending struct/union
4721 \param dtype: data type of struct/union
4722 */
4723 void
expand_smove(int destilm,int srcilm,DTYPE dtype)4724 expand_smove(int destilm, int srcilm, DTYPE dtype)
4725 {
4726 int dest_nme; /* names entry */
4727 int src_nme; /* names entry */
4728 int dest_addr; /* pointer to ili for destination addr */
4729 int src_addr; /* pointer to ili for source addr */
4730 UINT n; /* number of bytes left to copy */
4731 int i;
4732 INT offset; /* number of bytes from begin addr */
4733
4734 dest_nme = NME_OF(destilm);
4735 src_nme = NME_OF(srcilm);
4736 if (flg.opt > 1) {
4737 loc_of(dest_nme); /* implicit LOC */
4738 loc_of(src_nme);
4739 }
4740 dest_addr = ILI_OF(destilm);
4741 src_addr = ILI_OF(srcilm);
4742 if (USE_GSMOVE) {
4743 int ilix;
4744 ilix = ad5ili(IL_GSMOVE, src_addr, dest_addr, src_nme, dest_nme, dtype);
4745 chk_block(ilix);
4746 } else {
4747 _exp_smove(dest_nme, src_nme, dest_addr, src_addr, dtype);
4748 }
4749 }
4750
4751 /** \brief Transform the GSMOVE ILI created by expand_smove()
4752 */
4753 void
exp_remove_gsmove(void)4754 exp_remove_gsmove(void)
4755 {
4756 int bihx, iltx, ilix;
4757 p_chk_block = gsmove_chk_block;
4758 for (bihx = gbl.entbih; bihx; bihx = BIH_NEXT(bihx)) {
4759 int next_ilt;
4760 bool any_gsmove = false;
4761 rdilts(bihx);
4762 for (iltx = ILT_NEXT(0); iltx;) {
4763 next_ilt = ILT_NEXT(iltx);
4764 ilix = ILT_ILIP(iltx);
4765 if (ILI_OPC(ilix) == IL_GSMOVE) {
4766 int src_addr = ILI_OPND(ilix, 1);
4767 int dest_addr = ILI_OPND(ilix, 2);
4768 int src_nme = ILI_OPND(ilix, 3);
4769 int dest_nme = ILI_OPND(ilix, 4);
4770 DTYPE dtype = ILI_DTyOPND(ilix, 5);
4771 any_gsmove = true;
4772 gsmove_ilt = iltx;
4773 _exp_smove(dest_nme, src_nme, dest_addr, src_addr, dtype);
4774 ILT_NEXT(gsmove_ilt) = next_ilt;
4775 ILT_PREV(next_ilt) = gsmove_ilt;
4776 delilt(iltx);
4777 }
4778 iltx = next_ilt;
4779 }
4780 wrilts(bihx);
4781 if (DBGBIT(10, 2) && any_gsmove) {
4782 fprintf(gbl.dbgfil, "\n***** After remove gsmove *****\n");
4783 dump_one_block(gbl.dbgfil, bihx, NULL);
4784 }
4785 }
4786 p_chk_block = chk_block;
4787 }
4788
4789 static void
_exp_smove(int dest_nme,int src_nme,int dest_addr,int src_addr,DTYPE dtype)4790 _exp_smove(int dest_nme, int src_nme, int dest_addr, int src_addr, DTYPE dtype)
4791 {
4792 ISZ_T n; /* number of bytes left to copy */
4793 int i;
4794 INT offset; /* number of bytes from begin addr */
4795
4796 n = size_of(dtype);
4797 if (0 && !XBIT(2, 0x1000000)) {
4798 chk_block(ad5ili(IL_SMOVEJ, src_addr, dest_addr, src_nme, dest_nme, n));
4799 smove_flag = 1; /* structure move in this function */
4800 return;
4801 }
4802 offset = 0;
4803
4804 /* for large structs, copy as much as possible using an smovl/smoveq instr: */
4805 #define SMOVE_CHUNK 8
4806 #define TEST_BOUND 96
4807 if (n > TEST_BOUND) {
4808
4809 if (XBIT(2, 0x200000)) {
4810 p_chk_block(ad4ili(IL_SMOVE, src_addr, dest_addr,
4811 ad_aconi(n / SMOVE_CHUNK), dest_nme));
4812 } else {
4813 p_chk_block(ad5ili(IL_SMOVEJ, src_addr, dest_addr, src_nme,
4814 dest_nme, n));
4815 }
4816 smove_flag = 1; /* structure move in this function */
4817 offset = (n / SMOVE_CHUNK) * SMOVE_CHUNK;
4818 n = n - offset;
4819 if (n > 0) {
4820 /* add CSE's to prevent addresses from being recalculated: */
4821 src_addr = ad1ili(IL_CSEAR, src_addr);
4822 dest_addr = ad1ili(IL_CSEAR, dest_addr);
4823 }
4824 }
4825
4826 /* generate loads and stores for the parts of the structs remaining: */
4827
4828 #define START_AT 0 /* loop for skip size == 8, 4, 2, 1 */
4829 for (i = START_AT; i < 4; i++) {
4830 static struct {
4831 short siz;
4832 short skip;
4833 } info[4] = {{MSZ_I8, 8}, {MSZ_WORD, 4}, {MSZ_UHWORD, 2}, {MSZ_UBYTE, 1}};
4834
4835 int siz = info[i].siz;
4836 int skip = info[i].skip;
4837
4838 while (n >= skip) {
4839 int ilip, ilix; /* temporary ili pointers */
4840
4841 /* add load and store ili: */
4842
4843 ilip = ad_aconi(offset);
4844 ilix = ad3ili(IL_AADD, src_addr, ilip, 0);
4845 if (siz == MSZ_I8)
4846 ilix = ad3ili(IL_LDKR, ilix, src_nme, siz);
4847 else
4848 ilix = ad3ili(IL_LD, ilix, src_nme, siz);
4849 ilip = ad3ili(IL_AADD, dest_addr, ilip, 0);
4850 if (siz == MSZ_I8)
4851 ilip = ad4ili(IL_STKR, ilix, ilip, dest_nme, siz);
4852 else
4853 ilip = ad4ili(IL_ST, ilix, ilip, dest_nme, siz);
4854 p_chk_block(ilip);
4855
4856 offset += skip;
4857 n -= skip;
4858 if (n > 0) {
4859 src_addr = ad1ili(IL_CSEAR, src_addr);
4860 dest_addr = ad1ili(IL_CSEAR, dest_addr);
4861 }
4862 }
4863 }
4864 }
4865
4866 /***************************************************************/
4867
4868 /**
4869 \param to ilm of receiving struct/union
4870 \param from ilm of sending struct/union
4871 \param dtype data type of struct/union
4872 */
4873 void
exp_szero(ILM * ilmp,int curilm,int to,int from,int dtype)4874 exp_szero(ILM *ilmp, int curilm, int to, int from, int dtype)
4875 {
4876 int nme; /* names entry */
4877 int store, /* store ili generated */
4878 addr, /* address ili where value stored */
4879 expr, /* ili of value being stored */
4880 sym; /* ST item */
4881 int tmp;
4882
4883 nme = NME_OF(to);
4884 addr = ILI_OF(to);
4885 expr = ILI_OF(from);
4886 loc_of(nme);
4887 tmp = ad1ili(IL_NULL, 0);
4888 tmp = ad3ili(IL_ARGAR, addr, tmp, 0);
4889 tmp = ad2ili(IL_ARGIR, expr, tmp);
4890 sym = mkfunc("__c_bzero");
4891 chk_block(ad2ili(IL_JSR, sym, tmp)); /* temporary */
4892 }
4893
4894 void
exp_fstring(ILM_OP opc,ILM * ilmp,int curilm)4895 exp_fstring(ILM_OP opc, ILM *ilmp, int curilm)
4896 {
4897 int ili1;
4898 int sym;
4899 int op1, op2;
4900 int tmp;
4901 INT val[2];
4902 int addr, highsub, lowsub;
4903 int hsubili, lsubili;
4904 bool any_kr;
4905 STRDESC *str1, *str2;
4906 int ilm1;
4907
4908 switch (opc) {
4909 case IM_ICHAR: /* char to integer */
4910 tmp = MSZ_BYTE;
4911 case IM_INCHAR: /* nchar to integer */
4912 if (opc == IM_INCHAR)
4913 tmp = MSZ_UHWORD;
4914 ilm1 = ILM_OPND(ilmp, 1);
4915 str1 = getstr(ilm1);
4916 if (!str1->next)
4917 ili1 = ILI_OF(ilm1); /* char result */
4918 else {
4919 if (str1->liscon && str1->lval >= 1) {
4920 ;
4921 } else {
4922 str1 = storechartmp(str1, ILM_MXLEN(ilm1), ILM_CLEN(ilm1));
4923 }
4924 ili1 = getstraddr(str1);
4925 }
4926 if (ILI_OPC(ili1) == IL_ACON && opc != IM_INCHAR &&
4927 STYPEG(sym = CONVAL1G(ILI_OPND(ili1, 1))) == ST_CONST) {
4928 /* constant char str */
4929 #if DEBUG
4930 assert(DTY(DTYPEG(sym)) == TY_CHAR, "non char op of ICHAR", ili1,
4931 ERR_Severe);
4932 #endif
4933 op1 = CONVAL1G(sym); /* names area idx containing string */
4934 op2 = CONVAL2G(ILI_OPND(ili1, 1)); /* offset */
4935 tmp = stb.n_base[op1 + op2] & 0xff;
4936 ILM_RESULT(curilm) = ad_icon(tmp);
4937 } else
4938 ILM_RESULT(curilm) = ad3ili(IL_LD, ili1, NME_STR1, tmp);
4939 return;
4940
4941 case IM_CHAR: /* integer to char */
4942 val[0] = getchartmp(ad_icon(1));
4943 val[1] = 0;
4944 tmp = getcon(val, DT_ADDR);
4945 op1 = ILI_OF(ILM_OPND(ilmp, 1));
4946 if (IL_RES(ILI_OPC(op1)) == ILIA_KR)
4947 op1 = ad1ili(IL_KIMV, op1);
4948 ili1 = ad4ili(IL_ST, op1, ad1ili(IL_ACON, tmp), NME_STR1, MSZ_BYTE);
4949 chk_block(ili1);
4950 ILM_RESULT(curilm) = ad1ili(IL_ACON, tmp);
4951 ILM_RESTYPE(curilm) = ILM_ISCHAR;
4952 if (CHARLEN_64BIT) {
4953 ILM_CLEN(curilm) = ILM_MXLEN(curilm) = ad_kconi(1);
4954 } else {
4955 ILM_CLEN(curilm) = ILM_MXLEN(curilm) = ad_icon(1);
4956 }
4957 return;
4958
4959 case IM_NCHAR: /* integer to kanji char */
4960 val[0] = getchartmp(ad_icon(2));
4961 val[1] = 0;
4962 tmp = getcon(val, DT_ADDR);
4963 ili1 = ad4ili(IL_ST, ILI_OF(ILM_OPND(ilmp, 1)), ad1ili(IL_ACON, tmp),
4964 NME_STR1, MSZ_UHWORD);
4965 chk_block(ili1);
4966 ILM_RESULT(curilm) = ad1ili(IL_ACON, tmp);
4967 ILM_RESTYPE(curilm) = ILM_ISCHAR;
4968 if (CHARLEN_64BIT) {
4969 ILM_CLEN(curilm) = ILM_MXLEN(curilm) = ad_kconi(1);
4970 } else {
4971 ILM_CLEN(curilm) = ILM_MXLEN(curilm) = ad_icon(1);
4972 }
4973 return;
4974
4975 case IM_SST: /* string store */
4976 case IM_NSST:
4977 str1 = getstr(ILM_OPND(ilmp, 1));
4978 str2 = getstr(ILM_OPND(ilmp, 2));
4979 #if DEBUG
4980 assert(str1->cnt == 1, "string store into concat", curilm, ERR_Severe);
4981 #endif
4982 /* special case string store into single char */
4983 if (strislen1(str1)) {
4984 int tmp = MSZ_BYTE;
4985 if (strislen0(str2)) {
4986 if (opc != IM_NSST) {
4987 str2 = getstrconst(" ", 1);
4988 } else {
4989 goto bldfcall;
4990 }
4991 }
4992 if (opc == IM_NSST)
4993 tmp = MSZ_UHWORD;
4994 ili1 = ad3ili(IL_LD, getstraddr(str2), NME_STR1, tmp);
4995 ili1 = ad4ili(IL_ST, ili1, getstraddr(str1), NME_STR1, tmp);
4996 chk_block(ili1);
4997 return;
4998 }
4999 bldfcall:
5000 /* build function call */
5001 ili1 = exp_strcpy(str1, str2);
5002 iltb.callfg = 1;
5003 chk_block(ili1);
5004 return;
5005
5006 case IM_SPSEUDOST: /* string pseudo store */
5007 case IM_NSPSEUDOST:
5008 /* for now, just force the character expression into a temporary
5009 * and pass on the information for the temp.
5010 */
5011 str2 = getstr(ILM_OPND(ilmp, 2));
5012 ili1 = ad_icon(ILM_OPND(ilmp, 1));
5013 str1 = storechartmp(str2, ili1, ili1);
5014 ILM_RESULT(curilm) = getstraddr(str1);
5015 ILM_RESTYPE(curilm) = ILM_ISCHAR;
5016 if (CHARLEN_64BIT) {
5017 ILM_CLEN(curilm) = ILM_MXLEN(curilm) = sel_iconv(ili1, 1);
5018 } else {
5019 ILM_CLEN(curilm) = ILM_MXLEN(curilm) = ili1;
5020 }
5021 return;
5022
5023 case IM_LEN: /* length of string */
5024 case IM_NLEN:
5025 ili1 = ILM_CLEN(ILM_OPND(ilmp, 1));
5026 if (IL_RES(ILI_OPC(ili1)) == ILIA_KR)
5027 ili1 = ad1ili(IL_KIMV, ili1);
5028 ILM_RESULT(curilm) = ili1;
5029 #if DEBUG
5030 assert(ILM_RESULT(curilm) != 0, "IM_LEN:len ili 0", curilm, ERR_Severe);
5031 #endif
5032 return;
5033 case IM_KLEN: /* length of string */
5034 ili1 = ILM_CLEN(ILM_OPND(ilmp, 1));
5035 if (IL_RES(ILI_OPC(ili1)) != ILIA_KR)
5036 ili1 = ad1ili(IL_IKMV, ili1);
5037 ILM_RESULT(curilm) = ili1;
5038 return;
5039
5040 case IM_SUBS: /* substring */
5041 case IM_NSUBS:
5042 /*-
5043 * addr = addr + lowsub - 1
5044 * len = highsub - lowsub + 1
5045 * maxlen = len (if const.) else maxlen
5046 */
5047 addr = ILM_OPND(ilmp, 1);
5048 lowsub = ILM_OPND(ilmp, 2);
5049 highsub = ILM_OPND(ilmp, 3);
5050 lsubili = ILI_OF(lowsub);
5051 hsubili = ILI_OF(highsub);
5052
5053 if (CHARLEN_64BIT)
5054 any_kr = true;
5055 else
5056 any_kr = (IL_RES(ILI_OPC(lsubili)) == ILIA_KR) ||
5057 (IL_RES(ILI_OPC(hsubili)) == ILIA_KR);
5058 if (any_kr) {
5059 if (IL_RES(ILI_OPC(lsubili)) != ILIA_KR)
5060 lsubili = ad1ili(IL_IKMV, lsubili);
5061 if (IL_RES(ILI_OPC(hsubili)) != ILIA_KR)
5062 hsubili = ad1ili(IL_IKMV, hsubili);
5063 ili1 = ad2ili(IL_KSUB, lsubili, ad_kconi(1));
5064 if (opc == IM_NSUBS)
5065 ili1 = ad2ili(IL_KMUL, ili1, ad_kconi(2));
5066 ili1 = ad1ili(IL_KAMV, ili1);
5067 ILI_OF(curilm) = ad3ili(IL_AADD, ILI_OF(addr), ili1, 0);
5068 ili1 = ad2ili(IL_KSUB, hsubili, lsubili);
5069 ili1 = ad2ili(IL_KADD, ili1, ad_kconi(1));
5070 if (!CHARLEN_64BIT)
5071 ili1 = ad1ili(IL_KIMV, ili1);
5072 } else {
5073 ili1 = ad2ili(IL_ISUB, lsubili, ad_icon(1));
5074 if (opc == IM_NSUBS)
5075 ili1 = ad2ili(IL_IMUL, ili1, ad_icon(2));
5076 ili1 = ad1ili(IL_IAMV, ili1);
5077 ILI_OF(curilm) = ad3ili(IL_AADD, ILI_OF(addr), ili1, 0);
5078 ili1 = ad2ili(IL_ISUB, hsubili, lsubili);
5079 ili1 = ad2ili(IL_IADD, ili1, ad_icon(1));
5080 if (CHARLEN_64BIT)
5081 ili1 = sel_iconv(ili1, 1);
5082 }
5083
5084 if (IL_TYPE(ILI_OPC(ili1)) == ILTY_CONS) {
5085 if (get_isz_cval(ILI_OPND(ili1, 1)) < 0)
5086 ili1 = ad_icon(0);
5087 if (CHARLEN_64BIT)
5088 ili1 = sel_iconv(ili1, 1);
5089 ILM_CLEN(curilm) = ili1;
5090 ILM_MXLEN(curilm) = ili1;
5091 } else {
5092 if (CHARLEN_64BIT) {
5093 ILM_CLEN(curilm) = ad2ili(IL_KMAX, ili1, ad_kconi(0));
5094 if (ILM_MXLEN(addr))
5095 ILM_MXLEN(curilm) = sel_iconv(ILM_MXLEN(addr), 1);
5096 else
5097 ILM_MXLEN(curilm) = 0;
5098 } else {
5099 ILM_CLEN(curilm) = ad2ili(IL_IMAX, ili1, ad_icon(0));
5100 ILM_MXLEN(curilm) = ILM_MXLEN(addr);
5101 }
5102 }
5103 ILM_RESTYPE(curilm) = ILM_ISCHAR;
5104 return;
5105
5106 case IM_SCAT: /* concatenation */
5107 case IM_NSCAT:
5108 op1 = ILM_OPND(ilmp, 1);
5109 op2 = ILM_OPND(ilmp, 2);
5110 if (CHARLEN_64BIT) {
5111 ILM_CLEN(curilm) = ad2ili(IL_KADD, sel_iconv(ILM_CLEN(op1), 1),
5112 sel_iconv(ILM_CLEN(op2), 1));
5113 } else {
5114 ILM_CLEN(curilm) =
5115 ad2ili(IL_IADD, ILM_CLEN(op1), ILM_CLEN(op2));
5116 }
5117 if (ILM_MXLEN(op1) && ILM_MXLEN(op2)) {
5118 if (CHARLEN_64BIT) {
5119 ILM_MXLEN(curilm) = ad2ili(IL_KADD, sel_iconv(ILM_MXLEN(op1), 1),
5120 sel_iconv(ILM_MXLEN(op2), 1));
5121 } else {
5122 ILM_MXLEN(curilm) =
5123 ad2ili(IL_IADD, ILM_MXLEN(op1), ILM_MXLEN(op2));
5124 }
5125 } else {
5126 ILM_MXLEN(curilm) = 0;
5127 }
5128 ILM_RESULT(curilm) = 0; /* FIXME? */
5129 ILM_RESTYPE(curilm) = ILM_ISCHAR;
5130 return;
5131
5132 case IM_SCMP:
5133 case IM_NSCMP:
5134 /* set indicator for the referencing relational ILM --
5135 * indicates a string compare is handled by calling
5136 * ftn_strcmp.
5137 */
5138 ILM_RESTYPE(curilm) = ILM_ISCHAR;
5139 case IM_INDEX:
5140 case IM_KINDEX:
5141 case IM_NINDEX:
5142 /* if either arg is SCAT generate tmp and store into it */
5143 str1 = getstr(ILM_OPND(ilmp, 1));
5144 if (str1->next)
5145 str1 = storechartmp(str1, ILM_MXLEN(ILM_OPND(ilmp, 1)),
5146 ILM_CLEN(ILM_OPND(ilmp, 1)));
5147 str2 = getstr(ILM_OPND(ilmp, 2));
5148 if (str2->next)
5149 str2 = storechartmp(str2, ILM_MXLEN(ILM_OPND(ilmp, 2)),
5150 ILM_CLEN(ILM_OPND(ilmp, 2)));
5151 if (opc == IM_SCMP) {
5152 char *p1, *p2;
5153
5154 p1 = getcharconst(str1);
5155 p2 = getcharconst(str2);
5156 if (p1 != NULL & p2 != NULL) {
5157 val[0] = ftn_strcmp(p1, p2, str1->lval, str2->lval);
5158 ILM_RESULT(curilm) = ad_icon(val[0]);
5159 return;
5160 }
5161 if (strislen1(str1) && strislen1(str2)) {
5162 /* special case str cmp of single chars: generate a ICMP ili
5163 * with a load the two character items. This ili is save as
5164 * the result of the SCMP and will be picked up as a special
5165 * case by the relational ILM referencing this ILM (due to the
5166 * ILM_RESTYPE of ILM_ISCHAR).
5167 */
5168 op1 = ad3ili(IL_LD, getstraddr(str1), NME_STR1, MSZ_BYTE);
5169 op2 = ad3ili(IL_LD, getstraddr(str2), NME_STR1, MSZ_BYTE);
5170 ILM_RESULT(curilm) = ad3ili(IL_ICMP, op1, op2, CC_EQ);
5171 return;
5172 }
5173 }
5174 /* gen call to strcmp or stridx routine */
5175 iltb.callfg = 1;
5176 ili1 = exp_strx(opc, str1, str2);
5177 ILM_RESULT(curilm) = ili1;
5178 return;
5179
5180 default:
5181 interr("unrecognized fstr ILM", opc, ERR_Severe);
5182 break;
5183 }
5184 }
5185
5186 static int
exp_strx(int opc,STRDESC * str1,STRDESC * str2)5187 exp_strx(int opc, STRDESC *str1, STRDESC *str2)
5188 {
5189 int sym;
5190 int ili1;
5191 char *str_index_nm;
5192 char *nstr_index_nm;
5193 char *strcmp_nm;
5194 char *nstrcmp_nm;
5195 char *ftn_str_kindex_nm;
5196
5197 if (CHARLEN_64BIT) {
5198 str_index_nm = mkRteRtnNm(RTE_str_index_klen);
5199 nstr_index_nm = mkRteRtnNm(RTE_nstr_index_klen);
5200 strcmp_nm = mkRteRtnNm(RTE_strcmp_klen);
5201 nstrcmp_nm = mkRteRtnNm(RTE_nstrcmp_klen);
5202 ftn_str_kindex_nm = "ftn_str_kindex_klen";
5203 } else {
5204 str_index_nm = mkRteRtnNm(RTE_str_index);
5205 nstr_index_nm = mkRteRtnNm(RTE_nstr_index);
5206 strcmp_nm = mkRteRtnNm(RTE_strcmp);
5207 nstrcmp_nm = mkRteRtnNm(RTE_nstrcmp);
5208 ftn_str_kindex_nm = "ftn_str_kindex";
5209 }
5210
5211 if (str1->dtype == TY_NCHAR)
5212 sym = frte_func(mkfunc, opc == IM_NSCMP ? nstrcmp_nm : nstr_index_nm);
5213 else if (opc == IM_KINDEX)
5214 sym = mkfunc(ftn_str_kindex_nm);
5215 else
5216 sym = frte_func(mkfunc, opc == IM_SCMP ? strcmp_nm : str_index_nm);
5217 ili1 = ad1ili(IL_NULL, 0);
5218 /* str1 & str2 lens */
5219 if (!XBIT(125, 0x40000)) {
5220 ili1 = ad2ili(IL_ARGKR, getstrlen64(str2), ili1);
5221 ili1 = ad2ili(IL_ARGKR, getstrlen64(str1), ili1);
5222 } else {
5223 ili1 = ad2ili(IL_ARGIR, getstrlen(str2), ili1);
5224 ili1 = ad2ili(IL_ARGIR, getstrlen(str1), ili1);
5225 }
5226 /* str1 & str2 addrs */
5227 ili1 = ad3ili(IL_ARGAR, getstraddr(str2), ili1, 0);
5228 ili1 = ad3ili(IL_ARGAR, getstraddr(str1), ili1, 0);
5229 /* JSR */
5230 ili1 = ad2ili(IL_JSR, sym, ili1);
5231 if (opc == IM_KINDEX)
5232 ili1 = ad2ili(IL_DFRKR, ili1, KR_RETVAL);
5233 else
5234 ili1 = ad2ili(IL_DFRIR, ili1, IR_RETVAL);
5235 return ili1;
5236 }
5237
5238 static void
from_addr_and_length(STRDESC * s,ainfo_t * ainfo_ptr)5239 from_addr_and_length(STRDESC *s, ainfo_t *ainfo_ptr)
5240 {
5241 if (s->next)
5242 from_addr_and_length(s->next, ainfo_ptr);
5243 arg_length(s, ainfo_ptr);
5244 arg_ar(getstraddr(s), ainfo_ptr, 0);
5245 }
5246
5247 static int
exp_strcpy(STRDESC * str1,STRDESC * str2)5248 exp_strcpy(STRDESC *str1, STRDESC *str2)
5249 {
5250 int sym;
5251 STRDESC *s;
5252 int n;
5253 int ili1;
5254 static ainfo_t ainfo;
5255 char *str_copy_nm;
5256 char *nstr_copy_nm;
5257 if (CHARLEN_64BIT) {
5258 str_copy_nm = mkRteRtnNm(RTE_str_copy_klen);
5259 nstr_copy_nm = mkRteRtnNm(RTE_nstr_copy_klen);
5260 } else {
5261 str_copy_nm = mkRteRtnNm(RTE_str_copy);
5262 nstr_copy_nm = mkRteRtnNm(RTE_nstr_copy);
5263 }
5264
5265 init_ainfo(&ainfo);
5266
5267 if (str1->dtype == TY_CHAR) {
5268 if (!strovlp(str1, str2)) {
5269 /*
5270 * single source, no overlap
5271 */
5272 #define STR_MOVE_THRESH 16
5273 if (!XBIT(125, 0x800) && str1->liscon && str2->liscon &&
5274 str1->lval <= STR_MOVE_THRESH) {
5275 /*
5276 * perform a 'block move' of the rhs to the lhs -- the move
5277 * will move a combination of 8 (64-bit only) 4, 2, and 1
5278 * bytes. Note that this same code appears in the 32-bit
5279 * and 64-bit compilers, thus the check of TARGET_X8632.
5280 */
5281 if (str1->lval > str2->lval) {
5282 char *p2;
5283 p2 = getcharconst(str2);
5284 if (p2) {
5285 /*
5286 * if the rhs is a constant shorter than the lhs,
5287 * need to create a new constant padded with
5288 * blanks. Pad the constant to make its length
5289 * a multiple of a number specific to the arch
5290 * (8 for 64-bit, and 4 for 32-bit).
5291 */
5292 ISZ_T len;
5293 ISZ_T md;
5294 ISZ_T pad;
5295 char b[STR_MOVE_THRESH + 1];
5296 char *str;
5297
5298 str = b;
5299 len = (ISZ_T)str2->lval;
5300 while (len-- > 0) {
5301 *str++ = *p2++;
5302 }
5303 md = (8 - (str2->lval & 0x7)) & 0x7;
5304 if (XBIT(125, 0x1000) || str2->lval + md > str1->lval) {
5305 pad = str1->lval - str2->lval;
5306 } else {
5307 pad = md;
5308 }
5309 len = str2->lval + pad;
5310 while (pad-- > 0) {
5311 *str++ = ' ';
5312 }
5313 str2 = getstrconst(b, len);
5314 }
5315 }
5316 ili1 = block_str_move(str1, str2);
5317 return ili1;
5318 }
5319 sym = frte_func(mkfunc_cncall, mkRteRtnNm(RTE_str_cpy1));
5320
5321 /* from addr and length */
5322 arg_length(str2, &ainfo);
5323 arg_ar(getstraddr(str2), &ainfo, 0);
5324
5325 /* to addr and length */
5326 arg_length(str1, &ainfo);
5327 arg_ar(getstraddr(str1), &ainfo, 0);
5328
5329 /* JSR */
5330 ili1 = ad2ili(IL_JSR, sym, ainfo.lnk);
5331 end_ainfo(&ainfo);
5332 return ili1;
5333 }
5334 }
5335
5336 if (str1->dtype == TY_NCHAR)
5337 sym = frte_func(mkfunc, nstr_copy_nm);
5338 else
5339 sym = frte_func(mkfunc, str_copy_nm);
5340 VARARGP(sym, 1);
5341 n = str2->cnt;
5342
5343 /* from addrs and lengths, need to recurse */
5344 from_addr_and_length(str2, &ainfo);
5345
5346 /* to addr and length */
5347 arg_length(str1, &ainfo);
5348 arg_ar(getstraddr(str1), &ainfo, 0);
5349
5350 arg_ir(ad_icon(n), &ainfo); /* # from strings */
5351 /* JSR */
5352 ili1 = ad2ili(IL_JSR, sym, ainfo.lnk);
5353 end_ainfo(&ainfo);
5354 return ili1;
5355 }
5356
5357 static int
block_str_move(STRDESC * str1,STRDESC * str2)5358 block_str_move(STRDESC *str1, STRDESC *str2)
5359 {
5360 int len;
5361 int bfill;
5362 int nb;
5363 ISZ_T off;
5364 int addr1, addr2;
5365 int a1, a2;
5366 int ili1;
5367
5368 ili1 = 0;
5369 len = str1->lval;
5370 if (len <= str2->lval)
5371 bfill = 0;
5372 else {
5373 bfill = len - str2->lval;
5374 len = str2->lval;
5375 }
5376 addr1 = getstraddr(str1);
5377 addr2 = getstraddr(str2);
5378 off = 0;
5379 while (true) {
5380 if (ili1)
5381 chk_block(ili1);
5382 if (len > 7) {
5383 nb = 8;
5384 } else if (len > 3) {
5385 nb = 4;
5386 } else if (len > 1) {
5387 nb = 2;
5388 } else {
5389 nb = 1;
5390 }
5391 a1 = ad3ili(IL_AADD, addr1, ad_aconi(off), 0);
5392 a2 = ad3ili(IL_AADD, addr2, ad_aconi(off), 0);
5393 switch (nb) {
5394 case 8:
5395 ili1 = ad3ili(IL_LDKR, a2, NME_STR1, MSZ_I8);
5396 ili1 = ad4ili(IL_STKR, ili1, a1, NME_STR1, MSZ_I8);
5397 break;
5398 case 4:
5399 ili1 = ad3ili(IL_LD, a2, NME_STR1, MSZ_WORD);
5400 ili1 = ad4ili(IL_ST, ili1, a1, NME_STR1, MSZ_WORD);
5401 break;
5402 case 2:
5403 ili1 = ad3ili(IL_LD, a2, NME_STR1, MSZ_UHWORD);
5404 ili1 = ad4ili(IL_ST, ili1, a1, NME_STR1, MSZ_UHWORD);
5405 break;
5406 default:
5407 ili1 = ad3ili(IL_LD, a2, NME_STR1, MSZ_BYTE);
5408 ili1 = ad4ili(IL_ST, ili1, a1, NME_STR1, MSZ_BYTE);
5409 break;
5410 }
5411 len -= nb;
5412 if (len <= 0)
5413 break;
5414 off += nb;
5415 }
5416 if (bfill) {
5417 len = bfill;
5418 off = str2->lval;
5419 while (true) {
5420 if (ili1)
5421 chk_block(ili1);
5422 if (len > 7) {
5423 ili1 = ad_kcon(0x20202020, 0x20202020);
5424 nb = 8;
5425 } else if (len > 3) {
5426 ili1 = ad_icon(0x20202020);
5427 nb = 4;
5428 } else if (len > 1) {
5429 ili1 = ad_icon(0x2020);
5430 nb = 2;
5431 } else {
5432 ili1 = ad_icon(0x20);
5433 nb = 1;
5434 }
5435 a1 = ad3ili(IL_AADD, addr1, ad_aconi(off), 0);
5436 switch (nb) {
5437 case 8:
5438 ili1 = ad4ili(IL_STKR, ili1, a1, NME_STR1, MSZ_I8);
5439 break;
5440 case 4:
5441 ili1 = ad4ili(IL_ST, ili1, a1, NME_STR1, MSZ_WORD);
5442 break;
5443 case 2:
5444 ili1 = ad4ili(IL_ST, ili1, a1, NME_STR1, MSZ_UHWORD);
5445 break;
5446 default:
5447 ili1 = ad4ili(IL_ST, ili1, a1, NME_STR1, MSZ_BYTE);
5448 break;
5449 }
5450 len -= nb;
5451 if (len <= 0)
5452 break;
5453 off += nb;
5454 }
5455 }
5456 return ili1;
5457 }
5458
5459 /** \brief Determine if it's possible that the lhs & rhs of a string/character
5460 * assignment can overlap.
5461 *
5462 * Note that for now, an assumed-size char lhs is not a candidate since its
5463 * STRDESC is not marked 'asivar'.
5464 */
5465 static bool
strovlp(STRDESC * lhs,STRDESC * rhs)5466 strovlp(STRDESC *lhs, STRDESC *rhs)
5467 {
5468 int rsym;
5469 int lsym;
5470
5471 if (rhs->next != NULL) /* single rhs only */
5472 return true;
5473 if (!rhs->aisvar) /* rhs must be simple var or constant */
5474 return true;
5475 rsym = CONVAL1G(rhs->aval);
5476 if (rsym == 0)
5477 return true;
5478 if (STYPEG(rsym) == ST_CONST)
5479 /* constants never overlaps */
5480 return false;
5481 if (!lhs->aisvar) /* lhs must be simple var */
5482 return true;
5483 lsym = CONVAL1G(lhs->aval);
5484 if (lsym == 0)
5485 return true;
5486 if (lsym != rsym) /* lhs & rhs variables must be different */
5487 return false;
5488 return true;
5489 }
5490
5491 static char *
getcharconst(STRDESC * str)5492 getcharconst(STRDESC *str)
5493 {
5494 int asym;
5495 int sym;
5496 char *p;
5497
5498 if (!str->aisvar || !str->liscon)
5499 return NULL;
5500 asym = str->aval;
5501 sym = CONVAL1G(asym);
5502 if (sym == 0 || STYPEG(sym) != ST_CONST)
5503 return NULL;
5504 p = stb.n_base + (CONVAL1G(sym) + CONVAL2G(asym));
5505 return p;
5506 }
5507
5508 /*
5509 * fortran compare of strings a1 & a2; returns:
5510 * 0 => strings are the same
5511 * -1 => a1 lexically less than a2
5512 * 1 => a1 lexically greater than a2
5513 * If the lengths of the strings are not equal, the short string is blank
5514 * padded.
5515 */
5516 static int
_fstrcmp(char * a1,char * a2,int len)5517 _fstrcmp(char *a1, char *a2, int len)
5518 {
5519 while (len > 0) {
5520 if (*a1 != *a2) {
5521 if (*a1 > *a2)
5522 return 1;
5523 return -1;
5524 }
5525 ++a1;
5526 ++a2;
5527 --len;
5528 }
5529 return 0;
5530 }
5531
5532 static int
ftn_strcmp(char * a1,char * a2,int a1_len,int a2_len)5533 ftn_strcmp(char *a1, char *a2, int a1_len, int a2_len)
5534 {
5535 int retv;
5536
5537 if (a1_len == a2_len)
5538 return _fstrcmp(a1, a2, a1_len);
5539
5540 if (a1_len > a2_len) {
5541 /* first compare the first a2_len characters of the strings */
5542 retv = _fstrcmp(a1, a2, a2_len);
5543 if (retv)
5544 return retv;
5545 a1 += a2_len;
5546 a1_len -= a2_len;
5547 /*
5548 * if the last (a1_len - a2_len) characters of a1 are blank, then the
5549 * strings are equal; otherwise, compare the first non-blank char. to
5550 * blank
5551 */
5552 while (a1_len > 0) {
5553 if (*a1 != ' ') {
5554 if (*a1 > ' ')
5555 return 1;
5556 return -1;
5557 }
5558 ++a1;
5559 --a1_len;
5560 }
5561 } else {
5562 /* a2_len > a1_len */
5563 /* first compare the first a1_len characters of the strings */
5564 retv = _fstrcmp(a1, a2, a1_len);
5565 if (retv)
5566 return retv;
5567 a2 += a1_len;
5568 a2_len -= a1_len;
5569 /*
5570 * if the last (a2_len - a1_len) characters of a2 are blank, then the
5571 * strings are equal; otherwise, compare the first non-blank char. to
5572 * blank
5573 */
5574 while (a2_len > 0) {
5575 if (*a2 != ' ') {
5576 if (' ' > *a2)
5577 return 1;
5578 return -1;
5579 }
5580 ++a2;
5581 --a2_len;
5582 }
5583 }
5584 return 0;
5585 }
5586
5587 /**
5588 \param ili max size ili
5589 */
5590 static int
getchartmp(int ili)5591 getchartmp(int ili)
5592 {
5593 DTYPE dtype;
5594 SPTR sym = getccsym('T', expb.chartmps++, ST_VAR);
5595 SCP(sym, expb.sc);
5596
5597 if (ili && IL_TYPE(ILI_OPC(ili)) == ILTY_CONS)
5598 dtype = get_type(2, TY_CHAR, CONVAL2G(ILI_OPND(ili, 1)));
5599 else
5600 return allochartmp(ili);
5601 DTYPEP(sym, dtype);
5602 return sym;
5603 }
5604
5605 /**
5606 \param lenili length ili
5607 */
5608 static SPTR
allochartmp(int lenili)5609 allochartmp(int lenili)
5610 {
5611 SPTR sym;
5612 int sptr1;
5613 int dtype;
5614 int ili;
5615 ainfo_t ainfo;
5616 char *str_malloc_nm;
5617 if (CHARLEN_64BIT) {
5618 str_malloc_nm = mkRteRtnNm(RTE_str_malloc_klen);
5619 } else {
5620 str_malloc_nm = mkRteRtnNm(RTE_str_malloc);
5621 }
5622
5623 if (allocharhdr == 0) {
5624 /* create a symbol to represent the head of list of allocated
5625 * areas created by the run-time (ftn_str_malloc()). This variable
5626 * will be initialized in each entry and the list of allocated areas
5627 * will be freed at the end of each subprogram.
5628 */
5629 int ili;
5630 allocharhdr = getccsym('T', expb.chartmps++, ST_VAR);
5631 SCP(allocharhdr, SC_LOCAL);
5632 DTYPEP(allocharhdr, DT_ADDR);
5633 ADDRTKNP(allocharhdr, 1);
5634 }
5635 sym = getccsym('T', expb.chartmps++, ST_VAR);
5636 SCP(sym, SC_LOCAL);
5637
5638 init_ainfo(&ainfo);
5639 /* space <- ftn_str_malloc(lenili, &allocharhdr) */
5640 sptr1 = frte_func(mkfunc, str_malloc_nm);
5641 /***** remember that arguments are in reverse order *****/
5642 arg_ar(ad_acon(allocharhdr, 0), &ainfo, 0);
5643 arg_ir(lenili, &ainfo);
5644 /* JSR */
5645 DTYPEP(sptr1, DT_ADDR);
5646 ili = ad2ili(IL_JSR, sptr1, ainfo.lnk);
5647 ili = ad2ili(IL_DFRAR, ili, AR(0));
5648 ili = ad3ili(IL_STA, ili, ad_acon(sym, 0), addnme(NT_VAR, sym, 0, 0));
5649 end_ainfo(&ainfo);
5650 iltb.callfg = 1;
5651 chk_block(ili);
5652
5653 DTYPEP(sym, DT_ADDR);
5654 return sym;
5655 }
5656
5657 static STRDESC *
getstr(int ilm)5658 getstr(int ilm)
5659 {
5660 ILM *ilmp;
5661 int addrili, lenili, opc;
5662 STRDESC *list1, *list2, *item;
5663
5664 /* get string descriptor for string ILM */
5665 ilmp = (ILM *)(ilmb.ilm_base + ilm);
5666 if (ILM_OPC(ilmp) == IM_SCAT || ILM_OPC(ilmp) == IM_NSCAT) {
5667 list1 = getstr(ILM_OPND(ilmp, 1));
5668 list2 = getstr(ILM_OPND(ilmp, 2));
5669 item = list1;
5670 list1->cnt += list2->cnt;
5671 while (list1->next)
5672 list1 = list1->next;
5673 list1->next = list2;
5674 if (ILM_OPC(ilmp) == IM_NSCAT)
5675 item->dtype = TY_NCHAR;
5676 } else {
5677 item = (STRDESC *)getitem(STR_AREA, sizeof(STRDESC));
5678 addrili = ILM_RESULT(ilm);
5679 lenili = ILM_CLEN(ilm);
5680 if (IL_TYPE(ILI_OPC(addrili)) == ILTY_CONS &&
5681 SCG(CONVAL1G(ILI_OPND(addrili, 1))) != SC_DUMMY) {
5682 item->aisvar = true;
5683 item->aval = ILI_OPND(addrili, 1);
5684 } else {
5685 item->aisvar = false;
5686 item->aval = addrili;
5687 }
5688 if (IL_TYPE(ILI_OPC(lenili)) == ILTY_CONS) {
5689 item->liscon = true;
5690 item->lval = CONVAL2G(ILI_OPND(lenili, 1));
5691 } else {
5692 item->liscon = false;
5693 item->lval = lenili;
5694 }
5695 item->next = 0;
5696 item->cnt = 1;
5697 item->dtype = TY_CHAR;
5698 opc = ILM_OPC(ilmp);
5699 if (opc == IM_NCHAR || opc == IM_NSUBS || opc == IM_NCHFUNC ||
5700 opc == IM_NSPSEUDOST)
5701 item->dtype = TY_NCHAR;
5702 else if ((ilm = getrval(ilm))) { /* returns sptr or 0 */
5703 DTYPE dtype = DTYPEG(ilm);
5704 if (DTY(dtype) == TY_ARRAY)
5705 dtype = DTySeqTyElement(dtype);
5706 if (DTY(dtype) == TY_NCHAR)
5707 item->dtype = TY_NCHAR;
5708 }
5709 }
5710
5711 return item;
5712 }
5713
5714 static STRDESC *
getstrconst(char * str,int len)5715 getstrconst(char *str, int len)
5716 {
5717 SPTR s0;
5718 STRDESC *item;
5719
5720 s0 = getstring(str, len);
5721 item = (STRDESC *)getitem(STR_AREA, sizeof(STRDESC));
5722 item->aisvar = true;
5723 item->aval = get_acon(s0, 0);
5724 item->liscon = true;
5725 item->lval = len;
5726 item->next = 0;
5727 item->cnt = 1;
5728 item->dtype = TY_CHAR;
5729 return item;
5730 }
5731
5732 static STRDESC *
storechartmp(STRDESC * str,int mxlenili,int clenili)5733 storechartmp(STRDESC *str, int mxlenili, int clenili)
5734 {
5735 INT val[2];
5736 STRDESC *item;
5737 int ilix;
5738 int msz;
5739 int lenili;
5740
5741 msz = MSZ_BYTE;
5742 if (mxlenili)
5743 lenili = mxlenili;
5744 else
5745 lenili = clenili;
5746 if (str->dtype == TY_NCHAR) {
5747 ilix = ad_icon(2L);
5748 lenili = ad2ili(IL_IMUL, ilix, lenili);
5749 msz = MSZ_UHWORD;
5750 }
5751 item = (STRDESC *)getitem(STR_AREA, sizeof(STRDESC));
5752 val[1] = 0;
5753 if (mxlenili) {
5754 val[0] = getchartmp(lenili);
5755 item->aval = getcon(val, DT_ADDR);
5756 item->aisvar = true;
5757 } else {
5758 SPTR sym = allochartmp(lenili);
5759 ilix = ad_acon(sym, 0);
5760 ilix = ad2ili(IL_LDA, ilix, addnme(NT_VAR, sym, 0, 0));
5761 item->aval = ilix;
5762 item->aisvar = false;
5763 }
5764 if (IL_TYPE(ILI_OPC(clenili)) == ILTY_CONS) {
5765 item->liscon = true;
5766 item->lval = CONVAL2G(ILI_OPND(clenili, 1));
5767 } else {
5768 item->liscon = false;
5769 item->lval = clenili;
5770 }
5771
5772 item->dtype = str->dtype;
5773 item->next = 0;
5774 item->cnt = 1;
5775 if (strislen1(item)) {
5776 ilix = ad3ili(IL_LD, getstraddr(str), NME_STR1, msz);
5777 ilix = ad4ili(IL_ST, ilix, getstraddr(item), NME_STR1, msz);
5778 chk_block(ilix);
5779 return (item);
5780 }
5781 /* generate call to store str into item */
5782 iltb.callfg = 1;
5783 chk_block(exp_strcpy(item, str));
5784 return (item);
5785 }
5786
5787 /**
5788 * \brief return ili for character length of passed length dummy.
5789 */
5790 int
charlen(SPTR sym)5791 charlen(SPTR sym)
5792 {
5793 int iliptr;
5794 SPTR lensym;
5795 int nme;
5796 int addr;
5797
5798 lensym = CLENG(sym);
5799 if (!INTERNREFG(lensym) && gbl.internal > 1 && INTERNREFG(sym)) {
5800 /* Its len is passed by value in aux.curr_entry->display after sym */
5801 addr = mk_charlen_address(sym);
5802 } else if (PARREFG(lensym) && PASSBYVALG(lensym) && gbl.outlined) {
5803 addr = mk_charlen_parref_sptr(sym);
5804 } else
5805 {
5806 addr = mk_address(lensym);
5807 }
5808 if (DTYPEG(lensym) == DT_INT8)
5809 return ad3ili(IL_LDKR, addr, addnme(NT_VAR, lensym, 0, 0), MSZ_I8);
5810 return ad3ili(IL_LD, addr, addnme(NT_VAR, lensym, 0, 0), MSZ_WORD);
5811 }
5812
5813 /**
5814 * \brief Return ili for character addr of passed length dummy.
5815 */
5816 int
charaddr(SPTR sym)5817 charaddr(SPTR sym)
5818 {
5819 SPTR asym;
5820 int addr;
5821
5822 assert(SCG(sym) == SC_DUMMY, "charaddr: sym not dummy", sym, ERR_Severe);
5823 asym = mk_argasym(sym);
5824 addr = mk_address(sym);
5825
5826 /* We already do a load address in mk_address */
5827 if (INTERNREFG(sym) && gbl.internal > 1)
5828 return addr;
5829 if (PARREFG(sym) && SCG(sym) == SC_DUMMY && gbl.outlined)
5830 return addr;
5831 return ad2ili(IL_LDA, addr, addnme(NT_VAR, asym, 0, 0));
5832 }
5833
5834 /********************************************************************/
5835
5836 /**
5837 \param entbih bih of the entry block
5838 \param exitbih bih of the exit block
5839
5840 Check if this function is a terminal routine (one that does not call any
5841 other routines). If so, the necessary changes will be made to the entry and
5842 exit blocks. This optimization depends on the target machine and its
5843 execution environment. It is appropriate when the target does not have
5844 instructions to manipulate the stack; multiple instructions have to be
5845 generated to allocate stack space, manipulate the frame and stack pointers,
5846 and to check for overflow and underflow.
5847
5848 When the terminal function optimization is appropriate, the following
5849 applies:
5850
5851 1. exceptions and global registers are not used:
5852 a. if the routine is terminal, static space is used in lieu of the
5853 stack. ILIs QENTRY and QEXIT are used.
5854 b. otherwise, faster entry and exit routines, c_i_qentry and
5855 c_i_qexit, are used. The ENTRY ili is modified to locate
5856 c_i_qentry, and a new EXIT ili locating c_i_qexit is generated.
5857 2. otherwise, the ENTRY and EXIT ILIs are left as is.
5858
5859 When the terminal function optimization is not appropriate, the following
5860 applies:
5861
5862 1. if exceptions and global registers are not used, the faster entry and
5863 exit routines, c_i_qentry and c_i_qexit, are used. The ILIs QENTRY and
5864 QEXIT are used.
5865 2. otherwise, the ENTRY and EXIT ILIs are left as is.
5866
5867 The -q 0 256 switch forces full entry and exit to be used.
5868 The -q 0 4096 switch forces QENTRY and QEXIT to be used for all
5869 routines.
5870 */
5871 void
chk_terminal_func(int entbih,int exitbih)5872 chk_terminal_func(int entbih, int exitbih)
5873 {
5874 aux.curr_entry->auto_array = 0;
5875 }
5876
5877 /*------------------------------------------------------------------*/
5878
5879 /**
5880 \param ir number of integer regs used as arguments
5881 \param fr number of floating point regs used as arguments
5882
5883 Perform the necessary adjustments regarding the number of argument registers
5884 used by a jsr/qsr added after the expand phase and before the optimizer
5885 (i.e., by the vectorizer). An argument to the current function must be
5886 stored in memory if it has been marked by expand as a register argument and
5887 if its register is used by the jsr/qjr. Also, the available set of
5888 arg/scratch registers that can be used as globals by the optimizer must be
5889 updated.
5890 */
5891 void
exp_reset_argregs(int ir,int fr)5892 exp_reset_argregs(int ir, int fr)
5893 {
5894 }
5895
5896 /**
5897 * \brief Create & add an ILT for an ILI when transforming GSMOVE ILI
5898 */
5899 static void
gsmove_chk_block(int ili)5900 gsmove_chk_block(int ili)
5901 {
5902 gsmove_ilt = addilt(gsmove_ilt, ili);
5903 }
5904
5905 /*------------------------------------------------------------------*/
5906
5907 #undef ILM_OPC
5908 #undef ILM_OPND
5909 #define ILM_OPC(i) ilmb.ilm_base[i]
5910 #define ILM_OPND(i, n) ilmb.ilm_base[i + n]
5911 #ifdef __cplusplus
ILM_SymOPND(int i,int n)5912 inline SPTR ILM_SymOPND(int i, int n) {
5913 return static_cast<SPTR>(ILM_OPND(i, n));
5914 }
5915 #else
5916 #define ILM_SymOPND ILM_OPND
5917 #endif
5918
5919 void
AssignAddresses(void)5920 AssignAddresses(void)
5921 {
5922 int opc;
5923 reset_global_ilm_position();
5924 do {
5925 int ilmx, len;
5926 int numilms = rdilms();
5927 if (numilms == 0)
5928 break;
5929 for (ilmx = 0; ilmx < numilms; ilmx += len) {
5930 int flen, opnd;
5931 opc = ILM_OPC(ilmx);
5932 flen = len = ilms[opc].oprs + 1;
5933 if (IM_VAR(opc)) {
5934 len += ILM_OPND(ilmx, 1);
5935 }
5936 /* is this a variable reference */
5937 for (opnd = 1; opnd <= flen; ++opnd) {
5938 if (IM_OPRFLAG(opc, opnd) == OPR_SYM) {
5939 SPTR sptr = ILM_SymOPND(ilmx, opnd);
5940 if (sptr > SPTR_NULL && sptr < stb.stg_avail) {
5941 switch (STYPEG(sptr)) {
5942 case ST_CONST:
5943 sym_is_refd(sptr);
5944 break;
5945 case ST_VAR:
5946 case ST_ARRAY:
5947 case ST_STRUCT:
5948 case ST_UNION:
5949 switch (SCG(sptr)) {
5950 case SC_AUTO:
5951 if (!CCSYMG(sptr) && (DINITG(sptr) || SAVEG(sptr))) {
5952 SCP(sptr, SC_STATIC);
5953 sym_is_refd(sptr);
5954 }
5955 break;
5956 case SC_STATIC:
5957 if (!CCSYMG(sptr)) {
5958 sym_is_refd(sptr);
5959 }
5960 break;
5961 default:
5962 break;
5963 }
5964 default:
5965 break;
5966 }
5967 }
5968 }
5969 }
5970 }
5971 } while (opc != IM_END && opc != IM_ENDF);
5972 reset_global_ilm_position();
5973 }
5974