1 /*
2 * Copyright (c) 2016-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 FIXME - document what this is
21 */
22
23 #include "ll_ftn.h"
24 #include "exp_rte.h"
25 #include "ili.h"
26 #include "dinit.h"
27 #include "cg.h"
28 #include "x86.h"
29 #include "fih.h"
30 #include "pd.h"
31 #include "llutil.h"
32 #include <stdlib.h>
33 #include "expand.h"
34 #include "llassem.h"
35 #include "cgllvm.h"
36 #include "cgmain.h"
37 #include "symfun.h"
38
39 /* debug switches:
40 -Mq,11,16 dump ili right before ILI -> LLVM translation
41 -Mq,12,16 provides dinit info, ilt trace, and some basic preprocessing info
42 -Mq,12,32 provides complete flow debug info through the LLVM routines
43 */
44
45 #define DBGTRON DBGBIT(12, 0x20)
46 #define DBGTRACEIN(str) DBGXTRACEIN(DBGTRON, 1, str)
47 #define DBGTRACEOUT(str) DBGXTRACEOUT(DBGTRON, 1, str)
48 #define DBGDUMPLLTYPE(str, llt) DBGXDUMPLLTYPE(DBGTRON, 1, str, llt)
49 #define DBGTRACE5(str, p1, p2, p3, p4, p5) \
50 DBGXTRACE5(DBGTRON, 1, str, p1, p2, p3, p4, p5)
51
52 #define MAXARGLEN 256
53 #define LLVM_SHORTTERM_AREA 14
54
55 typedef struct char_len {
56 SPTR sptr;
57 struct char_len *next;
58 } sclen;
59
60 SPTR master_sptr = SPTR_NULL;
61
62 static ISZ_T f90_equiv_sz = 0;
63 static LL_Type *equiv_type;
64 static char *equiv_var;
65
66 bool
need_charlen(DTYPE dtype)67 need_charlen(DTYPE dtype)
68 {
69 TY_KIND dty = DTYG(dtype);
70 switch (dty) {
71 case TY_CHAR:
72 case TY_NCHAR:
73 return true;
74 case TY_PTR:
75 if (DTY(DTySeqTyElement(dtype)) == TY_CHAR)
76 return true;
77 else if (DTY(DTySeqTyElement(dtype)) == TY_NCHAR)
78 return true;
79 default:
80 return false;
81 }
82 return false;
83 }
84
85 static int
get_func_altili(int ilix)86 get_func_altili(int ilix)
87 {
88 if (ILI_ALT(ilix) && ILI_OPC(ILI_ALT(ilix)) == IL_GJSR)
89 return ILI_ALT(ilix);
90 return 0;
91 }
92
93 /**
94 \brief return argument dtype in IL GJSR , expect ili derived from IL_GJSR
95 */
96 static int
get_altili_dtype(int param_ili)97 get_altili_dtype(int param_ili)
98 {
99 if (ILI_OPC(param_ili) != IL_NULL)
100 return ILI_OPND(param_ili, 3);
101 return 0;
102 }
103
104 bool
is_fastcall(int ilix)105 is_fastcall(int ilix)
106 {
107 switch (ILI_OPC(ilix)) {
108 case IL_QJSR: /* sym lnk */
109 case IL_JSR: /* sym lnk */
110 case IL_JSRA: /* arlnk lnk stc , arlnk is the address of function */
111 switch (ILI_OPC(ILI_OPND(ilix, 2))) {
112 /* mth_i_ .. routines? */
113 case IL_DADP: /* dplnk dp lnk */
114 case IL_DASP: /* splnk sp lnk */
115 case IL_DACS: /* cslnk cs lnk */
116 case IL_DACD: /* cdlnk cd lnk */
117 return true;
118 }
119 break;
120 default:
121 break;
122 }
123 return false;
124 }
125
126 static void
stb_process_iface_chlen(int sptr)127 stb_process_iface_chlen(int sptr)
128 {
129 int i;
130 int e = sptr;
131 int dpdsc = DPDSCG(e);
132 int paramct = PARAMCTG(e);
133
134 for (i = 0; i < paramct; ++i) {
135 int param = aux.dpdsc_base[dpdsc + i];
136 int dtype = DDTG(DTYPEG(param));
137 if (dtype == DT_DEFERCHAR || dtype == DT_DEFERNCHAR) {
138 if (!CLENG(param)) {
139 int clen = getdumlen();
140 CLENP(param, clen);
141 if (PARREFG(param))
142 PARREFP(clen, 1);
143 }
144 } else if (dtype == DT_ASSCHAR || dtype == DT_ASSNCHAR) {
145 if (!CLENG(param)) {
146 int clen = getdumlen();
147 CLENP(param, clen);
148 if (PARREFG(param))
149 PARREFP(clen, 1);
150 }
151 }
152 }
153 }
154
155 void
stb_process_routine_parameters(void)156 stb_process_routine_parameters(void)
157 {
158 SPTR fsptr;
159
160 ll_process_routine_parameters(gbl.currsub);
161 /* Process Entry */
162 for (fsptr = SYMLKG(gbl.currsub); fsptr > NOSYM; fsptr = SYMLKG(fsptr)) {
163 stb_process_iface_chlen(fsptr); /* fix up char len dummy args */
164 ll_process_routine_parameters(fsptr);
165 }
166 }
167
168 char *
get_llvm_ifacenm(SPTR sptr)169 get_llvm_ifacenm(SPTR sptr)
170 {
171 char *nm = (char *)getitem(LLVM_LONGTERM_AREA, MAXARGLEN);
172 strcpy(nm, get_llvm_name(sptr));
173 #if DEBUG
174 assert((strlen(get_llvm_name(gbl.currsub)) + strlen(get_llvm_name(sptr)) +
175 4) < MAXARGLEN,
176 "get_llvm_ifacenm: name too long", sptr, ERR_Fatal);
177 #endif
178 return nm;
179 }
180
181 /* Given an sptr, return the iface if it exists, or 0 otherwise */
182 SPTR
get_iface_sptr(SPTR sptr)183 get_iface_sptr(SPTR sptr)
184 {
185 const DTYPE dtype = DTYPEG(sptr);
186 if (DTY(dtype) == TY_PTR && DTY(DTySeqTyElement(dtype)) == TY_PROC)
187 return DTyInterface(DTySeqTyElement(dtype));
188 return SPTR_NULL;
189 }
190
191 /* Returns the Fortran representation of a function name, taking into account if
192 * the function is an interface.
193 *
194 * CAUTION XXX: This returns a pointer from get_llvm_name, which returns a stack
195 * address.
196 */
197 static const char *
get_ftn_func_name(SPTR func_sptr,bool * has_iface)198 get_ftn_func_name(SPTR func_sptr, bool *has_iface)
199 {
200 *has_iface = false;
201 if (func_sptr != gbl.currsub) {
202 if (!gbl.currsub)
203 return NULL;
204 if (SCG(func_sptr) == SC_EXTERN || INMODULEG(func_sptr) ||
205 OUTLINEDG(func_sptr) ||
206 ((STYPEG(func_sptr) == ST_ENTRY) &&
207 has_multiple_entries(gbl.currsub))) {
208 return get_llvm_name(func_sptr); /* module subroutine */
209 }
210 /* interface name to be hashed has the format:
211 * <get_llvm_name(gbl.currsub)>_$_<get_llvm_name(func_sptr)>
212 */
213 *has_iface = true;
214 return get_llvm_ifacenm(func_sptr);
215 } else if ((gbl.internal == 1) && (gbl.rutype == RU_PROG)) {
216 return get_main_progname();
217 }
218 return get_llvm_name(func_sptr);
219 }
220
221 /** \brief Called by ll_process_routine_parameters() to generate a pass by
222 * reference parameter.
223 */
224 static void
gen_ref_arg(SPTR param_sptr,SPTR func_sptr,LL_Type * ref_dummy,int param_num,SPTR gblsym)225 gen_ref_arg(SPTR param_sptr, SPTR func_sptr, LL_Type *ref_dummy, int param_num,
226 SPTR gblsym)
227 {
228 LL_Type *llt;
229 if (OUTLINEDG(func_sptr))
230 llt = make_ptr_lltype(make_lltype_from_dtype(DTYPEG(param_sptr)));
231 else
232 llt = ref_dummy;
233 addag_llvm_argdtlist(gblsym, param_num, param_sptr, llt);
234 }
235
236 void
ll_process_routine_parameters(SPTR func_sptr)237 ll_process_routine_parameters(SPTR func_sptr)
238 {
239 int params, sc;
240 SPTR param_sptr;
241 DTYPE dtype;
242 DTYPE return_dtype;
243 DTYPE param_dtype;
244 SPTR gblsym;
245 SPTR fval;
246 SPTR clen;
247 int param_num;
248 DTYPE ref_dtype;
249 LL_ABI_Info *abi;
250 sclen *t_len, *pd_len = NULL, *pd_len_last = NULL, *c_len = NULL;
251 bool update;
252 bool iface = false;
253 const char *nm;
254 LL_Type *ref_dummy;
255 bool hiddenarg = true;
256 SPTR display_temp = SPTR_NULL;
257
258 if (func_sptr < 1)
259 return;
260 /* If we already processed this and the func_sptr is for a differnt function
261 * being compiled, then return early. Else, we need to update the sptrs in
262 * the AG table for the LL_ABI.
263 */
264 nm = get_ftn_func_name(func_sptr, &iface);
265 assert(nm, "get_ftn_func_name(): Could not find name", func_sptr, ERR_unused);
266 gblsym = find_ag(nm);
267 update = ((gblsym &&
268 (gbl.currsub == func_sptr || get_master_sptr() == func_sptr)) ||
269 STYPEG(func_sptr) == ST_ENTRY);
270 if (gblsym && !update && is_llvmag_entry(gblsym))
271 return;
272
273 if (!gblsym) {
274 gblsym = iface ? get_llvm_funcptr_ag(func_sptr, nm) : get_ag(func_sptr);
275 }
276
277 if (!update && (abi = ll_proto_get_abi(ll_proto_key(func_sptr))) &&
278 abi->nargs)
279 return;
280
281 /* It is possible that we have ag but it is not ST_ENTRY */
282 if (STYPEG(func_sptr) == ST_ENTRY)
283 set_llvmag_entry(gblsym);
284
285 /* At this point, we have a valid gblsym, perhaps already processed. We
286 * still need to update the AG table sptr entries if the func_sptr being
287 * processed is this function.
288 */
289 clen = SPTR_NULL;
290 c_len = NULL;
291 t_len = NULL;
292
293 /* Store return type (if we are overriding get_return_dtype()) */
294 if (gbl.arets && (!CFUNCG(func_sptr))) {
295 return_dtype = DT_INT;
296 set_ag_return_lltype(gblsym, make_lltype_from_dtype(return_dtype));
297 } else {
298 return_dtype = get_return_type(func_sptr);
299 }
300 sc = SCG(func_sptr);
301
302 DBGTRACEIN("")
303 DBGTRACE5("#function \"%s\" (%s), sptr %d returning dtype=%d(%s)",
304 get_llvm_name(func_sptr), stb.scnames[sc], func_sptr, return_dtype,
305 stb.tynames[DTY(return_dtype)])
306
307 params = PARAMCTG(func_sptr);
308 fval = FVALG(func_sptr);
309 clen = SPTR_NULL;
310 c_len = NULL;
311 param_num = 0;
312
313 /* Create a dummy LL_Type for use when passing by ref.
314 * This will either be a i32* or i64*.
315 */
316 ref_dtype = generic_dummy_dtype();
317 ref_dummy = make_generic_dummy_lltype();
318
319 /* If an internal function */
320 if ((gbl.internal > 1 && STYPEG(func_sptr) == ST_ENTRY) &&
321 !OUTLINEDG(func_sptr)) {
322 /* get the display variable. This will be the last argument. */
323 display_temp = aux.curr_entry->display;
324 if (aux.curr_entry->display) {
325 display_temp = aux.curr_entry->display;
326 DTYPEP(display_temp, ref_dtype); /* fake type */
327 } else {
328 display_temp = getccsym('S', gbl.currsub, ST_VAR);
329 /* we won't make type as at the time we generate the prototype, we don't
330 * know
331 * what members it has.
332 */
333 SCP(display_temp, SC_DUMMY);
334 DTYPEP(display_temp, ref_dtype); /* fake type */
335 }
336 }
337
338 if (fval) {
339 bool nchar = false;
340 TY_KIND ThisIsABug; // FIXME
341 param_dtype = DTYPEG(fval);
342 ThisIsABug = DTY(param_dtype);
343 dtype = (DTYPE)ThisIsABug; // FIXME
344 if (DT_ISCMPLX(param_dtype)) {
345 if (XBIT(70, 0x40000000) && (CFUNCG(func_sptr) || CMPLXFUNC_C)) {
346 if ((POINTERG(fval) || ALLOCATTRG(fval)) &&
347 SCG(MIDNUMG(fval)) == SC_DUMMY)
348 hiddenarg = true;
349 else
350 hiddenarg = false;
351 }
352 } else if (CFUNCG(func_sptr) && DTY(param_dtype) == TY_STRUCT) {
353 hiddenarg = false;
354 }
355
356 nchar = (DTYG(param_dtype) == TY_NCHAR ||
357 (dtype == TY_PTR && DTySeqTyElement(dtype) == DT_NCHAR));
358 if (DTYG(param_dtype) == TY_CHAR ||
359 (dtype == TY_PTR && DTySeqTyElement(dtype) == DT_CHAR) || nchar) {
360 /* If func_sptr has return type(that is not 0), len is put right after
361 * return fval
362 * else len is put as normal argument - the end of all arguments.
363 */
364 addag_llvm_argdtlist(gblsym, param_num, fval, ref_dummy);
365 ++param_num;
366
367 clen = CLENG(fval);
368 if (!clen) {
369 clen = getdumlen();
370 CLENP(fval, clen);
371 } else if (SCG(clen) == SC_LOCAL) {
372 clen = getdumlen();
373 CLENP(fval, clen);
374 }
375 if (PARREFG(fval))
376 PARREFP(clen, 1);
377 if (DTYPEG(func_sptr)) {
378 /* fixed size length, put size immediately after return value
379 */
380 addag_llvm_argdtlist(gblsym, param_num, clen,
381 make_lltype_from_dtype(DTYPEG(clen)));
382 ++param_num;
383 } else {
384 if (c_len) {
385 t_len->next = (sclen *)getitem(LLVM_SHORTTERM_AREA, sizeof(sclen));
386 t_len = t_len->next;
387 } else {
388 c_len = (sclen *)getitem(LLVM_SHORTTERM_AREA, sizeof(sclen));
389 t_len = c_len;
390 }
391 t_len->sptr = clen;
392 t_len->next = NULL;
393 }
394 } else if (TY_ARRAY == DTY(param_dtype) ||
395 (TY_STRUCT == DTY(param_dtype) && !CFUNCG(func_sptr)) ||
396 (((SCG(fval) == SC_BASED) || (SCG(fval) == SC_DUMMY)) &&
397 POINTERG(fval)) ||
398 (((SCG(fval) == SC_BASED) || (SCG(fval) == SC_DUMMY)) &&
399 ALLOCATTRG(fval)) ||
400 ((hiddenarg) && is_struct_kind(param_dtype, true, true))) {
401
402 if (MIDNUMG(fval) && SCG(MIDNUMG(fval)) == SC_DUMMY)
403 fval = MIDNUMG(fval);
404 addag_llvm_argdtlist(gblsym, param_num, fval, ref_dummy);
405 ++param_num;
406 clen = (SPTR)1;
407 }
408 }
409
410 if (params) {
411 bool has_char_args = func_has_char_args(func_sptr);
412 SPTR *dpdscp = (SPTR *)(aux.dpdsc_base + DPDSCG(func_sptr));
413
414 /* Get a temporary abi so that we can call our abi classifiers */
415 abi = ll_abi_alloc(cpu_llvm_module, params);
416 abi->is_fortran = true;
417
418 while (params--) {
419 param_sptr = *dpdscp++;
420 if (param_sptr) {
421 if (param_sptr == FVALG(func_sptr))
422 continue;
423 clen = (SPTR)1;
424 param_dtype = DTYPEG(param_sptr);
425 if (DTY(param_dtype) == TY_STRUCT && is_iso_cptr(param_dtype)) {
426 param_dtype = DT_ADDR;
427 }
428 /* For string, need to ut length */
429 if (!PASSBYVALG(param_sptr) &&
430 (DTYG(param_dtype) == TY_CHAR || DTYG(param_dtype) == TY_NCHAR)) {
431 SPTR len = CLENG(param_sptr);
432 if ((len <= NOSYM) || (SCG(len) == SC_NONE) ||
433 (SCG(len) == SC_LOCAL)) {
434 len = getdumlen();
435 CLENP(param_sptr, len);
436 }
437 if (PARREFG(param_sptr))
438 PARREFP(len, 1);
439 PASSBYVALP(len, 1);
440 if (len) {
441 if (c_len) {
442 t_len->next =
443 (sclen *)getitem(LLVM_SHORTTERM_AREA, sizeof(sclen));
444 t_len = t_len->next;
445 } else {
446 c_len = (sclen *)getitem(LLVM_SHORTTERM_AREA, sizeof(sclen));
447 t_len = c_len;
448 }
449 t_len->sptr = len;
450 t_len->next = NULL;
451 }
452 } else if (has_char_args && !HAS_OPT_ARGSG(func_sptr) &&
453 IS_PROC_DESCRG(param_sptr)) {
454 /* defer generating procedure descriptor arguments until the end */
455 if (pd_len != NULL) {
456 pd_len_last->next =
457 (sclen *)getitem(LLVM_SHORTTERM_AREA, sizeof(sclen));
458 pd_len_last = pd_len_last->next;
459 } else {
460 pd_len = pd_len_last =
461 (sclen *)getitem(LLVM_SHORTTERM_AREA, sizeof(sclen));
462 }
463 pd_len_last->sptr = param_sptr;
464 pd_len_last->next = NULL;
465 continue;
466 }
467
468 if (!PASSBYVALG(param_sptr)) { /* If pass by reference... */
469 gen_ref_arg(param_sptr, func_sptr, ref_dummy, param_num, gblsym);
470 ++param_num;
471 } else { /* Else, pass by value */
472 LL_Type *type;
473 LL_ABI_ArgInfo arg = {LL_ARG_UNKNOWN};
474 if (is_iso_cptr(DTYPEG(param_sptr)))
475 type = ref_dummy;
476 else {
477 if ((DTY(param_dtype) == TY_CHAR || DTY(param_dtype) == TY_NCHAR) &&
478 (DTyCharLength(param_dtype) == 1)) {
479 type = make_lltype_from_dtype(DT_BINT);
480 } else {
481 ll_abi_classify_arg_dtype(abi, &arg, param_dtype);
482 ll_abi_complete_arg_info(abi, &arg, param_dtype);
483 type = make_lltype_from_abi_arg(&arg);
484 }
485 }
486 addag_llvm_argdtlist(gblsym, param_num, param_sptr, type);
487 ++param_num;
488 }
489 }
490 }
491
492 /* This was just a temporary state to call the classifiers with */
493 ll_abi_free(abi);
494
495 /* print clen */
496 t_len = c_len;
497 while (t_len) {
498 param_dtype = DTYPEG(t_len->sptr);
499 addag_llvm_argdtlist(gblsym, param_num, t_len->sptr,
500 make_lltype_from_dtype(param_dtype));
501 ++param_num;
502 t_len = t_len->next;
503 }
504
505 /* Generate any procedure descriptor arguments. When we have character
506 * length arugments, the procedure descriptor arguments must be generated
507 * at the end.
508 */
509 while (pd_len) {
510 param_sptr = pd_len->sptr;
511 gen_ref_arg(param_sptr, func_sptr, ref_dummy, param_num, gblsym);
512 ++param_num;
513 pd_len = pd_len->next;
514 }
515 }
516
517 if (display_temp != 0) {
518 /* place display_temp as last argument */
519 addag_llvm_argdtlist(gblsym, param_num, display_temp, ref_dummy);
520 ++param_num;
521 }
522
523 if (iface) {
524 set_llvm_iface_oldname(gblsym, get_llvm_name(func_sptr));
525 }
526
527 add_ag_typename(gblsym, char_type(return_dtype, SPTR_NULL));
528 if (gbl.arets && (!CFUNCG(func_sptr)))
529 set_ag_lltype(gblsym, make_lltype_from_dtype(DT_INT));
530
531 /* If we got this far, then we have established an argdtlist, perhaps it is
532 * null with no params, and that is still valid.
533 */
534 set_ag_argdtlist_is_valid(gblsym);
535
536 /* Add the abi */
537 abi = process_ll_abi_func_ftn(func_sptr, true);
538 ll_proto_add_sptr(func_sptr, abi);
539
540 if (flg.smp && OUTLINEDG(func_sptr) && gbl.internal > 1) {
541 ll_shallow_copy_uplevel(gbl.currsub, func_sptr);
542 }
543
544 freearea(LLVM_SHORTTERM_AREA);
545
546 DBGTRACEOUT("")
547 } /* ll_process_routine_parameters */
548
549 /*
550 * same return value as strcmp(str, pattern); pattern is a lower case
551 * string and str may contain upper case characters.
552 */
553 static int
sem_strcmp(char * str,char * pattern)554 sem_strcmp(char *str, char *pattern)
555 {
556 char *p1, *p2;
557 int ch;
558
559 p1 = str;
560 p2 = pattern;
561 do {
562 ch = *p1;
563 if (ch >= 'A' && ch <= 'Z')
564 ch += ('a' - 'A'); /* to lower case */
565 if (ch != *p2)
566 return (ch - *p2);
567 if (ch == '\0')
568 return 0;
569 p1++;
570 p2++;
571 } while (1);
572 }
573
574 int
is_iso_cptr(DTYPE d_dtype)575 is_iso_cptr(DTYPE d_dtype)
576 {
577 int tag;
578 if (DTY(d_dtype) == TY_ARRAY)
579 d_dtype = DTySeqTyElement(d_dtype);
580
581 if (DTY(d_dtype) != TY_STRUCT)
582 return 0;
583
584 tag = DTyAlgTyTag(d_dtype);
585
586 if (ISOCTYPEG(tag))
587 return d_dtype;
588
589 return 0;
590 }
591
592 /**
593 \brief Get the return \c DTYPE of the function, \p func_sptr.
594 \param func_sptr Symbol id of function to examine
595 */
596 DTYPE
get_return_type(SPTR func_sptr)597 get_return_type(SPTR func_sptr)
598 {
599 int fval;
600 DTYPE dtype;
601
602 if ((SCG(func_sptr) == SC_DUMMY) && MIDNUMG(func_sptr))
603 func_sptr = MIDNUMG(func_sptr);
604
605 fval = FVALG(func_sptr);
606 if (fval) {
607 if (POINTERG(fval) || ALLOCATTRG(fval))
608 return DT_NONE;
609 dtype = DTYPEG(fval);
610 } else {
611 dtype = DTYPEG(func_sptr);
612 }
613 if (POINTERG(func_sptr) || ALLOCATTRG(func_sptr))
614 return DT_NONE;
615 switch (DTY(dtype)) {
616 case TY_CHAR:
617 case TY_NCHAR:
618 case TY_ARRAY:
619 return DT_NONE;
620 case TY_STRUCT:
621 case TY_UNION:
622 if (CFUNCG(func_sptr))
623 break;
624 if (is_iso_cptr(dtype))
625 return DT_ADDR;
626 return DT_NONE;
627 case TY_CMPLX:
628 case TY_DCMPLX:
629 if (CFUNCG(func_sptr) || CMPLXFUNC_C)
630 break;
631 return DT_NONE;
632 default:
633 break;
634 }
635 return dtype;
636 }
637
638 void
assign_array_lltype(DTYPE dtype,int size,int sptr)639 assign_array_lltype(DTYPE dtype, int size, int sptr)
640 {
641 LLTYPE(sptr) = make_array_lltype(size, make_lltype_from_dtype(dtype));
642 }
643
644 void
write_llvm_lltype(int sptr)645 write_llvm_lltype(int sptr)
646 {
647 write_type(LLTYPE(sptr));
648 }
649
650 static int
llvm_args_valid(SPTR func_sptr)651 llvm_args_valid(SPTR func_sptr)
652 {
653 /* This is a workaround - there maybe a place in the front end that we don't
654 * process module routine arguments - if that is the case don't put it in ag
655 * table.
656 * it will replace the correct one because we can have same routine multiple
657 * times
658 * in ilm file by use associate.
659 */
660 int valid = 1;
661 int argcnt = PARAMCTG(func_sptr);
662 int fval = FVALG(func_sptr);
663 DTYPE dtype;
664
665 if (!fval)
666 return valid;
667
668 if (CFUNCG(func_sptr))
669 return valid;
670
671 if (argcnt) {
672 int *dpdscp = (int *)(aux.dpdsc_base + DPDSCG(func_sptr));
673 if (fval == *dpdscp)
674 return valid;
675
676 dtype = get_return_type(func_sptr);
677 if (dtype == 0 && DTYPEG(fval) != 0)
678 return 0;
679 }
680
681 return valid;
682 }
683
684 void
fix_llvm_fptriface(void)685 fix_llvm_fptriface(void)
686 {
687 /* Process function interface and store in ag table - need to do when process
688 stb file
689 because
690 0. This function needs to be called in main even without code.
691 1. All function info must be in ag table already so that vft processing
692 can get correct function signature.
693 2. For inlining(i.e., ieee03), Currently when we read symbol from inlining
694 ilm
695 we have no information about that symbol at all, we then put incorrect
696 info
697 in ag table. If we process the stb file, we normally have interface
698 information at that time, so correct function info is stored in ag
699 table first. When we subsequently inline this function, we would get
700 correct info from ag table.
701 */
702
703 DTYPE dtype;
704 int dt;
705 SPTR sptr;
706 SPTR iface;
707 char *ifacenm;
708
709 if (!gbl.currsub)
710 return;
711
712 if (!gbl.stbfil)
713 return; /* do it when process stb file */
714
715 for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) {
716 if (SCG(sptr) == SC_BASED)
717 continue;
718 dtype = DTYPEG(sptr);
719
720 /*
721 * !IS_INTERFACE check allows abstract interfaces which have INMODULE
722 * bit set to pass through this check, for processing of parameters.
723 */
724 if (SCG(sptr) == SC_EXTERN && STYPEG(sptr) == ST_PROC && INMODULEG(sptr) &&
725 !IS_INTERFACEG(sptr)) {
726
727 /* If routine is in same module as current routine then it is module
728 subroutine - should already process for this module.
729 */
730 if (INMODULEG(gbl.currsub) == INMODULEG(sptr))
731 continue;
732
733 stb_process_iface_chlen(sptr); /* fix up char len dummy args */
734 ll_process_routine_parameters(sptr);
735 continue;
736 }
737 if (SCG(sptr) == SC_EXTERN && STYPEG(sptr) == ST_PROC) {
738 if (CFUNCG(sptr) || PARAMCTG(sptr) ||
739 (CMPLXFUNC_C && DTYPEG(sptr) && DT_ISCMPLX(DTYPEG(sptr)))) {
740 ifacenm = get_llvm_ifacenm(sptr);
741 llvm_funcptr_store(sptr, ifacenm);
742 stb_process_iface_chlen(sptr); /* fix up char len dummy args */
743 ll_process_routine_parameters(sptr);
744 continue;
745 }
746 }
747 if (DTY(dtype) != TY_PTR)
748 continue;
749 if ((iface = get_iface_sptr(sptr))) {
750 ifacenm = get_llvm_ifacenm(iface);
751 llvm_funcptr_store(sptr, ifacenm);
752 stb_process_iface_chlen(iface); /* fix up char len dummy args */
753 ll_process_routine_parameters(iface);
754 }
755 }
756 }
757
758 void
store_llvm_localfptr(void)759 store_llvm_localfptr(void)
760 {
761 int dtype, dt, sptr, iface;
762 char *ifacenm;
763
764 if (!gbl.currsub)
765 return;
766
767 if (gbl.stbfil)
768 return;
769 }
770
771 /* Handle equivalence on stack:
772 Collect the size (gbl.locaddr) and create a new array of i8 with size of
773 gbl.locaddr.
774 In gen_llvm_expr() - use equiv_type instead.
775 Its address is the total size + ADDRESSG field(which is negative value).
776 ADDRESSG is always negative for SC_LOCAL+SOCPTR.
777 lowest_quiv_addr is the lowest address - for native compiler this is the
778 offset from
779 stack.
780 */
781
782 void
get_local_overlap_size(void)783 get_local_overlap_size(void)
784 {
785 char *name;
786 ISZ_T align_mask = 15; /* assume maximum alignment is 16 */
787 /* create a new variable with [i8 x gbl.locaddr] - note that gbl.locaddr may
788 * change later when we process more local variable(s).
789 */
790 if (gbl.locaddr && !gbl.outlined) {
791 f90_equiv_sz = ALIGN(gbl.locaddr, align_mask);
792 equiv_type =
793 make_array_lltype(f90_equiv_sz, make_lltype_from_dtype(DT_BINT));
794 name = get_llvm_name(gbl.currsub);
795 equiv_var = (char *)getitem(LLVM_LONGTERM_AREA, strlen(name) + 20);
796 sprintf(equiv_var, "%%%s_%s%d", name, "_$eq_", gbl.currsub);
797 }
798 }
799
800 char *
get_local_overlap_var(void)801 get_local_overlap_var(void)
802 {
803 return equiv_var;
804 }
805
806 LL_Type *
get_local_overlap_vartype(void)807 get_local_overlap_vartype(void)
808 {
809 return equiv_type;
810 }
811
812 void
write_local_overlap(void)813 write_local_overlap(void)
814 {
815 if (!equiv_var)
816 return;
817
818 print_token("\t");
819 print_token(equiv_var);
820 print_token(" = alloca ");
821 write_type(equiv_type);
822 print_token(", align 4\n");
823 }
824
825 void
reset_equiv_var(void)826 reset_equiv_var(void)
827 {
828 equiv_var = NULL;
829 equiv_type = NULL;
830 }
831
832 void
reset_master_sptr(void)833 reset_master_sptr(void)
834 {
835 master_sptr = SPTR_NULL;
836 }
837
838 SPTR
get_master_sptr(void)839 get_master_sptr(void)
840 {
841 return master_sptr;
842 }
843
844 ISZ_T
get_socptr_offset(int sptr)845 get_socptr_offset(int sptr)
846 {
847 return f90_equiv_sz + (ADDRESSG(sptr));
848 }
849
850 static char *
get_master_entry_name(SPTR sptr)851 get_master_entry_name(SPTR sptr)
852 {
853 static char nm[MAXARGLEN];
854 sprintf(nm, "%s%s", "_master___", get_llvm_name(sptr));
855 return nm;
856 }
857
858 static SPTR
make_new_funcsptr(SPTR oldsptr)859 make_new_funcsptr(SPTR oldsptr)
860 {
861 char *nm = get_master_entry_name(oldsptr);
862 SPTR sptr = getsym(nm, strlen(nm));
863 DTYPEP(sptr, DTYPEG(oldsptr));
864 STYPEP(sptr, STYPEG(oldsptr));
865 SCP(sptr, SCG(oldsptr));
866 CCSYMP(sptr, CCSYMG(oldsptr));
867 SYMLKP(sptr, NOSYM);
868 CREFP(sptr, CREFG(oldsptr));
869 #ifdef CUDAP
870 CUDAP(sptr, CUDAG(oldsptr));
871 #endif
872 PASSBYVALP(sptr, PASSBYVALG(oldsptr));
873 PASSBYREFP(sptr, PASSBYREFG(oldsptr));
874 ADDRESSP(sptr, 0);
875 FVALP(sptr, FVALG(oldsptr));
876 ADJARRP(sptr, ADJARRG(oldsptr));
877 DCLDP(sptr, DCLDG(oldsptr));
878 INMODULEP(sptr, INMODULEG(oldsptr));
879 VTOFFP(sptr, VTOFFG(oldsptr));
880 INVOBJP(sptr, INVOBJG(oldsptr));
881 INVOBJINCP(sptr, INVOBJINCG(oldsptr));
882 FUNCLINEP(sptr, FUNCLINEG(oldsptr));
883 CLASSP(sptr, CLASSG(oldsptr));
884 DPDSCP(sptr, DPDSCG(oldsptr));
885 sym_is_refd(sptr);
886
887 return sptr;
888 }
889
890 int
get_entries_argnum(void)891 get_entries_argnum(void)
892 {
893 int param_cnt, max_cnt, i, param_sptr, *dpdscp;
894 SPTR opt;
895 int master_dpdsc;
896 int sptr = gbl.currsub;
897 int fval = FVALG(gbl.currsub);
898 int fvaldt = 0;
899 int found = 0;
900 char name[100];
901
902 if (SYMLKG(sptr) <= NOSYM) /* no Entry */
903 return 0;
904
905 /* Create a new sym and gblsym for master */
906 master_sptr = make_new_funcsptr(gbl.currsub);
907
908 /* Argument from main routine */
909 param_cnt = PARAMCTG(sptr);
910 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(sptr));
911 master_dpdsc = aux.dpdsc_avl;
912
913 /* Add first argument, the entry_option */
914 i = 0;
915 sprintf(name, "%s%d", "__master_entry_choice", stb.stg_avail);
916 opt = addnewsym(name);
917 SCG(opt) = SC_DUMMY;
918 DTYPEP(opt, DT_INT);
919 STYPEP(opt, ST_VAR);
920 PASSBYVALP(opt, 1);
921 sym_is_refd(opt);
922 max_cnt = 1;
923 if (!aux.dpdsc_avl)
924 aux.dpdsc_avl++;
925 master_dpdsc = aux.dpdsc_avl;
926 aux.dpdsc_avl += max_cnt;
927 NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size,
928 aux.dpdsc_size + max_cnt + 100);
929 aux.dpdsc_base[master_dpdsc] = opt;
930 i = 1;
931
932 /* Add second arg if the following is true */
933 if (fval && SCG(fval) != SC_DUMMY) {
934 sprintf(name, "%s%d", "__master_entry_rslt", stb.stg_avail);
935 opt = addnewsym(name);
936 max_cnt++;
937 SCG(opt) = SC_DUMMY;
938 DTYPEP(opt, DTYPEG(fval));
939 STYPEP(opt, ST_VAR);
940 sym_is_refd(opt);
941 aux.dpdsc_avl += max_cnt;
942 aux.dpdsc_base[master_dpdsc + 1] = opt;
943 i = 2;
944 }
945
946 /* Add all of the known dummies */
947 if (param_cnt) {
948 max_cnt += param_cnt;
949 aux.dpdsc_avl += param_cnt;
950 NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size,
951 aux.dpdsc_size + param_cnt + 100);
952
953 while (param_cnt--) {
954 param_sptr = *dpdscp++;
955 aux.dpdsc_base[master_dpdsc + i] = param_sptr;
956 ++i;
957 }
958 }
959
960 /* add argument of entry that is not already in the list */
961 for (sptr = SYMLKG(sptr); sptr > NOSYM; sptr = SYMLKG(sptr)) {
962 if (sptr == gbl.currsub)
963 continue;
964
965 param_cnt = PARAMCTG(sptr);
966
967 if (param_cnt) {
968 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(sptr));
969 while (param_cnt--) {
970 param_sptr = *dpdscp++;
971 found = 0;
972 for (i = 0; i < max_cnt; i++) {
973 if (param_sptr == aux.dpdsc_base[master_dpdsc + i]) {
974 found = 1;
975 break;
976 }
977 }
978 if (!found) { /* not yet in the list, add to list */
979 aux.dpdsc_avl++;
980 NEED(aux.dpdsc_avl + 1, aux.dpdsc_base, int, aux.dpdsc_size,
981 aux.dpdsc_size + param_cnt + 100);
982 aux.dpdsc_base[master_dpdsc + max_cnt] = param_sptr;
983 max_cnt++;
984 }
985 }
986 }
987 }
988
989 PARAMCTP(master_sptr, max_cnt);
990 if (max_cnt) /* should always be true */
991 DPDSCP(master_sptr, master_dpdsc);
992 DTYPEP(master_sptr, DT_NONE); /* subroutine */
993 FVALP(master_sptr, 0);
994
995 /* Update the ag entry for master_sptr to have these newly added args */
996 ll_process_routine_parameters(master_sptr);
997 return master_sptr;
998 }
999
1000 static void
DeclareSPtrAsLocal(SPTR sptr,int flag)1001 DeclareSPtrAsLocal(SPTR sptr, int flag)
1002 {
1003 print_token("\t");
1004 print_token("%");
1005 print_token(get_llvm_name(sptr));
1006 print_token(" = alloca ");
1007 if (flag || PASSBYVALG(sptr))
1008 write_type(make_lltype_from_dtype(DTYPEG(sptr)));
1009 else
1010 write_type(make_lltype_from_dtype(generic_dummy_dtype()));
1011 print_nl();
1012 }
1013
1014 /* This function will declare all dummy variables from all entries as
1015 * local variables if it is not dummy argument of the current Entry.
1016 * Then we can pass them to master routine with the right type.
1017 * Therefore, it must be called after gen_entries_argnum so that we can
1018 * compare it against the list.
1019 */
1020 static void
write_dummy_as_local_in_entry(int sptr)1021 write_dummy_as_local_in_entry(int sptr)
1022 {
1023 int param_cnt, i;
1024 SPTR param_sptr;
1025 int found;
1026 SPTR marg_sptr;
1027 int master_param;
1028 SPTR *dpdscp;
1029 SPTR *master_dp;
1030
1031 param_cnt = PARAMCTG(sptr);
1032 if (param_cnt) {
1033 master_dp = (SPTR *)(aux.dpdsc_base + DPDSCG(master_sptr));
1034 master_param = PARAMCTG(master_sptr);
1035 for (i = 0; i < master_param; i++, master_dp++) {
1036 found = 0;
1037 marg_sptr = *master_dp;
1038 dpdscp = (SPTR *)(aux.dpdsc_base + DPDSCG(sptr));
1039 while (param_cnt--) {
1040 param_sptr = *dpdscp++;
1041 if (param_sptr == marg_sptr) { /* in current entry dummy arg */
1042 found = 1;
1043 break;
1044 } else if (marg_sptr == FVALG(sptr)) {
1045 found = 1;
1046 break;
1047 }
1048 }
1049 if (found == 0) {
1050 DeclareSPtrAsLocal(marg_sptr, 0);
1051 }
1052 param_cnt = PARAMCTG(sptr);
1053 }
1054 } else {
1055 /* declare all as local variables*/
1056 master_dp = (SPTR *)(aux.dpdsc_base + DPDSCG(master_sptr));
1057 for (i = 0; i < PARAMCTG(master_sptr); i++) {
1058 param_sptr = *master_dp++;
1059 DeclareSPtrAsLocal(param_sptr, 0);
1060 }
1061 }
1062
1063 if (FVALG(sptr) && SCG(FVALG(sptr)) != SC_DUMMY) {
1064 DeclareSPtrAsLocal(FVALG(sptr), 1);
1065 }
1066 }
1067
1068 void
print_entry_subroutine(LL_Module * module)1069 print_entry_subroutine(LL_Module *module)
1070 {
1071 SPTR sptr = gbl.entries;
1072 int iter = 0;
1073 char num[16];
1074 int i;
1075 DTYPE dtype, param_dtype;
1076 int clen, fval;
1077 DTYPE rettype;
1078 int chararg = 0;
1079 char *nm;
1080 int *dpdscp;
1081 TMPS *tmp, *atmp;
1082 LL_ABI_Info *abi;
1083 LL_Type *dummy_type;
1084 hashset_t formals; /* List of formal params for each entry trampoline */
1085
1086 if (SYMLKG(sptr) <= NOSYM)
1087 return;
1088
1089 if (master_sptr == 0)
1090 return;
1091
1092 /* For use when representing formal parameters */
1093 dummy_type = make_generic_dummy_lltype();
1094
1095 /* For each entry trampoline */
1096 formals = hashset_alloc(hash_functions_direct);
1097 for (; sptr > NOSYM; sptr = SYMLKG(sptr)) {
1098 tmp = NULL;
1099 atmp = NULL;
1100 reset_expr_id(); /* reset a temp runner */
1101
1102 /* Convenience hash for fast formal paramter identifying */
1103 hashset_clear(formals);
1104 abi = process_ll_abi_func_ftn(sptr, true);
1105
1106 ll_proto_add_sptr(sptr, abi);
1107 ll_proto_set_defined_body(ll_proto_key(sptr), true);
1108
1109 /*
1110 * HACK XXX FIXME: We do not call process_formal_arguments()
1111 * on any of the routines generated by the print_token commands below.
1112 * This means process_sptr will not be called for any CCSYM arguments
1113 * and we need to do that so that there exists an SNAME for those.
1114 */
1115 for (i = 1; i <= abi->nargs; ++i) {
1116 SPTR arg_sptr = abi->arg[i].sptr;
1117 if (!SNAME(arg_sptr) && CCSYMG(arg_sptr))
1118 process_sptr(arg_sptr);
1119 hashset_insert(formals, INT2HKEY(arg_sptr));
1120 }
1121 build_routine_and_parameter_entries(sptr, abi, NULL);
1122
1123 write_dummy_as_local_in_entry(sptr);
1124
1125 fval = FVALG(sptr);
1126 if (fval) {
1127 rettype = DTYPEG(fval);
1128 } else if (gbl.arets) {
1129 rettype = DT_INT;
1130 } else {
1131 rettype = DT_NONE;
1132 }
1133 if (fval && SCG(fval) != SC_DUMMY) {
1134 /* Bitcast fval which is local variable to i8*.
1135 * We will pass this fval to master routine.
1136 */
1137 tmp = make_tmps();
1138 tmp->id = 0;
1139 print_token("\t");
1140 print_tmp_name(tmp);
1141 print_token(" = bitcast ");
1142 write_type(make_ptr_lltype(make_lltype_from_dtype(rettype)));
1143 print_space(1);
1144 print_token(SNAME(fval));
1145 print_token(" to ");
1146 write_type(dummy_type);
1147 print_space(1);
1148 print_nl();
1149 }
1150
1151 /* call the master */
1152 if (gbl.arets) {
1153 atmp = make_tmps();
1154 print_token("\t");
1155 print_tmp_name(atmp);
1156 print_token(" = call ");
1157 write_type(make_lltype_from_dtype(DT_INT));
1158 print_token(" @");
1159 } else {
1160 print_token("\tcall void @");
1161 }
1162 print_token(get_llvm_name(master_sptr));
1163 print_token("(");
1164
1165 /* First argument is choice=? */
1166 write_type(make_lltype_from_dtype(DT_INT));
1167 snprintf(num, sizeof(num), " %d", iter++);
1168 print_token(num);
1169
1170 /* if function, the second argument is the return value. The third argument
1171 can also be a return value if the return value is a dummy argument
1172 (happens when types are different). */
1173 if (tmp) {
1174 /* pass the tmp about */
1175 print_token(", ");
1176 write_type(dummy_type);
1177 print_space(1);
1178 print_tmp_name(tmp);
1179 } else if (fval && SCG(fval) != SC_DUMMY && fval != FVALG(gbl.currsub)) {
1180 TY_KIND ThisIsABug; // FIXME
1181 DTYPE ThisIsABug2; // FIXME
1182 /* If it is a dummy, it should already in the master dpdsc. */
1183 print_token(", ");
1184 write_type(dummy_type);
1185 print_space(1);
1186 print_token(SNAME(fval));
1187 param_dtype = DTYPEG(fval);
1188 ThisIsABug = DTY(param_dtype); // FIXME
1189 ThisIsABug2 = (DTYPE)ThisIsABug; // FIXME
1190 if (DTYG(param_dtype) == TY_CHAR || DTYG(param_dtype) == TY_NCHAR ||
1191 (ThisIsABug == TY_PTR && DTySeqTyElement(ThisIsABug2) == DT_CHAR) ||
1192 (ThisIsABug == TY_PTR && DTySeqTyElement(ThisIsABug2) == DT_NCHAR)) {
1193 if (DTYPEG(sptr)) {
1194 clen = CLENG(sptr);
1195 if (!clen) {
1196 clen = getdumlen();
1197 CLENP(sptr, clen);
1198 }
1199 print_token(", ");
1200 write_type(make_lltype_from_dtype(DTYPEG(sptr)));
1201 print_token(SNAME(clen));
1202 } else {
1203 ++chararg;
1204 }
1205 }
1206 }
1207
1208 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(master_sptr));
1209 for (i = 0; i < PARAMCTG(master_sptr); i++) {
1210 int sym = *dpdscp++;
1211 if (i == 0)
1212 continue; /* skip choice */
1213 if (tmp && i == 1)
1214 continue; /* skip return value */
1215 print_token(", ");
1216 if (PASSBYVALG(sym))
1217 write_type(LLTYPE(sym));
1218 else
1219 write_type(dummy_type);
1220 print_space(1);
1221 print_token(SNAME(sym));
1222 }
1223 /* second loop - check for char arg */
1224 /* print char len here */
1225 if (chararg) {
1226 clen = CLENG(fval);
1227 print_token(", ");
1228 write_type(make_lltype_from_dtype(DTYPEG(clen)));
1229 print_token(" ");
1230 print_token(SNAME(clen));
1231 }
1232
1233 /* check for char arg */
1234 dpdscp = (int *)(aux.dpdsc_base + DPDSCG(master_sptr));
1235 for (i = 0; i < PARAMCTG(master_sptr); i++) {
1236 int sym = *dpdscp++;
1237 if (i == 0) /* Skip choice */
1238 continue;
1239 if (tmp && i == 1)
1240 continue; /* Skip non-character, return value */
1241 if (DTYG(DTYPEG(sym)) == TY_CHAR || DTYG(DTYPEG(sym)) == TY_NCHAR) {
1242 clen = CLENG(sym);
1243 print_token(", ");
1244 write_type(make_lltype_from_dtype(DTYPEG(clen)));
1245 if (clen && hashset_lookup(formals, INT2HKEY(clen))) {
1246 print_token(SNAME(clen));
1247 } else {
1248 print_token(" 0"); /* Default to 0 */
1249 }
1250 }
1251 }
1252
1253 print_token(")\n\t");
1254
1255 if (tmp) {
1256 /* load return value and return it */
1257 LL_Type *return_ll_type;
1258
1259 if (!DT_ISCMPLX(rettype) || !CMPLXFUNC_C) {
1260 return_ll_type = make_lltype_from_dtype(rettype);
1261
1262 /* %1 = load i32, i32* %cp1_300, align 4 */
1263 tmp = make_tmps();
1264 print_tmp_name(tmp);
1265 print_token(" = load ");
1266 if (ll_feature_explicit_gep_load_type(&module->ir)) {
1267 /* Print load type */
1268 write_type(return_ll_type);
1269 print_token(", ");
1270 }
1271 write_type(make_ptr_lltype(return_ll_type));
1272 print_space(1);
1273 print_token(SNAME(fval));
1274 print_token(", align 4");
1275 print_nl();
1276 } else {
1277 /* complex entry, default C return conventions */
1278 TMPS *addrtmp;
1279 return_ll_type = make_lltype_from_abi_arg(&abi->arg[0]);
1280
1281 /* %1 = bitcast <{float, float}>* %cp1_300 to double* */
1282 addrtmp = make_tmps();
1283 print_tmp_name(addrtmp);
1284 print_token(" = bitcast ");
1285 write_type(make_ptr_lltype(make_lltype_from_dtype(rettype)));
1286 print_space(1);
1287 print_token(SNAME(fval));
1288 print_token(" to ");
1289 write_type(make_ptr_lltype(return_ll_type));
1290 print_nl();
1291
1292 /* %2 = load double, double* %1, align 4 */
1293 tmp = make_tmps();
1294 print_token("\t");
1295 print_tmp_name(tmp);
1296 print_token(" = load ");
1297 /* Print load type */
1298 write_type(return_ll_type);
1299 print_token(", ");
1300 write_type(make_ptr_lltype(return_ll_type));
1301 print_space(1);
1302 print_tmp_name(addrtmp);
1303 print_token(", align 4\n");
1304 }
1305 if (abi->extend_abi_return) {
1306 print_token("\t%.rt = sext ");
1307 write_type(return_ll_type);
1308 print_space(1);
1309 print_tmp_name(tmp);
1310 print_token(" to ");
1311 write_type(make_lltype_from_dtype(DT_INT));
1312 print_nl();
1313 }
1314 print_token("\tret ");
1315 write_type(abi->extend_abi_return ? make_lltype_from_dtype(DT_INT)
1316 : return_ll_type);
1317 print_space(1);
1318 if (abi->extend_abi_return) {
1319 print_token("%.rt");
1320 } else {
1321 print_tmp_name(tmp);
1322 }
1323 } else if (atmp) {
1324 print_token("ret ");
1325 write_type(make_lltype_from_dtype(DT_INT));
1326 print_space(1);
1327 print_tmp_name(atmp);
1328 } else {
1329 print_token("ret void"); /* make sure it return correct type */
1330 }
1331 print_nl();
1332 /* vi matching { */
1333 print_token("}");
1334 print_nl();
1335 }
1336
1337 hashset_free(formals);
1338 }
1339
1340 bool
has_multiple_entries(int sptr)1341 has_multiple_entries(int sptr)
1342 {
1343 return (SYMLKG(sptr) > NOSYM);
1344 }
1345
1346 void
write_master_entry_routine(void)1347 write_master_entry_routine(void)
1348 {
1349 LL_ABI_Info *a = process_ll_abi_func_ftn(master_sptr, true);
1350 build_routine_and_parameter_entries(master_sptr, a, NULL);
1351 }
1352
1353 char *
get_entret_arg_name(void)1354 get_entret_arg_name(void)
1355 {
1356 SPTR *dpdscp = (SPTR *)(aux.dpdsc_base + DPDSCG(master_sptr));
1357 dpdscp++;
1358 return get_llvm_name(*dpdscp);
1359 }
1360
1361 int
mk_charlen_address(int sptr)1362 mk_charlen_address(int sptr)
1363 {
1364 int mem, ili, nme, off;
1365 INT zoff;
1366
1367 mem = get_sptr_uplevel_address(sptr); /* next one is the address of its len */
1368 zoff = ADDRESSG(mem);
1369
1370 /* match in load_uplevel_addresses. */
1371 zoff += 8;
1372 nme = addnme(NT_VAR, aux.curr_entry->display, 0, (INT)0);
1373 ili = ad_acon(aux.curr_entry->display, (INT)0);
1374
1375 off = 0;
1376 ili = ad2ili(IL_LDA, ili, nme); /* load display struct */
1377 if (zoff) {
1378 off = ad_aconi(zoff);
1379 ili = ad3ili(IL_AADD, ili, off, 0); /* add offset of sptr to display */
1380 }
1381
1382 return ili;
1383 }
1384
1385 LL_Type *
get_ftn_lltype(SPTR sptr)1386 get_ftn_lltype(SPTR sptr)
1387 {
1388 int dtype, gblsym;
1389 char *name;
1390 char tname[250];
1391 LL_Type *llt;
1392 LL_Type *rslt = NULL;
1393
1394 if (LLTYPE(sptr))
1395 return llt;
1396
1397 switch (SCG(sptr)) {
1398 case SC_STATIC:
1399 llt = get_ftn_static_lltype(sptr);
1400 rslt = llt;
1401 break;
1402 case SC_CMBLK:
1403 llt = get_ftn_cmblk_lltype(sptr);
1404 rslt = llt;
1405 break;
1406 case SC_EXTERN:
1407 llt = get_ftn_extern_lltype(sptr);
1408 rslt = llt;
1409 break;
1410 default:
1411 process_sptr(sptr);
1412 llt = LLTYPE(sptr);
1413 rslt = llt;
1414 break;
1415 }
1416 return rslt;
1417 }
1418
1419