1 /*
2 * Copyright (c) 2014-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 LLVM backend routines. This backend is Fortran-specific.
21 */
22
23 #include "llassem.h"
24 #include "dinit.h"
25 #include "dtypeutl.h"
26 #include "dinitutl.h"
27 #include "exp_rte.h"
28 #include "exputil.h"
29 #include "syms.h"
30 #include "version.h"
31 #include "machreg.h"
32 #include "dbg_out.h"
33 #include "assem.h"
34 #include "fih.h"
35 #include "x86.h"
36 #include "ili.h"
37 #include "llutil.h"
38 #include "cgllvm.h"
39 #include "cgmain.h"
40 #include "cg.h"
41 #include "ll_write.h"
42 #include "ll_structure.h"
43 #include "lldebug.h"
44 #include "expand.h"
45 #include "outliner.h"
46 #include "upper.h"
47 #include "llassem_common.h"
48 #if DEBUG
49 #include "flang/ADT/hash.h"
50 #endif
51 #include "symfun.h"
52
53 fptr_local_t fptr_local = {0};
54
55 /* --- AGB local --- */
56 static AGB_t agb_local;
57 #define AGL_SYMLK(s) agb_local.s_base[s].symlk
58 #define AGL_HASHLK(s) agb_local.s_base[s].hashlk
59 #define AGL_NMPTR(s) agb_local.s_base[s].nmptr
60 #define AGL_TYPENMPTR(s) agb_local.s_base[s].type_nmptr
61 #define AGL_ARGNMPTR(s) agb_local.s_base[s].farg_nmptr
62 #define AGL_DTYPE(s) agb_local.s_base[s].dtype
63 #define AGL_REF(s) agb_local.s_base[s].ref
64 #define AGL_NEEDMOD(s) agb_local.s_base[s].needmod
65 #define AGL_NAME(s) agb_local.n_base + agb_local.s_base[s].nmptr
66 #define AGL_TYPENAME(s) agb_local.n_base + agb_local.s_base[s].type_nmptr
67 #define AGL_ARGNAME(s) agb_local.n_base + agb_local.s_base[s].farg_nmptr
68 #define AGL_ARGDTLIST(s) agb_local.s_base.argdtlist
69
70 #ifdef __cplusplus
71 /* clang-format off */
72 static class ClassSections {
73 public:
operator [](int sec)74 const struct sec_t operator[](int sec) {
75 const int DoubleAlign = 8;
76 const int OneAlign = 1;
77 switch (sec) {
78 case NVIDIA_FATBIN_SEC:
79 return {".nvFatBinSegment", DoubleAlign};
80 case NVIDIA_MODULEID_SEC:
81 return {"__nv_module_id", DoubleAlign};
82 case NVIDIA_RELFATBIN_SEC:
83 return {"__nv_relfatbin", DoubleAlign};
84 case NVIDIA_OLDFATBIN_SEC:
85 return {".nv_fatbin", DoubleAlign};
86 case OMP_OFFLOAD_SEC:
87 return {".omp_offloading.entries", OneAlign};
88 default:
89 return {NULL, 0};
90 }
91 }
92 } sections;
93 /* clang-format on */
94 #else
95 #define LAST_SEC 28
96 static const struct sec_t sections[LAST_SEC] = {
97 [NVIDIA_FATBIN_SEC] = {".nvFatBinSegment", 8},
98 [NVIDIA_MODULEID_SEC] = {"__nv_module_id", 8},
99 [NVIDIA_RELFATBIN_SEC] = {"__nv_relfatbin", 8},
100 [NVIDIA_OLDFATBIN_SEC] = {".nv_fatbin", 8},
101 [OMP_OFFLOAD_SEC] = {".omp_offloading.entries", 1}};
102 #endif
103
104 static void assn_stkoff(SPTR sptr, DTYPE dtype, ISZ_T size);
105 static void assn_static_off(SPTR sptr, DTYPE dtype, ISZ_T size);
106 static void write_consts(void);
107 static void write_comm(void);
108 static void write_statics(void);
109 static void write_bss(void);
110 static void write_externs(void);
111 static void write_typedescs(void);
112 static void write_extern_inits(void);
113 static void dinits(void);
114 static bool llassem_struct_needs_cast(int sptr);
115 static void put_kstr(SPTR sptr, int add_null);
116 static void upcase_name(char *);
117 static char *write_ftn_type(LL_Type *, char *, int);
118 static void write_module_as_subroutine(void);
119 static int get_ag_size(int gblsym);
120 static DSRT *process_dsrt(DSRT *dsrtp, ISZ_T size, char *cptr, bool stop_at_sect, ISZ_T addr);
121 #if DEBUG
122 static void dump_all_dinits(void);
123
124 static hashset_t CommonBlockInits;
125 #endif
126
127 #ifdef __cplusplus
128 /* clang-format off */
GetDTPtr()129 inline DTYPE GetDTPtr() {
130 // FIXME: DT_PTR is 1 from syms.h, is that a bug?
131 return static_cast<DTYPE>(DT_PTR);
132 }
133 #undef DT_PTR
134 #define DT_PTR GetDTPtr()
135
136 #undef DSRTG
DSRTG(int sptr)137 inline DSRT *DSRTG(int sptr) {
138 return static_cast<DSRT *>(get_getitem_p(STGetDsrtInit(sptr)));
139 }
140 /* clang-format on */
141 #endif
142
143 /*
144 * There are two possible object file formats:
145 * IS_COFF IS_ELF
146 * ------- ------
147 * coff => true false
148 * elf => false true
149 *
150 * There are three possible debug formats: stabs, coff, and dwarf. Stabs or
151 * dwarf may be generated for either coff or elf object file formats.
152 * Stabs-generation is controlled only by an xflag; consequently, 'IS_STABS'
153 * must be tested first. Dwarf-generation is performed if the 'dwarf in coff'
154 * xflag is set, or the 'dwarf2' xflag is set, or if the object type is ELF.
155 * Coff-generation only occurs for coff object files if the 'dwarf in coff'
156 * xflag is not set:
157 * + IS_STABS is true => stabs
158 * + IS_DWARF is true => dwarf in coff, dwarf2, or ELF object file type
159 * + otherwise, the debug format is coff.
160 */
161 INLINE static bool
is_stabs(void)162 is_stabs(void)
163 {
164 return XBIT(120, 0x20);
165 }
166
167 #define ASMFIL gbl.asmfil
168
169 char *comment_char;
170
171 extern DINIT_REC *dsrtbase, *dsrtend, *dsrtfree;
172 extern char *current_module;
173 extern int current_debug_area;
174
175 static int static_name_initialized = 0;
176 static int static_name_global = 0;
177 static SPTR static_base;
178 static LL_ObjToDbgList *static_dbg_list;
179 static int bss_name_initialized = 0;
180 static int bss_name_global = 0;
181 static SPTR bss_base;
182 static char bss_name[MXIDLN];
183 static LL_ObjToDbgList *bss_dbg_list;
184 static int ag_ctors_cnt = 0;
185 #if defined(TARGET_OSX)
186 static int emitted_bss_name = 0;
187 static int emitted_static_name = 0;
188 static int emitted_outer_bss_name = 0;
189 static int emitted_outer_static_name = 0;
190 #endif
191 static char outer_static_name[MXIDLN]; /* Fortran: name of STATIC area for outer
192 function */
193 static char contained_static_name[MXIDLN]; /* Fortran: name of STATIC area for
194 contained function */
195 static char outer_bss_name[MXIDLN];
196 static char contained_bss_name[MXIDLN];
197 int print_stab_lines = false; /* exported to dwarf output module */
198
199 #define PRVT_FIRST 32 /* run-time needs 32 bytes for storage */
200 static struct {
201 int addr; /* next available addr for private variable */
202 int sym_sz; /* sym ptr representing size of private area */
203 } prvt = {PRVT_FIRST, 0};
204
205 #define DATA_ALIGN 15
206 #define MIN_ALIGN_SIZE (DATA_ALIGN + 1) /* flg.quad mininum size */
207
208 /* This make sure that common block and its threadprivate pointer each has its
209 * own cache line. If there were in the same cached line as other variables as
210 * we saw in fma3d OpenMP where threadprivate pointer shares the same cache line
211 * as common block, when there is a write to common block of master thread which
212 * threadprivate pointer resides, it also invalidates threadprivate pointer
213 * fetched by other threads and causes performance degradation. We decide to
214 * make 128 for all targets as it is safe to do so.
215 */
216 static int max_cm_align = 15; /* max alignment for common blocks */
217 static int ptr_local = 0; /* list of function pointer search name */
218 static int has_init = 0;
219 static int global_sptr; /* use to prepend for CUDA constructor static
220 initialized data such as ..cuda_constructor_1.BSS or
221 .SECTIONxxx which can be duplicate with other files
222 because name is not unique across file - we make it
223 global to avoid llvm optimization problem that make
224 it read only(aM). */
225
226 #ifdef TARGET_POWER
227 #define CACHE_ALIGN 127
228 #define ALN_UNIT 128
229 #else
230 #define CACHE_ALIGN 63
231 #define ALN_UNIT 64
232 #endif
233 #define ALN_MINSZ 128000
234 #define ALN_MAXADJ 4096
235 #define ALN_THRESH (ALN_MAXADJ / ALN_UNIT)
236 static int stk_aln_n = 1;
237 static int bss_aln_n = 1;
238
239 /* Information about the layout descriptor currently being written */
240 static struct {
241 SPTR sptr; /* the symbol that this is a layout descriptor for */
242 int entries; /* entries written so far in layout desc */
243 int expected_entries; /* total number of entries to be written */
244 bool wrote_tname; /* has the layout type struct been written yet? */
245 const char *tname; /* name of layout type struct */
246 } layout_desc = {SPTR_NULL, 0, 0, false, "%struct.ld.memtype"};
247
248 /* ******************************************************** */
249
250 INLINE static bool
is_BIGOBJ()251 is_BIGOBJ()
252 {
253 return XBIT(68, 0x1);
254 }
255
256 static int
name_to_hash(const char * ag_name,int len)257 name_to_hash(const char *ag_name, int len)
258 {
259 int hashval = ag_name[len - 1] | (ag_name[0] << 16) | (ag_name[1] << 8);
260 return hashval % AG_HASHSZ;
261 }
262
263 static int
add_ag_name(const char * ag_name)264 add_ag_name(const char *ag_name)
265 {
266 int i, nptr, len, needed;
267 char *np;
268
269 len = strlen(ag_name);
270 nptr = agb.n_avl;
271 agb.n_avl += (len + 1);
272
273 if ((len + 1) >= (32 * 16))
274 needed = len + 1;
275 else
276 needed = 32 * 16;
277
278 NEED(agb.n_avl, agb.n_base, char, agb.n_size, agb.n_size + needed);
279 np = agb.n_base + nptr;
280 for (i = 0; i < len; i++)
281 *np++ = *ag_name++;
282 *np = '\0';
283
284 return nptr;
285 }
286
287 static int
add_ag_local_name(char * ag_name)288 add_ag_local_name(char *ag_name)
289 {
290 int i, nptr, len, needed;
291 char *np;
292
293 len = strlen(ag_name);
294 nptr = agb_local.n_avl;
295 agb_local.n_avl += (len + 1);
296
297 if ((len + 1) >= (32 * 16))
298 needed = len + 1;
299 else
300 needed = 32 * 16;
301
302 NEED(agb_local.n_avl, agb_local.n_base, char, agb_local.n_size,
303 agb_local.n_size + needed);
304 np = agb_local.n_base + nptr;
305 for (i = 0; i < len; i++)
306 *np++ = *ag_name++;
307 *np = '\0';
308
309 return nptr;
310 }
311
312 INLINE static ISZ_T
count_skip(ISZ_T old,ISZ_T New)313 count_skip(ISZ_T old, ISZ_T New)
314 {
315 return New - old;
316 }
317
318 static SPTR
make_gblsym(SPTR sptr,const char * ag_name)319 make_gblsym(SPTR sptr, const char *ag_name)
320 {
321 int nptr, hashval;
322 SPTR gblsym;
323 DTYPE dtype;
324
325 gblsym = (SPTR)agb.s_avl++;
326 NEED(agb.s_avl, agb.s_base, AG, agb.s_size, agb.s_size + 32);
327 BZERO(&agb.s_base[gblsym], AG, 1);
328
329 nptr = add_ag_name(ag_name);
330 AG_NMPTR(gblsym) = nptr;
331 AG_DLL(gblsym) = DLL_NONE;
332
333 hashval = name_to_hash(ag_name, strlen(ag_name));
334 AG_HASHLK(gblsym) = agb.hashtb[hashval];
335 agb.hashtb[hashval] = gblsym;
336
337 if (sptr) {
338 AG_SC(gblsym) = SCG(sptr);
339 AG_STYPE(gblsym) = STYPEG(sptr);
340 if (CLASSG(sptr) && DESCARRAYG(sptr)) {
341 dtype = get_ftn_typedesc_dtype(sptr);
342 AG_LLTYPE(gblsym) = make_lltype_from_dtype(dtype);
343 } else if (STYPEG(sptr) == ST_PROC) {
344 dtype = get_return_type(sptr);
345 AG_LLTYPE(gblsym) = make_lltype_from_dtype(dtype);
346 } else if (STYPEG(sptr) == ST_CMBLK) {
347 if (flg.debug) {
348 lldbg_create_cmblk_mem_mdnode_list(sptr, gblsym);
349 }
350 } else
351 {
352 AG_LLTYPE(gblsym) = make_lltype_from_sptr(sptr);
353 }
354 }
355 return gblsym;
356 }
357
358 static char *
get_ag_searchnm(SPTR sptr)359 get_ag_searchnm(SPTR sptr)
360 {
361 if (sptr == gbl.currsub && gbl.rutype == RU_PROG)
362 return get_main_progname();
363 return get_llvm_name(sptr);
364 }
365
366 SPTR
get_typedef_ag(char * ag_name,char * typeName)367 get_typedef_ag(char *ag_name, char *typeName)
368 {
369 SPTR gblsym = find_ag(ag_name);
370
371 if (gblsym) {
372 if (typeName && !AG_TYPENMPTR(gblsym))
373 AG_TYPENMPTR(gblsym) = add_ag_name(typeName);
374 return gblsym;
375 }
376
377 /* Enter new symbol into the global symbol table */
378 gblsym = make_gblsym(SPTR_NULL, ag_name);
379 AG_STYPE(gblsym) = ST_TYPEDEF;
380 AG_SYMLK(gblsym) = ag_typedef;
381 ag_typedef = gblsym;
382 if (typeName) {
383 AG_TYPENMPTR(gblsym) = add_ag_name(typeName);
384 }
385 return SPTR_NULL;
386 }
387
388 SPTR
find_ag(const char * ag_name)389 find_ag(const char *ag_name)
390 {
391 SPTR gblsym;
392 int hashval = name_to_hash(ag_name, strlen(ag_name));
393
394 for (gblsym = agb.hashtb[hashval]; gblsym; gblsym = AG_HASHLK(gblsym))
395 if (!strcmp(ag_name, AG_NAME(gblsym)))
396 return gblsym;
397 return SPTR_NULL;
398 }
399
400 /*
401 * The F90 front-end has allocated the private variable with respect to a base
402 * offset of 0 -- need to adjust the offset so that it's with respect to
403 * the first available private offset.
404 */
405 void
fix_private_sym(int sptr)406 fix_private_sym(int sptr)
407 {
408 #if DEBUG
409 assert(SCG(sptr) == SC_PRIVATE, "fix_private_sym: sym not SC_PRIVATE", sptr,
410 ERR_Severe);
411 #endif
412 ADDRESSP(sptr, ADDRESSG(sptr) + 0);
413 }
414
415 void
assemble(void)416 assemble(void)
417 {
418 if (DBGBIT(14, 128))
419 return;
420
421 cg_llvm_init();
422
423 if (gbl.rutype == RU_BDATA) {
424 assem_init();
425 if (gbl.currsub) { /* need to print out the module as a subroutine */
426 int gblsym = find_ag(get_ag_searchnm(gbl.currsub));
427 if (!gblsym)
428 gblsym = get_ag(gbl.currsub);
429 else
430 AG_STYPE(gblsym) = ST_ENTRY;
431 write_module_as_subroutine();
432 }
433
434 assem_data();
435 }
436 if (has_init)
437 assem_end();
438
439 } /* endroutine assemble */
440
441 /**
442 \brief Initialize assem for the source file
443
444 Guaranteed to be called only once per compilation
445 */
446 void
assemble_init(int argc,char * argv[],char * cmdline)447 assemble_init(int argc, char *argv[], char *cmdline)
448 {
449 gbl.bss_addr = 0;
450 ag_cmblks = 0;
451 ag_procs = 0;
452 ag_other = 0;
453 ag_global = 0;
454 ag_typedef = 0;
455 ag_ctors_cnt = 0;
456 ag_static = 0;
457 ag_funcptr = 0;
458 agb.s_size = 32;
459 agb.s_avl = 1;
460 agb.n_size = 32 * 16;
461 agb.n_avl = 0;
462 NEW(agb.s_base, AG, agb.s_size);
463 NEW(agb.n_base, char, agb.n_size);
464
465 /* Set the inital entry to a canary */
466 add_ag_typename(0, "BADTYPE");
467
468 gbl.paddr = 0;
469 }
470
471 /**
472 \brief Creates a dtype struct and adds it to the AG table
473 */
474 static int
generate_struct_dtype(int size,char * name,char * typed)475 generate_struct_dtype(int size, char *name, char *typed)
476 {
477 DTYPE ttype;
478 int gblsym;
479 char gname[MXIDLN];
480 LL_Type *llt;
481
482 sprintf(gname, "struct%s", name);
483 ttype = mk_struct_for_llvm_init(name, size);
484 get_typedef_ag(gname, typed);
485 gblsym = find_ag(gname);
486
487 llt = make_lltype_from_dtype(ttype);
488 set_ag_lltype(gblsym, llt);
489
490 {
491 char override[MXIDLN + 1];
492 /* FIXME: LLVM will create its own "unique_name()"
493 * This overrides it with fortran name stored in the AG table.
494 */
495 sprintf(override, "%%%s", gname);
496 ll_override_type_string(llt, override);
497 }
498
499 if (gbl.currsub)
500 AG_DTYPESC(gblsym) = find_ag(get_ag_searchnm(gbl.currsub));
501 else
502 AG_DTYPESC(gblsym) = 0;
503
504 return gblsym;
505 }
506
507 /* Create a dtype for the type descriptor used to describe the type of sptr
508 * This does not add the created symbol to the AG table
509 */
510 DTYPE
get_ftn_typedesc_dtype(SPTR sptr)511 get_ftn_typedesc_dtype(SPTR sptr)
512 {
513 return mk_struct_for_llvm_init(getsname(sptr), 0);
514 }
515
516 static bool
llassem_struct_needs_cast(int sptr)517 llassem_struct_needs_cast(int sptr)
518 {
519 return sptr && ((STYPEG(sptr) == ST_STRUCT) || (STYPEG(sptr) == ST_UNION));
520 }
521
522 #define CHK_REALLOC(_buf, _total, _csz, _pad) \
523 do { \
524 if (strlen(_buf) >= _total) { \
525 _total += (strlen(_buf) - _total) + _csz; \
526 asrt(strlen(_buf) < _total + _pad); \
527 _buf = (char *)realloc(_buf, _total + _pad); \
528 } \
529 } while (0)
530
531 /**
532 \brief Create a struct type from the \c DSRT list
533 \param sptr symbol
534 \param dsrtp head of DSRT list
535 \param size ?
536 \param align8 ? [output]
537 \param stop_at_sect When true then return immediately when a new section
538 type is encountered on the list. This flag is only useful for processing a
539 list of named sections (specifically 'section_inits').
540 \param addr ?
541 \return a string of the constructed type
542
543 The struct type is built as follows:
544 - Combine all non-pointer together as an array of bytes,
545 - Each pointer type emitted as i8*
546
547 All callers must call <tt>free()</tt> on the returned string.
548 */
549 static char *
get_struct_from_dsrt(SPTR sptr,DSRT * dsrtp,ISZ_T size,int * align8,bool stop_at_sect,ISZ_T addr)550 get_struct_from_dsrt(SPTR sptr, DSRT *dsrtp, ISZ_T size, int *align8,
551 bool stop_at_sect, ISZ_T addr)
552 {
553 int al;
554 DTYPE tdtype;
555 size_t total_alloc;
556 ISZ_T skip_size, repeat_cnt, loc_base;
557 char *buf;
558 DREC *p;
559 ISZ_T i8cnt = 0, n_skip;
560 int ptrcnt = 0;
561 char tchar[20];
562 const int csz = 256;
563 const int pad = 32;
564
565 if (llassem_struct_needs_cast(sptr)) {
566 LL_Type *llty;
567 // recursive call to prop side-effects (setting *align8, etc.)
568 buf = get_struct_from_dsrt(SPTR_NULL, dsrtp, size, align8, stop_at_sect,
569 addr);
570 free(buf);
571 llty = make_lltype_from_sptr(sptr);
572 assert(llty && (llty->data_type == LL_PTR),
573 "type of object must be pointer", 0, ERR_Fatal);
574 return strdup(llty->sub_types[0]->str);
575 }
576 /* This is using string ops (e.g., strcpy, strcat, strlen) therefore
577 * we need to account for the terminator, so we add an additional pad
578 * The pad should account for the cases where we might overrun the string
579 * before we have time to realloc, such as when we append "[ %ld x i8]"
580 */
581 buf = (char *)malloc(csz + pad);
582 total_alloc = csz;
583 buf[0] = '\0';
584 tchar[0] = '\0';
585 loc_base = 0;
586 repeat_cnt = 1;
587 first_data = 1;
588
589 for (; dsrtp; dsrtp = dsrtp->next) {
590 loc_base = dsrtp->offset; /* assumes this is a DINIT_LOC */
591 if (dsrtp->sectionindex != DATA_SEC) {
592 switch (dsrtp->sectionindex) {
593 case NVIDIA_FATBIN_SEC:
594 case NVIDIA_RELFATBIN_SEC:
595 case NVIDIA_OLDFATBIN_SEC:
596 *align8 = 1;
597 }
598 gbl.func_count = dsrtp->func_count;
599 } else {
600 if (addr < dsrtp->offset) {
601 if (ptrcnt) {
602 if (!first_data)
603 strcat(buf, ", ");
604 if (!i8cnt)
605 strcat(buf, "[" /*]*/);
606 ptrcnt = 0;
607 } else if (!i8cnt) {
608 if (!first_data)
609 strcat(buf, ", ");
610 strcat(buf, "[" /*]*/);
611 }
612 i8cnt = i8cnt + count_skip(addr, dsrtp->offset);
613 addr = dsrtp->offset;
614 first_data = 0;
615 } else if (addr > dsrtp->offset) {
616 error(S_0164_Overlapping_data_initializations_of_OP1, ERR_Warning, 0,
617 SYMNAME(dsrtp->sptr), CNULL);
618 continue;
619 }
620 }
621 dinit_fseek(dsrtp->filepos);
622 while ((p = dinit_read())) {
623 int size_of_item;
624
625 tdtype = p->dtype;
626 if (tdtype == DINIT_LOC || tdtype == DINIT_SLOC) {
627 loc_base = ADDRESSG(p->conval);
628 break;
629 }
630
631 if (tdtype == DINIT_SECT || tdtype == DINIT_DATASECT) {
632 if (!first_data && stop_at_sect) {
633 if (i8cnt) {
634 sprintf(tchar, /*[*/ "%ld x i8] ", i8cnt);
635 strcat(buf, tchar);
636 }
637 return buf;
638 }
639 break;
640 }
641
642 switch (p->dtype) {
643 case 0: /* alignment record */
644 #if DEBUG
645 assert(p->conval == 7 || p->conval == 3 || p->conval == 1 ||
646 p->conval == 0,
647 "dinits:bad align", (int)p->conval, ERR_Severe);
648 #endif
649 skip_size = ALIGN(addr, p->conval) - addr;
650 if (ptrcnt) {
651 if (!first_data)
652 strcat(buf, ", ");
653 strcat(buf, "[" /*]*/);
654 ptrcnt = 0;
655 } else if (!i8cnt) {
656 if (!first_data)
657 strcat(buf, ", ");
658 strcat(buf, "[" /*]*/);
659 }
660 first_data = 0;
661 i8cnt = i8cnt + count_skip(addr, ALIGN(addr, p->conval));
662 addr = ALIGN(addr, p->conval);
663 break;
664 case DINIT_ZEROES:
665 if (ptrcnt) {
666 if (!first_data)
667 strcat(buf, ", ");
668 strcat(buf, "[" /*]*/);
669 ptrcnt = 0;
670 } else if (!i8cnt) {
671 if (!first_data)
672 strcat(buf, ", ");
673 strcat(buf, "[" /*]*/);
674 }
675 i8cnt = i8cnt + ((int)p->conval);
676 first_data = 0;
677 addr += p->conval;
678 break;
679 case DINIT_LABEL:
680 /* word to be init'ed with address of label 'tconval' */
681 al = alignment(DT_CPTR);
682 skip_size = ALIGN(addr, al) - addr;
683 if (ptrcnt) {
684 if (!first_data)
685 strcat(buf, ", ");
686 if (skip_size)
687 strcat(buf, "[" /*]*/);
688 ptrcnt = 0;
689 } else if (!i8cnt) {
690 if (!first_data)
691 strcat(buf, ", ");
692 if (skip_size)
693 strcat(buf, "[" /*]*/);
694 }
695 i8cnt = i8cnt + count_skip(addr, ALIGN(addr, al));
696 if (i8cnt) {
697 sprintf(tchar, /*[*/ "%ld x i8] ", i8cnt);
698 strcat(buf, tchar);
699 strcat(buf, ", ");
700 i8cnt = 0;
701 first_data = 0;
702 }
703 addr = ALIGN(addr, al);
704 ptrcnt++;
705 strcat(buf, "i8* ");
706 addr += size_of(DT_CPTR);
707 first_data = 0;
708 break;
709 #ifdef DINIT_FUNCCOUNT
710 case DINIT_FUNCCOUNT:
711 gbl.func_count = p->conval;
712 break;
713 #endif
714 case DINIT_OFFSET:
715 n_skip = i8cnt + count_skip(addr, p->conval + loc_base);
716 if (ptrcnt) {
717 if (!first_data)
718 strcat(buf, ", ");
719 if (n_skip)
720 strcat(buf, "[" /*]*/);
721 ptrcnt = 0;
722 } else if (!i8cnt) {
723 if (!first_data)
724 strcat(buf, ", ");
725 if (n_skip)
726 strcat(buf, "[" /*]*/);
727 }
728 if (n_skip)
729 first_data = 0;
730 else
731 first_data = 1;
732 i8cnt = n_skip;
733 addr = p->conval + loc_base;
734 break;
735 case DINIT_REPEAT:
736 repeat_cnt = p->conval;
737 break;
738 case DINIT_SECT:
739 break;
740 case DINIT_DATASECT:
741 break;
742 case DINIT_STRING:
743 if (ptrcnt) {
744 if (!first_data)
745 strcat(buf, ", ");
746 strcat(buf, "[" /*]*/);
747 ptrcnt = 0;
748 } else if (!i8cnt) {
749 if (!first_data)
750 strcat(buf, ", ");
751 strcat(buf, "[" /*]*/);
752 }
753 addr += p->conval;
754 i8cnt += p->conval;
755 first_data = 0;
756 dinit_fskip(p->conval);
757 break;
758
759 default:
760 assert(tdtype > 0, "dinits:bad dinit rec", tdtype, ERR_Severe);
761
762 size_of_item = size_of(tdtype);
763
764 do {
765 if (DTY(tdtype) == TY_PTR && size_of_item) {
766 if (i8cnt) {
767 sprintf(tchar, /*[*/ "%ld x i8] ", i8cnt);
768 strcat(buf, tchar);
769 i8cnt = 0;
770 first_data = 0;
771 }
772 if (!first_data)
773 strcat(buf, ", ");
774 strcat(buf, "i8* ");
775 ptrcnt++;
776 } else if (size_of_item) {
777 if (ptrcnt || !i8cnt) {
778 if (!first_data)
779 strcat(buf, ", ");
780 strcat(buf, "[" /*]*/);
781 ptrcnt = 0;
782 }
783 i8cnt = i8cnt + size_of_item;
784 }
785 if (size_of_item) /* don't do for char*0 */
786 first_data = 0;
787 addr += size_of_item;
788 CHK_REALLOC(buf, total_alloc, csz, pad);
789 } while (--(repeat_cnt));
790 repeat_cnt = 1;
791 }
792
793 CHK_REALLOC(buf, total_alloc, csz, pad);
794 } /* end of while(dinit_read()) */
795
796 CHK_REALLOC(buf, total_alloc, csz, pad);
797 } /* end of for( ... dsrt) */
798
799 if (size >= (INT)0 && (size >= addr)) {
800 if (!i8cnt && (size - addr) > 0) {
801 if (!first_data)
802 strcat(buf, ", ");
803 strcat(buf, "[" /*]*/);
804 ptrcnt = 0;
805 }
806 i8cnt = i8cnt + count_skip(addr, size);
807 }
808 if (i8cnt) {
809 if (ptrcnt) {
810 if (!first_data)
811 strcat(buf, ", ");
812 strcat(buf, "[" /*]*/);
813 ptrcnt = 0;
814 } else {
815 sprintf(tchar, /*[*/ "%ld x i8] ", i8cnt);
816 strcat(buf, tchar);
817 }
818 }
819 first_data = 0;
820 return buf;
821 }
822
823 /**
824 \brief Initialize assem for a function
825
826 Called once per function. This init is called immediately before any
827 processing is performed for a function.
828 */
829 void
assem_init(void)830 assem_init(void)
831 {
832 INT nmptr;
833 SPTR sptr;
834 int align8, mod_or_sub, subprog;
835 char *typed;
836
837 if (has_init == 1) {
838 return;
839 }
840
841 has_init = 1;
842 subprog = gbl.outersub ? gbl.outersub : gbl.currsub;
843 mod_or_sub = INMODULEG(subprog) ? INMODULEG(subprog) : subprog;
844 if (!mod_or_sub)
845 return;
846
847 if (!static_name_initialized) {
848 {
849 sprintf(static_name, ".STATICS%d", gbl.multi_func_count);
850 }
851 static_name_global = 0;
852 static_base = SPTR_NULL;
853 }
854 if (!bss_name_initialized) {
855 {
856 sprintf(bss_name, ".BSS%d", gbl.multi_func_count);
857 }
858 bss_name_global = 0;
859 bss_base = SPTR_NULL;
860 }
861 static_name_initialized = 1;
862 bss_name_initialized = 1;
863 if (!gbl.outlined) {
864 if (gbl.internal <= 1) {
865 strcpy(outer_static_name, static_name);
866 strcpy(outer_bss_name, bss_name);
867 }
868 }
869 if (gbl.internal > 1 || gbl.outlined) {
870 generate_struct_dtype(0, outer_static_name, NULL);
871 generate_struct_dtype(0, outer_bss_name, NULL);
872 if (gbl.outlined) {
873 if (*contained_static_name)
874 generate_struct_dtype(0, contained_static_name, NULL);
875 if (*contained_bss_name)
876 generate_struct_dtype(0, contained_bss_name, NULL);
877 } else {
878 strcpy(contained_static_name, static_name);
879 strcpy(contained_bss_name, bss_name);
880 }
881 }
882
883 generate_struct_dtype(0, static_name, NULL);
884 generate_struct_dtype(0, bss_name, NULL);
885
886 for (sptr = gbl.cmblks; sptr > NOSYM; sptr = SYMLKG(sptr)) {
887 int gblsym;
888 typed = NULL;
889 typed =
890 get_struct_from_dsrt(sptr, DSRTG(sptr), SIZEG(sptr), &align8, false, 0);
891 gblsym = generate_struct_dtype(0, get_llvm_name(sptr), typed);
892 if (!DINITG(sptr)) {
893 if (!AG_SIZE(gblsym)) {
894 AG_SIZE(gblsym) = SIZEG(sptr);
895 } else if (SIZEG(sptr) > AG_SIZE(gblsym)) {
896 AG_SIZE(gblsym) = SIZEG(sptr);
897 nmptr = add_ag_name(typed);
898 AG_TYPENMPTR(gblsym) = nmptr;
899 }
900 }
901 free(typed);
902 }
903
904 /* ag_local gets allocated and deallocate for every function */
905 ag_local = 0;
906 agb_local.s_size = 32;
907 agb_local.s_avl = 1;
908 agb_local.n_size = 32 * 16;
909 agb_local.n_avl = 0;
910 NEW(agb_local.s_base, AG, agb_local.s_size);
911 NEW(agb_local.n_base, char, agb_local.n_size);
912 BZERO(agb_local.hashtb, int, AG_HASHSZ);
913
914 /* ptr_local - store name for function pointer per routine */
915 ptr_local = 0;
916 fptr_local.s_size = 5;
917 fptr_local.s_avl = 1;
918 fptr_local.n_size = 5 * 16;
919 fptr_local.n_avl = 0;
920 NEW(fptr_local.s_base, FPTRSYM, fptr_local.s_size);
921 NEW(fptr_local.n_base, char, fptr_local.n_size);
922 BZERO(fptr_local.hashtb, int, AG_HASHSZ);
923
924 } /* endroutine assem_init */
925
926 /**
927 \brief Print directives and label for beginning of function.
928 */
929 void
assem_begin_func(SPTR sptr)930 assem_begin_func(SPTR sptr)
931 {
932 /* only f90 host subprograms are global */
933 if (gbl.internal > 1)
934 return;
935 get_ag(sptr);
936 }
937
938 void
assem_put_linux_trace(int sptr)939 assem_put_linux_trace(int sptr)
940 {
941 }
942
943 void
assem_data(void)944 assem_data(void)
945 {
946 assem_init(); /* put it here - won't hurt if it is already called
947 The reason we put it here because write_statics will
948 attempt to write static data for openacc constructor
949 we need to make sure the the static name is correct
950 with respect gbl.currsub. This does not happen with
951 native because it does not need to write out static
952 if lcl_inits is empty.
953 */
954
955 dinits();
956
957 write_comm();
958
959 write_extern_inits();
960 write_bss(); /* There is a bug in llvm opt where it makes bss area
961 not writable "a", progbits - if we write after
962 the constants and statics. It is OK if we write before.
963 Example test is f90_correct/dt42.f90
964 */
965 write_statics();
966 write_consts();
967
968 write_externs();
969
970 write_typedescs();
971 }
972
973 void
assem_end(void)974 assem_end(void)
975 {
976 freearea(2);
977 dinit_end();
978 static_base = SPTR_NULL;
979 static_name_global = 0;
980 bss_base = SPTR_NULL;
981 bss_name_global = 0;
982 has_init = 0;
983 ag_local = 0;
984 FREE(agb_local.s_base);
985 FREE(agb_local.n_base);
986 agb_local.s_base = NULL;
987 agb_local.n_base = NULL;
988 agb_local.s_avl = 0;
989 agb_local.n_avl = 0;
990 agb_local.s_size = 0;
991 agb_local.n_size = 0;
992
993 ptr_local = 0;
994 FREE(fptr_local.s_base);
995 FREE(fptr_local.n_base);
996 fptr_local.s_base = NULL;
997 fptr_local.n_base = NULL;
998 fptr_local.n_avl = 0;
999 fptr_local.s_avl = 0;
1000 fptr_local.n_size = 0;
1001 fptr_local.s_size = 0;
1002
1003 reset_equiv_var();
1004 reset_master_sptr();
1005 stk_aln_n = 1;
1006 bss_aln_n = 1;
1007 static_name_initialized = 0;
1008 bss_name_initialized = 0;
1009
1010 } /* endroutine assem_end */
1011
1012 #ifdef OMP_OFFLOAD_LLVM
1013 /**
1014 \brief Complete assem for the source file
1015 Writes shared memory variables to global module.
1016 */
1017 void
ompaccel_write_sharedvars(void)1018 ompaccel_write_sharedvars(void)
1019 {
1020 int gblsym;
1021 char *name, *typed;
1022 for (gblsym = ag_other; gblsym; gblsym = AG_SYMLK(gblsym)) {
1023 name = AG_NAME(gblsym);
1024 typed = AG_TYPENAME(gblsym);
1025 fprintf(gbl.ompaccfile, "@%s = common addrspace(3) global %s ", name,
1026 typed);
1027 fprintf(gbl.ompaccfile, " zeroinitializer\n");
1028 }
1029 }
1030
1031 static void
write_libomptarget_statics(SPTR sptr,char * gname,char * typed,int gblsym,DSRT * dsrtp)1032 write_libomptarget_statics(SPTR sptr, char *gname, char *typed, int gblsym,
1033 DSRT *dsrtp)
1034 {
1035 char *linkage_type;
1036
1037 linkage_type = "internal";
1038 sprintf(gname, "struct%s", getsname(sptr));
1039 get_typedef_ag(gname, typed);
1040 free(typed);
1041 gblsym = find_ag(gname);
1042 typed = AG_TYPENAME(gblsym);
1043
1044 process_ftn_dtype_struct(DTYPEG(sptr), typed, false);
1045 write_struct_defs();
1046
1047 #ifdef WEAKG
1048 if (WEAKG(sptr))
1049 linkage_type = "weak";
1050 #endif
1051 fprintf(ASMFIL, "@%s = %s global %s ", getsname(sptr), linkage_type, typed);
1052
1053 fprintf(ASMFIL, " { ");
1054 process_dsrt(dsrtp, gbl.saddr, typed, TRUE, 0);
1055 fprintf(ASMFIL, " ,i64 0, i32 0, i32 0 }");
1056
1057 fprintf(ASMFIL, ", section \"%s\"", sections[dsrtp->sectionindex].name);
1058 if (sections[dsrtp->sectionindex].align)
1059 fprintf(ASMFIL, ", align %d", sections[dsrtp->sectionindex].align);
1060 fputc('\n', ASMFIL);
1061 }
1062
1063 static bool isOmptargetInitialized = false;
1064
1065 void
write_libomtparget(void)1066 write_libomtparget(void)
1067 {
1068 /* These structs should be created just right after the first target region. */
1069 if (!isOmptargetInitialized) {
1070 if(!strcmp(SYMNAME(gbl.currsub), "ompaccel.register"))
1071 {
1072 fprintf(ASMFIL, "\n; OpenMP GPU Offload Init\n\
1073 @.omp_offloading.img_end.nvptx64-nvidia-cuda = external constant i8 \n\
1074 @.omp_offloading.img_start.nvptx64-nvidia-cuda = external constant i8 \n\
1075 @.omp_offloading.entries_end = external constant %%struct.__tgt_offload_entry_ \n\
1076 @.omp_offloading.entries_begin = external constant %%struct.__tgt_offload_entry_ \n\
1077 @.omp_offloading.device_images = internal unnamed_addr constant [1 x %%struct.__tgt_device_image] [%%struct.__tgt_device_image { i8* @.omp_offloading.img_start.nvptx64-nvidia-cuda, i8* @.omp_offloading.img_end.nvptx64-nvidia-cuda, %%struct.__tgt_offload_entry_* @.omp_offloading.entries_begin, %%struct.__tgt_offload_entry_* @.omp_offloading.entries_end }], align 8\n\
1078 @.omp_offloading.descriptor_ = internal constant %%struct.__tgt_bin_desc { i64 1, %%struct.__tgt_device_image* getelementptr inbounds ([1 x %%struct.__tgt_device_image], [1 x %%struct.__tgt_device_image]* @.omp_offloading.device_images, i32 0, i32 0), %%struct.__tgt_offload_entry_* @.omp_offloading.entries_begin, %%struct.__tgt_offload_entry_* @.omp_offloading.entries_end }, align 8\n\n");
1079 isOmptargetInitialized = true;
1080 }
1081 }
1082 }
1083
1084 #endif
1085
1086
1087 /**
1088 \brief Complete assem for the source file
1089
1090 Guaranteed to be called only once per compilation
1091 */
1092 void
assemble_end(void)1093 assemble_end(void)
1094 {
1095 int gblsym, tdefsym, align_value, cmem;
1096 char *name, *typed, gname[MXIDLN + 50];
1097 char *tls = " thread_local";
1098
1099 if (gbl.has_program) {
1100 /* If huge page table support (-Mhugetlb) emit the constructor init */
1101 if (XBIT(129, 0x10000000))
1102 init_huge_tlb();
1103 #if defined(TARGET_X8664)
1104 /* -Mflushz */
1105 if (XBIT(129, 0x2))
1106 init_flushz();
1107 /* -Mdaz */
1108 if (mach.feature[FEATURE_DAZ])
1109 init_daz();
1110 #endif
1111 if (XBIT(24, 0x1f9)) { /* any of -Ktrap=... */
1112 init_ktrap();
1113 }
1114 }
1115
1116 write_external_function_declarations(true);
1117 llvm_write_ctors();
1118
1119 /* write out common block which is not initialized */
1120 align_value = CACHE_ALIGN + 1;
1121 for (gblsym = ag_cmblks; gblsym; gblsym = AG_SYMLK(gblsym)) {
1122 if (AG_DSIZE(gblsym))
1123 continue;
1124 if (AG_SC(gblsym) == SC_EXTERN) {
1125 fprintf(ASMFIL, "@%s = linkonce global %s undef\n", AG_NAME(gblsym),
1126 AG_TYPENAME(gblsym));
1127 } else {
1128 ISZ_T sz;
1129 char tname[20];
1130 LL_ObjToDbgList *listp = AG_OBJTODBGLIST(gblsym);
1131 LL_ObjToDbgListIter i;
1132 if (AG_ALLOC(gblsym))
1133 sz = 8;
1134 else
1135 sz = AG_SIZE(gblsym);
1136 name = AG_NAME(gblsym);
1137 sprintf(gname, "struct%s", name);
1138 sprintf(tname, "[%ld x i8]", sz);
1139 get_typedef_ag(gname, tname);
1140 tdefsym = find_ag(gname);
1141 typed = AG_TYPENAME(tdefsym);
1142 fprintf(ASMFIL, "%%struct%s = type < { %s } > \n", name, typed);
1143 fprintf(ASMFIL, "@%s = %s global %%struct%s ", name,
1144 AG_ISMOD(gblsym) ? "external" : "common", name);
1145 fprintf(ASMFIL, "%s, align %d",
1146 AG_ISMOD(gblsym) ? "" : " zeroinitializer", align_value);
1147 for (llObjtodbgFirst(listp, &i); !llObjtodbgAtEnd(&i);
1148 llObjtodbgNext(&i)) {
1149 print_dbg_line(llObjtodbgGet(&i));
1150 }
1151 llObjtodbgFree(listp);
1152 fprintf(ASMFIL, "\n");
1153 AG_DSIZE(gblsym) = 1;
1154 }
1155 }
1156
1157 for (gblsym = ag_intrin; gblsym; gblsym = AG_SYMLK(gblsym)) {
1158 print_line(AG_NAME(gblsym));
1159 }
1160
1161 /* If this type descriptor has been defined (written to asm) skip,
1162 * else declare as extern.
1163 */
1164 for (gblsym = ag_global; gblsym; gblsym = AG_SYMLK(gblsym)) {
1165 if (AG_TYPEDESC(gblsym) && !AG_DEFD(gblsym)) {
1166 fprintf(ASMFIL, "%%%s = type opaque\n", AG_TYPENAME(gblsym));
1167 fprintf(ASMFIL, "@%s = external global %%%s\n", AG_NAME(gblsym),
1168 AG_TYPENAME(gblsym));
1169 }
1170 }
1171 for (gblsym = ag_typedef; gblsym; gblsym = AG_SYMLK(gblsym)) {
1172 if (AG_FINAL(gblsym) && !AG_DEFD(gblsym))
1173 fprintf(ASMFIL, "@%s = extern_weak global %s \n", AG_NAME(gblsym),
1174 AG_TYPENAME(gblsym));
1175 else if (AG_TYPEDESC(gblsym) && !AG_DEFD(gblsym)) {
1176 fprintf(ASMFIL, "%%%s = type opaque\n", AG_TYPENAME(gblsym));
1177 fprintf(ASMFIL, "@%s = external global %%%s\n", AG_NAME(gblsym),
1178 AG_TYPENAME(gblsym));
1179 }
1180 }
1181 for (gblsym = ag_other; gblsym; gblsym = AG_SYMLK(gblsym)) {
1182 name = AG_NAME(gblsym);
1183 typed = AG_TYPENAME(gblsym);
1184 if (AG_ISTLS(gblsym)) {
1185 fprintf(ASMFIL, "@%s = common%s global %s ", name, tls, typed);
1186 } else {
1187 fprintf(ASMFIL, "@%s = common global %s ", name, typed);
1188 }
1189 fprintf(ASMFIL, " zeroinitializer , align %d\n", align_value);
1190 }
1191
1192 FREE(agb.s_base);
1193 FREE(agb.n_base);
1194 } /* endroutine assemble_end */
1195
1196 static void
write_consts(void)1197 write_consts(void)
1198 {
1199 if (gbl.consts > NOSYM) {
1200 SPTR sptr;
1201 for (sptr = gbl.consts; sptr > NOSYM; sptr = SYMLKG(sptr)) {
1202 DTYPE dtype = DTYPEG(sptr);
1203 if (DTY(dtype) == TY_CHAR) {
1204 put_fstr(sptr, XBIT(124, 0x8000));
1205 fputc('\n', ASMFIL);
1206 } else if (DTY(dtype) == TY_NCHAR) {
1207 put_kstr(sptr, XBIT(124, 0x8000));
1208 fputc('\n', ASMFIL);
1209 } else if (DTY(dtype) != TY_PTR) {
1210 const char *tyName = char_type(dtype, sptr);
1211 if (OMPACCRTG(sptr)) {
1212 fprintf(ASMFIL, "@%s = external constant %s ", getsname(sptr),
1213 tyName);
1214 } else {
1215 if (XBIT(183, 0x20000000)) {
1216 fprintf(ASMFIL, "@%s = global %s ", getsname(sptr),
1217 tyName);
1218 } else {
1219 fprintf(ASMFIL, "@%s = internal constant %s ", getsname(sptr),
1220 tyName);
1221 }
1222 write_constant_value(sptr, 0, CONVAL1G(sptr), CONVAL2G(sptr), false);
1223 }
1224 fputc('\n', ASMFIL);
1225 }
1226 }
1227 if (flg.smp || XBIT(34, 0x200 || gbl.usekmpc)) {
1228 SPTR tsptr = SPTR_NULL;
1229 for (sptr = gbl.consts; sptr > NOSYM; sptr = SYMLKG(sptr)) {
1230 if (tsptr)
1231 SYMLKP(tsptr, SPTR_NULL);
1232 tsptr = sptr;
1233 }
1234 if (tsptr)
1235 SYMLKP(tsptr, SPTR_NULL);
1236 }
1237 }
1238 gbl.consts = NOSYM;
1239 }
1240
1241 static DSRT *
process_dsrt(DSRT * dsrtp,ISZ_T size,char * cptr,bool stop_at_sect,ISZ_T addr)1242 process_dsrt(DSRT *dsrtp, ISZ_T size, char *cptr, bool stop_at_sect, ISZ_T addr)
1243 {
1244 int al;
1245 DTYPE tdtype;
1246 int putval;
1247 INT loc_base, skip_cnt;
1248 ISZ_T repeat_cnt;
1249 DREC *p;
1250 ISZ_T i8cnt = 0;
1251 int ptrcnt = 0;
1252 char *cptrCopy = strdup(cptr);
1253 char *ptr = cptrCopy;
1254
1255 loc_base = 0;
1256 repeat_cnt = 1;
1257 first_data = 1;
1258 for (; dsrtp; dsrtp = dsrtp->next) {
1259 loc_base = dsrtp->offset; /* assumes this is a DINIT_LOC */
1260
1261 if (dsrtp->sectionindex != DATA_SEC) {
1262 gbl.func_count = dsrtp->func_count;
1263 } else {
1264 if (addr < dsrtp->offset) {
1265 skip_cnt = dsrtp->offset - addr;
1266 if (ptrcnt) {
1267 if (!first_data && skip_cnt)
1268 fputs(", ", ASMFIL);
1269 if (!i8cnt) {
1270 ptr = put_next_member(ptr);
1271 fputc('[', ASMFIL);
1272 }
1273 ptrcnt = 0;
1274 } else if (!i8cnt) {
1275 if (!first_data && skip_cnt)
1276 fputs(", ", ASMFIL);
1277 ptr = put_next_member(ptr);
1278 fputc('[', ASMFIL);
1279 } else if (i8cnt) {
1280 if (!first_data && skip_cnt)
1281 fputs(", ", ASMFIL);
1282 }
1283 i8cnt = i8cnt + put_skip(addr, dsrtp->offset);
1284 first_data = 0;
1285 addr = dsrtp->offset;
1286 } else if (addr > dsrtp->offset) {
1287 error(S_0164_Overlapping_data_initializations_of_OP1, ERR_Warning, 0,
1288 SYMNAME(dsrtp->sptr), CNULL);
1289 continue;
1290 }
1291 }
1292
1293 dinit_fseek(dsrtp->filepos);
1294 while ((p = dinit_read())) {
1295 tdtype = p->dtype;
1296 if (tdtype == DINIT_LOC || tdtype == DINIT_SLOC) {
1297 loc_base = ADDRESSG(p->conval);
1298 break;
1299 }
1300 if (tdtype == DINIT_SECT || tdtype == DINIT_DATASECT) {
1301 if (stop_at_sect) {
1302 if (i8cnt)
1303 fputs("] ", ASMFIL);
1304 return dsrtp;
1305 }
1306 break;
1307 }
1308
1309 if ((((int)tdtype) >= 0) && (DTY(tdtype) == TY_STRUCT) &&
1310 ALLDEFAULTINITG(DTyAlgTyTag(tdtype)))
1311 break;
1312
1313 if (DBGBIT(5, 32))
1314 fprintf(gbl.dbgfil, "call emit_init: i8cnt:%ld ptrcnt:%d\n", i8cnt,
1315 ptrcnt);
1316
1317 emit_init(p->dtype, p->conval, &addr, &repeat_cnt, loc_base, &i8cnt,
1318 &ptrcnt, &ptr);
1319 }
1320 }
1321
1322 if (size >= 0) {
1323 INT skip_size = size - addr;
1324 if (skip_size > 0) {
1325 if (ptrcnt) {
1326 if (!first_data && skip_size)
1327 fprintf(ASMFIL, ", ");
1328 if (!i8cnt) {
1329 ptr = put_next_member(ptr);
1330 fprintf(ASMFIL, "zeroinitializer ");
1331 free(cptrCopy);
1332 return dsrtp;
1333 }
1334 ptrcnt = 0;
1335 } else if (!i8cnt) {
1336 if (!first_data && skip_size)
1337 fprintf(ASMFIL, ", ");
1338 ptr = put_next_member(ptr);
1339 fprintf(ASMFIL, "[");
1340 } else if (i8cnt) {
1341 if (!first_data && skip_size)
1342 fprintf(ASMFIL, ", ");
1343 }
1344 } else if (i8cnt) {
1345 fprintf(ASMFIL, "] ");
1346 }
1347 put_skip(addr, size);
1348 i8cnt = skip_size;
1349 }
1350 free(cptrCopy);
1351 if (i8cnt)
1352 fprintf(ASMFIL, "] ");
1353
1354 return dsrtp;
1355 }
1356
1357 /* Contains the functionality of process_extern_dsrt() */
1358 static void
write_extern_inits(void)1359 write_extern_inits(void)
1360 {
1361 SPTR sptr;
1362 int vargblsym, typegblsym, align8, needsCast;
1363 DSRT *dsrtp;
1364 char gname[256], *typed;
1365 const char *prefix;
1366
1367 if (!extern_inits)
1368 return; /* nothing to do */
1369
1370 /* Output the initialized values of the externals */
1371 for (dsrtp = extern_inits; dsrtp; dsrtp = dsrtp ? dsrtp->next : dsrtp) {
1372 sptr = dsrtp->sptr;
1373 if (DBGBIT(5, 32))
1374 fprintf(gbl.dbgfil, "write_extern_inits: %s\n", getsname(sptr));
1375 sprintf(gname, "struct%s", getsname(sptr));
1376
1377 /* Get the global symbol or create it if it does not yet exist */
1378 vargblsym = get_ag(sptr);
1379
1380 /* Set 'addr' to dsrtp->offset, to avoid generating 'skip' bytes */
1381 if (DT_ISBASIC(DTYPEG(sptr)) || (STYPEG(sptr) == ST_ARRAY)) {
1382 typed = strdup(make_lltype_from_dtype(DTYPEG(sptr))->str);
1383 needsCast = true;
1384 } else {
1385 typed = get_struct_from_dsrt(sptr, dsrtp, SIZEG(sptr), &align8, true,
1386 dsrtp->offset);
1387 needsCast = llassem_struct_needs_cast(sptr);
1388 }
1389
1390 /* Save the typedef (if it hasn't already been saved) */
1391 get_typedef_ag(gname, typed);
1392 typegblsym = find_ag(gname);
1393 if (CFUNCG(sptr) && SCG(sptr) == SC_EXTERN) {
1394 DTYPE ttype;
1395 if (DT_ISBASIC(DTYPEG(sptr))) {
1396 ttype = DTYPEG(sptr);
1397 } else {
1398 ttype = mk_struct_for_llvm_init(getsname(sptr), SIZEG(sptr));
1399 }
1400 set_ag_lltype(typegblsym, make_lltype_from_dtype(ttype));
1401 }
1402
1403 #ifdef CUDAG
1404 /* Prefix: If cuda then emit internal global (for acc.plat0) */
1405 if (CUDAG(gbl.currsub) && CFUNCG(sptr) && SCG(sptr) == SC_STATIC)
1406 prefix = "internal global ";
1407 else if (CFUNCG(sptr) && SCG(sptr) == SC_STATIC) /* openacc */
1408 prefix = "internal global ";
1409 else
1410 prefix = "global ";
1411 #else
1412 prefix = "global ";
1413 #endif
1414 /* Output the struct and data for the struct */
1415 if (needsCast) {
1416 int dummy;
1417 char *bare = get_struct_from_dsrt(SPTR_NULL, dsrtp, SIZEG(sptr), &dummy,
1418 true, dsrtp->offset);
1419 char *alTy = "";
1420 char *alSep = "";
1421 fprintf(ASMFIL,
1422 "%%struct%s = type %s\n"
1423 "@%s.%d = internal %s<{%s}> <{ ",
1424 getsname(sptr), typed, getsname(sptr), sptr, prefix, bare);
1425 dsrtp = process_dsrt(dsrtp, -1, bare, false, dsrtp->offset);
1426 if (get_llvm_version() >= LL_Version_3_8) {
1427 alTy = typed;
1428 alSep = ", ";
1429 }
1430 fprintf(ASMFIL, " }>\n@%s = alias %s%sbitcast (<{%s}>* @%s.%d to %s*)",
1431 getsname(sptr), alTy, alSep, bare, getsname(sptr), sptr, typed);
1432 free(bare);
1433 } else {
1434 fprintf(ASMFIL, "%%struct%s = type <{ %s }>\n@%s = %s%%struct%s <{ ",
1435 getsname(sptr), typed, getsname(sptr), prefix, getsname(sptr));
1436 /* Setting size to -1, to ignore 'skip' bytes */
1437 dsrtp = process_dsrt(dsrtp, -1, typed, false, dsrtp->offset);
1438 fputs(" }>", ASMFIL);
1439 /* mark it that it has been emitted */
1440 if (AG_DSIZE(vargblsym) <= 0)
1441 AG_DSIZE(vargblsym) = 1;
1442 }
1443 #ifdef CUDAG
1444 if (CUDAG(gbl.currsub) && CFUNCG(sptr) && SCG(sptr) == SC_STATIC)
1445 fputs(", align 16", ASMFIL);
1446 #endif
1447 fputc('\n', ASMFIL);
1448 free(typed);
1449 }
1450 }
1451
1452 static void
write_bss(void)1453 write_bss(void)
1454 {
1455 /* XXX: "global" and not "internal global"
1456 * hack until llvm opt allows us to specify section attribute flags
1457 * LLVM opt is marking certain variables constant and others remain
1458 * mutable. The user defined section will get the attributes (write or
1459 * read-only) based on the first object being added to the section. If
1460 * the first object is read-only and subsequent objects are writeable,
1461 * a segfault will ensue, as llvm will emit the section as read-only in
1462 * this case: http://llvm.org/bugs/show_bug.cgi?id=17246
1463 */
1464 int gblsym;
1465 char *type_str = "internal global";
1466 char *bss_nm = bss_name;
1467
1468 if (gbl.bss_addr) {
1469 fprintf(ASMFIL, "%%struct%s = type <{[%" ISZ_PF "d x i8]}>\n", bss_nm,
1470 gbl.bss_addr);
1471 fprintf(ASMFIL,
1472 "@%s = %s %%struct%s <{[%" ISZ_PF "d x i8] "
1473 "zeroinitializer }> , align 32",
1474 bss_nm, type_str, bss_nm, gbl.bss_addr);
1475 ll_write_object_dbg_references(ASMFIL, cpu_llvm_module, bss_dbg_list);
1476 bss_dbg_list = NULL;
1477 fputc('\n', ASMFIL);
1478 gbl.bss_addr = 0;
1479 }
1480 } /* write_bss */
1481
1482 /**
1483 \brief get the altname string for the given \p sptr
1484 \param sptr the symbol
1485 */
1486 static char *
get_altname(SPTR sptr)1487 get_altname(SPTR sptr)
1488 {
1489 int ss, len;
1490 static char name[MXIDLN];
1491
1492 ss = ALTNAMEG(sptr);
1493 len = DTyCharLength(DTYPEG(ss));
1494 if (len >= MXIDLN)
1495 len = MXIDLN - 1;
1496 strncpy(name, stb.n_base + CONVAL1G(ss), len);
1497 name[len] = '\0';
1498 #if defined(TARGET_WIN)
1499 if (DECORATEG(sptr)) {
1500 const bool can_annotate = ((ARGSIZEG(sptr) == -1) || (ARGSIZEG(sptr) > 0));
1501 const int arg_size = (ARGSIZEG(sptr) > 0) ? ARGSIZEG(sptr) : 0;
1502 if (can_annotate) {
1503 sprintf(name, "%s@%d", name, arg_size);
1504 }
1505 }
1506 #endif
1507 return name;
1508 }
1509
1510 static void
write_statics(void)1511 write_statics(void)
1512 {
1513 /* XXX: "global" and not "internal global"
1514 * hack until llvm opt allows us to specify section attribute flags
1515 * LLVM opt is marking certain variables constant and others remain
1516 * mutable. The user defined section will get the attributes (write or
1517 * read-only) based on the first object being added to the section. If
1518 * the first object is read-only and subsequent objects are writeable,
1519 * a segfault will ensue, as llvm will emit the section as read-only in
1520 * this case: http://llvm.org/bugs/show_bug.cgi?id=17246
1521 */
1522 char *type_str = "internal global";
1523 char gname[MXIDLN + 50];
1524 char *typed = NULL;
1525 int align8 = 16;
1526 SPTR gblsym, sptr;
1527 DSRT *dsrtp;
1528 int count = 0;
1529 char *static_nm = static_name;
1530
1531 if (lcl_inits) {
1532 if (DBGBIT(5, 32)) {
1533 fprintf(gbl.dbgfil, "write_statics:%s\n", static_nm);
1534 }
1535 sprintf(gname, "struct%s", static_nm);
1536 typed = get_struct_from_dsrt(SPTR_NULL, lcl_inits, gbl.saddr, &align8,
1537 false, 0);
1538 get_typedef_ag(gname, typed);
1539 free(typed);
1540 gblsym = find_ag(gname);
1541 typed = AG_TYPENAME(gblsym);
1542 fprintf(ASMFIL, "%%struct%s = type <{ %s }>\n", static_nm, typed);
1543 fprintf(ASMFIL, "@%s = %s %%struct%s <{ ", static_nm, type_str, static_nm);
1544 process_dsrt(lcl_inits, gbl.saddr, typed, false, 0);
1545 fprintf(ASMFIL, " }>, align 16");
1546 ll_write_object_dbg_references(ASMFIL, cpu_llvm_module, static_dbg_list);
1547 static_dbg_list = NULL;
1548 fputc('\n', ASMFIL);
1549 count++;
1550 } else if (gbl.saddr && !gbl.outlined) {
1551 fprintf(ASMFIL, "%%struct%s = type <{ [%ld x i8] }>\n", static_name,
1552 (long)gbl.saddr);
1553 fprintf(ASMFIL,
1554 "@%s = %s %%struct%s <{ [%ld x i8] zeroinitializer }>"
1555 ", align 16",
1556 static_name, type_str, static_name, (long)gbl.saddr);
1557 ll_write_object_dbg_references(ASMFIL, cpu_llvm_module, static_dbg_list);
1558 static_dbg_list = NULL;
1559 fputc('\n', ASMFIL);
1560 }
1561
1562 for (dsrtp = section_inits; dsrtp; dsrtp = dsrtp->next) {
1563 sptr = dsrtp->sptr;
1564 count++;
1565 if (DBGBIT(5, 32)) {
1566 fprintf(gbl.dbgfil, "write_statics (section_inits): %s\n",
1567 getsname(sptr));
1568 }
1569 typed = get_struct_from_dsrt(sptr, dsrtp, SIZEG(sptr), &align8, true, 0);
1570 #ifdef OMP_OFFLOAD_LLVM
1571 if (OMPACCSTRUCTG(sptr)) {
1572 write_libomptarget_statics(sptr, gname, typed, gblsym, dsrtp);
1573 count--;
1574 continue;
1575 }
1576 #endif
1577 sprintf(gname, "struct%s", getsname(sptr));
1578 get_typedef_ag(gname, typed);
1579 free(typed);
1580 gblsym = find_ag(gname);
1581 typed = AG_TYPENAME(gblsym);
1582
1583 fprintf(ASMFIL, "%%struct%s = type < { %s } >\n", getsname(sptr), typed);
1584 fprintf(ASMFIL, "@%s = %s %%struct%s ", getsname(sptr), type_str,
1585 getsname(sptr));
1586 fprintf(ASMFIL, " <{ ");
1587 process_dsrt(dsrtp, gbl.saddr, typed, true, 0);
1588 fprintf(ASMFIL, " }>");
1589 fprintf(ASMFIL, ", section \"%s\"", sections[dsrtp->sectionindex].name);
1590 if (sections[dsrtp->sectionindex].align)
1591 fprintf(ASMFIL, ", align %d", sections[dsrtp->sectionindex].align);
1592 // ll_write_object_dbg_references(ASMFIL, cpu_llvm_module,
1593 // get_section_debug_list(sptr)); get_section_debug_list(sptr) = NULL;
1594 fputc('\n', ASMFIL);
1595 }
1596
1597 /* Only create when count > 1, it only creates when section_inits is present.
1598 *
1599 * NOTE: If we were to have llvm.used on other variable - we may have updated
1600 * our implementation so that it only collect information here and print
1601 * in assemble_end. It only allows one instance per file.
1602 */
1603 if (count > 1) {
1604 if (count) {
1605 fprintf(ASMFIL, "@llvm.used = appending global [%d x i8*] [\n", count);
1606 if (lcl_inits) {
1607 fprintf(ASMFIL, "i8* bitcast (%%struct%s* @%s to i8*)", static_nm,
1608 static_nm);
1609 if (section_inits)
1610 fputc(',', ASMFIL);
1611 fputc('\n', ASMFIL);
1612 }
1613 for (dsrtp = section_inits; dsrtp; dsrtp = dsrtp->next) {
1614 #ifdef OMP_OFFLOAD_LLVM
1615 if (OMPACCSTRUCTG(sptr))
1616 continue;
1617 #endif
1618 sptr = dsrtp->sptr;
1619 fprintf(ASMFIL, "i8* bitcast (%%struct%s* @%s to i8*)", getsname(sptr),
1620 getsname(sptr));
1621 if (dsrtp->next)
1622 fputc(',', ASMFIL);
1623 fputc('\n', ASMFIL);
1624 }
1625 fputs("], section \"llvm.metadata\"\n", ASMFIL);
1626 }
1627 }
1628 lcl_inits = NULL;
1629 section_inits = NULL;
1630 extern_inits = NULL;
1631
1632 } /* write_statics */
1633
1634 static void
write_comm(void)1635 write_comm(void)
1636 {
1637 SPTR sptr, gblsym, cmsym;
1638 int align8;
1639 char *name;
1640 int align_value;
1641 char *typed;
1642 char gname[MXIDLN + 50];
1643
1644 for (sptr = gbl.cmblks; sptr > NOSYM; sptr = SYMLKG(sptr)) {
1645 SPTR cmem;
1646
1647 first_data = 1;
1648 process_sptr(sptr);
1649 if ((cmsym = get_ag(sptr)) == 0)
1650 continue; /* name conflict occurred */
1651
1652 if (!DINITG(sptr)) /* process this only when dinit */
1653 continue;
1654
1655 if (AG_DSIZE(cmsym))
1656 continue; /* already init'd, get_ag issues error */
1657
1658 AG_DSIZE(cmsym) = SIZEG(sptr);
1659
1660 name = get_llvm_name(sptr);
1661 sprintf(gname, "struct%s", name);
1662
1663 /* size may varies - redo if init */
1664 typed =
1665 get_struct_from_dsrt(sptr, DSRTG(sptr), SIZEG(sptr), &align8, false, 0);
1666 get_typedef_ag(gname, typed);
1667 gblsym = find_ag(gname);
1668
1669 align_value = CACHE_ALIGN + 1;
1670
1671 fprintf(ASMFIL, "%%struct%s = type < { %s } > \n", name, typed);
1672 fprintf(ASMFIL, "@%s = global %%struct%s", name, name);
1673 fprintf(ASMFIL, " < { ");
1674 process_dsrt(DSRTG(sptr), SIZEG(sptr), typed, false, 0);
1675 fprintf(ASMFIL, " } > ");
1676
1677 DSRTP(sptr, NULL);
1678
1679 fprintf(ASMFIL, ", align %d", align_value);
1680
1681 for (cmem = CMEMFG(sptr); cmem > NOSYM; cmem = SYMLKG(cmem)) {
1682 if (MIDNUMG(cmem)) /* some member does not have midnum/no name */
1683 process_sptr(cmem);
1684 if (flg.debug) {
1685 LL_MDRef mdref = ll_get_global_debug(cpu_llvm_module, cmem);
1686 if (!LL_MDREF_IS_NULL(mdref))
1687 print_dbg_line(mdref);
1688 }
1689 }
1690 fprintf(ASMFIL, "\n");
1691
1692 free(typed);
1693 }
1694
1695 for (sptr = gbl.threadprivate; sptr > NOSYM; sptr = TPLNKG(sptr)) {
1696 if (SCG(sptr) != SC_STATIC) {
1697 /* find it and it is not found create it. */
1698 name = get_llvm_name(sptr);
1699 gblsym = find_ag(name);
1700 if (!gblsym) {
1701 gblsym = make_gblsym(sptr, get_llvm_name(sptr));
1702 AG_SYMLK(gblsym) = ag_other;
1703 ag_other = gblsym;
1704 AG_SIZE(gblsym) = size_of(DTYPEG(sptr));
1705 if (XBIT(69, 0x80))
1706 AG_ISTLS(gblsym) = 1;
1707 else
1708 AG_ISTLS(gblsym) = 0;
1709 }
1710 add_ag_typename(gblsym, char_type(DTYPEG(sptr), SPTR_NULL));
1711 }
1712 }
1713 }
1714
1715 static int
has_final_members(int sptr,int visit_flag)1716 has_final_members(int sptr, int visit_flag)
1717 {
1718
1719 typedef struct visitDty {
1720 int dty;
1721 struct visitDty *next;
1722 } VISITDTY;
1723
1724 static VISITDTY *visit_list;
1725 VISITDTY *curr, *new_visit, *prev;
1726
1727 int rslt;
1728 DTYPE dtype = DTYPEG(sptr);
1729 int member;
1730
1731 if (DTY(dtype) == TY_ARRAY)
1732 dtype = DTySeqTyElement(dtype);
1733
1734 if (DTY(dtype) != TY_STRUCT)
1735 return 0;
1736
1737 if (visit_list) {
1738 for (curr = visit_list; curr; curr = curr->next) {
1739 if (curr->dty == dtype)
1740 return 0;
1741 }
1742 }
1743
1744 NEW(new_visit, VISITDTY, 1);
1745 new_visit->dty = dtype;
1746 new_visit->next = visit_list;
1747 visit_list = new_visit;
1748
1749 rslt = 0;
1750 for (member = DTyAlgTyMember(dtype); member > NOSYM;
1751 member = SYMLKG(member)) {
1752 if (FINALG(member)) {
1753 rslt = 1;
1754 break;
1755 } else if (has_final_members(member, 1)) {
1756 rslt = 1;
1757 break;
1758 }
1759 }
1760
1761 if (!visit_flag && visit_list) {
1762 for (prev = curr = visit_list; curr;) {
1763
1764 curr = curr->next;
1765 FREE(prev);
1766 prev = curr;
1767 }
1768 visit_list = 0;
1769 }
1770
1771 return rslt;
1772 }
1773
1774 /* Compute the number of entries that will be written by write_layout_desc().
1775 * If the logic here doesn't match write_layout_desc() we will fail an assert
1776 * in end_layout_desc(). */
1777 static int
count_members(DTYPE dtype)1778 count_members(DTYPE dtype)
1779 {
1780 SPTR member;
1781 int count = 0;
1782 for (member = DTyAlgTyMember(dtype); member > NOSYM;
1783 member = SYMLKG(member)) {
1784 DTYPE dty = DTYPEG(member);
1785 if (CLASSG(member) && TBPLNKG(member)) {
1786 continue; /* skip type bound procedure members */
1787 }
1788 if (PARENTG(member)) {
1789 count += count_members(dty);
1790 } else if (POINTERG(member) || has_final_members(member, 0)) {
1791 count += 1;
1792 } else if (DTY(dty) == TY_STRUCT && !CCSYMG(member)) {
1793 count += count_members(dty);
1794 }
1795 }
1796 return count;
1797 }
1798
1799 /* Call this before write_layout_desc(). */
1800 static void
begin_layout_desc(SPTR sptr,DTYPE dtype)1801 begin_layout_desc(SPTR sptr, DTYPE dtype)
1802 {
1803 int members = count_members(dtype);
1804
1805 layout_desc.sptr = sptr;
1806 layout_desc.entries = 0;
1807 layout_desc.expected_entries = members;
1808 if (members > 0) {
1809 char name[256], buf[256];
1810 int gblsym;
1811 int subscript_size = is_BIGOBJ() ? 64 : 32;
1812
1813 if (!layout_desc.wrote_tname) {
1814 /* First time, write the layout type: Each member is a struct */
1815 fprintf(ASMFIL, "%s = type < { [6 x i%d], i8* } >\n", layout_desc.tname,
1816 subscript_size);
1817 layout_desc.wrote_tname = true;
1818 }
1819
1820 /* Write the array of members (the actual layout descriptor) */
1821 sprintf(name, "%s$ld", SYMNAME(layout_desc.sptr));
1822 sprintf(buf, "%%struct.ld.%s", getsname(layout_desc.sptr));
1823 fprintf(ASMFIL, "%s = type < { [%d x %s], [7 x i%d] } >\n", buf, members,
1824 layout_desc.tname, subscript_size);
1825
1826 /* The layout description instance */
1827 fprintf(ASMFIL, "@%s = global %s < {\n", name, buf);
1828 fprintf(ASMFIL, " [%d x %s] [\n", members, layout_desc.tname);
1829
1830 /* Add to the ag list */
1831 get_typedef_ag(name, buf);
1832 gblsym = find_ag(name);
1833 AG_DEFD(gblsym) = 1;
1834 }
1835 }
1836
1837 /**
1838 \brief If there were any entries in the layout descriptor, terminate with
1839 all-0 entry and return true.
1840 */
1841 static bool
end_layout_desc(void)1842 end_layout_desc(void)
1843 {
1844 bool any_entries = layout_desc.entries > 0;
1845 #if DEBUG
1846 /* if this fails, logic in count_members doesn't match write_layout_desc */
1847 assert(layout_desc.entries == layout_desc.expected_entries,
1848 "end_layout_desc: wrong number of layout descriptor entries", 0,
1849 ERR_Fatal);
1850 #endif
1851 if (any_entries) {
1852 int subscript_size = is_BIGOBJ() ? 64 : 32;
1853 /* The end of the layout descriptor */
1854 fprintf(ASMFIL, " ],\n");
1855 fprintf(
1856 ASMFIL,
1857 " [7 x i%d] [i%d 0, i%d 0, i%d 0, i%d 0, i%d -1, i%d 0, i%d 0]\n} >\n",
1858 subscript_size, subscript_size, subscript_size, subscript_size,
1859 subscript_size, subscript_size, subscript_size, subscript_size);
1860 }
1861 layout_desc.sptr = SPTR_NULL;
1862 layout_desc.entries = 0;
1863 return any_entries;
1864 }
1865
1866 /**
1867 \brief Write an entry in the layout desc for this member
1868 */
1869 static void
write_layout_desc_entry(char tag,int offset,SPTR member,int length,SPTR sdsc)1870 write_layout_desc_entry(char tag, int offset, SPTR member, int length,
1871 SPTR sdsc)
1872 {
1873 int subscript_size = is_BIGOBJ() ? 64 : 32;
1874 int desc_offset = -1;
1875 int mem_offset = offset + ADDRESSG(member);
1876
1877 if (SDSCG(member)) {
1878 desc_offset = offset + ADDRESSG(SDSCG(member));
1879 #if DEBUG
1880 assert(desc_offset > 0, "write_layout_desc_entry: desc_offset is 0",
1881 desc_offset, ERR_Severe);
1882 #endif
1883 }
1884
1885 #if DEBUG
1886 fprintf(ASMFIL, " ; member: '%s'\n", SYMNAME(member));
1887 #endif
1888 /* Write the member data */
1889 fprintf(ASMFIL, " %s < {\n", layout_desc.tname);
1890 fprintf(ASMFIL, " [6 x i%d] [", subscript_size);
1891 fprintf(ASMFIL, "i%d %d, ", subscript_size, tag);
1892 fprintf(ASMFIL, "i%d 0, ", subscript_size);
1893 fprintf(ASMFIL, "i%d %d, ", subscript_size, mem_offset);
1894 fprintf(ASMFIL, "i%d %d, ", subscript_size, length);
1895 fprintf(ASMFIL, "i%d %d, ", subscript_size, desc_offset);
1896 fprintf(ASMFIL, "i%d 0],\n", subscript_size);
1897
1898 if (sdsc == 0) {
1899 fprintf(ASMFIL, " i8* null\n");
1900 } else { /* Else a pointer to the typedef which is of type: struct<name> */
1901 process_sptr(sdsc);
1902 fprintf(ASMFIL, " i8* bitcast(%%struct%s* @%s to i8*)\n",
1903 getsname(sdsc), getsname(sdsc));
1904 }
1905 fprintf(ASMFIL, " } >");
1906 if (++layout_desc.entries < layout_desc.expected_entries)
1907 fprintf(ASMFIL, ",");
1908 fprintf(ASMFIL, "\n");
1909 }
1910
1911 /* Write a layout desc for this dtype, recursing into nested derived types.
1912 offset is the distance of this dtype from the start of the outermost one.
1913 Call begin_layout_desc() and end_layout_desc() before and after this. */
1914 static void
write_layout_desc(DTYPE dtype,int offset)1915 write_layout_desc(DTYPE dtype, int offset)
1916 {
1917 SPTR member;
1918
1919 for (member = DTyAlgTyMember(dtype); member > NOSYM;
1920 member = SYMLKG(member)) {
1921 bool finals = has_final_members(member, 0);
1922 DTYPE dty = DTYPEG(member);
1923 TY_KIND ty = DTY(dty);
1924 if (CLASSG(member) && TBPLNKG(member)) {
1925 continue; /* skip type bound procedure members */
1926 }
1927 if (PARENTG(member)) {
1928 write_layout_desc(dty, offset);
1929 } else if (POINTERG(member) || finals) {
1930 char tag;
1931 SPTR sdsc;
1932 bool unknown;
1933 int length;
1934 DTYPE dty2 = DDTG(dty);
1935
1936 if (!POINTERG(member)) {
1937 tag = 'F'; /* finalized object */
1938 } else if (ty == TY_STRUCT && dtype == dty) {
1939 tag = 'R'; /* recursive pointer to derived type */
1940 } else if (ALLOCATTRG(member) || TPALLOCG(member)) {
1941 tag = 'T';
1942 } else if (ty == TY_STRUCT) {
1943 tag = 'D'; /* regular pointer to derived type */
1944 } else if (ty == TY_PTR) {
1945 tag = 'S'; /* procedure ptr */
1946 } else {
1947 tag = 'P';
1948 }
1949 if (DTY(dty2) == TY_STRUCT) {
1950 SPTR ty = DTyAlgTyTag(dty2);
1951 sdsc = SDSCG(ty);
1952 } else {
1953 sdsc = SPTR_NULL;
1954 }
1955 unknown = dty2 == DT_ASSCHAR || dty2 == DT_DEFERCHAR;
1956 length = (CLASSG(member) || unknown) ? 0 : size_of(dty);
1957 write_layout_desc_entry(tag, offset, member, length, sdsc);
1958 } else if (ty == TY_STRUCT && !CCSYMG(member)) {
1959 write_layout_desc(dty, ADDRESSG(member));
1960 }
1961 }
1962 }
1963
1964 static int
count_parent_pointers(int parent,int level)1965 count_parent_pointers(int parent, int level)
1966 {
1967 const DTYPE dtype = DTYPEG(parent);
1968 SPTR member;
1969 if (DTY(dtype) != TY_STRUCT)
1970 return level;
1971 member = DTyAlgTyMember(dtype);
1972 ++level;
1973 if (!PARENTG(member))
1974 return level;
1975 return count_parent_pointers(PARENTG(member), level);
1976 }
1977
1978 static void
write_parent_pointers(int parent,int level)1979 write_parent_pointers(int parent, int level)
1980 {
1981 SPTR member;
1982 SPTR tag;
1983 int gblsym;
1984 SPTR desc;
1985 char tdtname[MAXIDLEN];
1986 const DTYPE dtype = DTYPEG(parent);
1987
1988 if (DTY(dtype) != TY_STRUCT)
1989 return;
1990
1991 member = DTyAlgTyMember(dtype);
1992 tag = DTyAlgTyTag(dtype);
1993 desc = SDSCG(tag);
1994 fprintf(ASMFIL, " i8* bitcast(%%struct%s* @%s to i8*)",
1995 get_llvm_name(SDSCG(tag)), get_llvm_name(SDSCG(tag)));
1996
1997 if (SCG(desc) == SC_EXTERN && CLASSG(desc) && DESCARRAYG(desc)) {
1998 sprintf(tdtname, "struct%s", get_llvm_name(desc));
1999 if (get_typedef_ag(get_llvm_name(desc), tdtname) == 0) {
2000 /* If newly added... (i.e., above get_typedef_ag returns zero) */
2001 gblsym = find_ag(get_llvm_name(desc));
2002 AG_TYPEDESC(gblsym) = 1;
2003 }
2004 }
2005
2006 if (level > 1)
2007 fprintf(ASMFIL, ",");
2008 --level;
2009 fprintf(ASMFIL, "\n");
2010
2011 if (!PARENTG(member))
2012 return;
2013
2014 write_parent_pointers(PARENTG(member), level);
2015 }
2016
2017 /* final table size is max dimensions plus 2. The 0th element holds the
2018 * scalar subroutine and the last element holds the elemental subroutine.
2019 */
2020 #define FINAL_TABLE_SZ 9
2021
2022 static int
build_final_table(DTYPE dtype,SPTR ft[FINAL_TABLE_SZ])2023 build_final_table(DTYPE dtype, SPTR ft[FINAL_TABLE_SZ])
2024 {
2025 SPTR mem;
2026 int i, j;
2027
2028 for (i = 0; i < FINAL_TABLE_SZ; ++i)
2029 ft[i] = SPTR_NULL;
2030 for (j = 0, mem = DTyAlgTyMember(dtype); mem > NOSYM; mem = SYMLKG(mem)) {
2031 if (CLASSG(mem) && (i = FINALG(mem))) {
2032 if (i < 0)
2033 return -1;
2034 ft[i - 1] = VTABLEG(mem);
2035 j++;
2036 }
2037 }
2038 return j;
2039 }
2040
2041 /* Returns the number of entries in the finalizer table */
2042 static int
write_final_table(SPTR sptr,DTYPE dtype)2043 write_final_table(SPTR sptr, DTYPE dtype)
2044 {
2045 int i;
2046 SPTR ft[FINAL_TABLE_SZ];
2047 SPTR entry;
2048 SPTR gblsym;
2049 char tname[256];
2050 LL_Type *ttype;
2051
2052 i = build_final_table(dtype, ft);
2053 if (i > 0) {
2054 /* Check to see if this table has already been generated */
2055 get_typedef_ag(getsname(sptr), NULL);
2056 gblsym = find_ag(getsname(sptr));
2057 if (AG_DEFD(gblsym))
2058 return 0;
2059
2060 /* Add type name to ag table and define this table */
2061 sprintf(tname, "[%d x i8*]", FINAL_TABLE_SZ);
2062 if ((gblsym = get_typedef_ag(getsname(sptr), tname)) ||
2063 (gblsym = find_ag(getsname(sptr))))
2064 AG_DEFD(gblsym) = 1;
2065
2066 fprintf(ASMFIL, "@%s = weak global %s [", getsname(sptr), tname);
2067 for (i = 0; i < FINAL_TABLE_SZ; ++i) {
2068 entry = ft[i];
2069 if (entry) {
2070 const char *fntype;
2071 LL_ABI_Info *abi = ll_proto_get_abi(ll_proto_key(entry));
2072 gblsym = get_ag(entry);
2073 AG_DEFD(gblsym) = 1;
2074 fntype = abi ? ll_abi_function_type(abi)->str : "(i8*)";
2075 fprintf(ASMFIL, "i8* bitcast(%s* @%s to i8*)", fntype,
2076 get_llvm_name(entry));
2077 } else
2078 fprintf(ASMFIL, "i8* null");
2079
2080 if (i < FINAL_TABLE_SZ - 1)
2081 fprintf(ASMFIL, ", ");
2082 }
2083 fprintf(ASMFIL, "]\n");
2084
2085 if (!LLTYPE(sptr)) {
2086 ttype = make_array_lltype(
2087 FINAL_TABLE_SZ, make_ptr_lltype(make_lltype_from_dtype(DT_INT)));
2088 LLTYPE(sptr) = ttype;
2089 /* make sure it is i32 */
2090 // FIXME: why is the pointer being coerced to 32 bits here? On 64 bit
2091 // systems, how is this correct?
2092 }
2093 }
2094
2095 /* Return the number of entries created */
2096 if (i < 0)
2097 return i;
2098
2099 return 0;
2100 }
2101
2102 static int
has_final_procedures(int sptr)2103 has_final_procedures(int sptr)
2104 {
2105 /* Return true if dtype associated with sptr has final procedures that
2106 * are ready to be written to assembly file (they have been processed)
2107 */
2108
2109 DTYPE dtype;
2110 SPTR mem;
2111 char *name;
2112 int len;
2113
2114 name = SYMNAME(sptr);
2115 len = strlen(name);
2116
2117 if (len < 3 || strcmp(name + (len - 3), "$ft") != 0)
2118 return 0;
2119
2120 dtype = DTYPEG(sptr);
2121 dtype = DTyArgType(dtype);
2122
2123 for (mem = DTyAlgTyMember(dtype); mem > NOSYM; mem = SYMLKG(mem)) {
2124 if (CLASSG(mem) && FINALG(mem) > 0)
2125 return 1;
2126 }
2127 return 0;
2128 }
2129
2130 static int
has_pending_final_procedures(SPTR sptr)2131 has_pending_final_procedures(SPTR sptr)
2132 {
2133
2134 /* Return true if dtype associated with sptr has final procedures but
2135 * they have not been fully processed yet.
2136 */
2137
2138 DTYPE dtype;
2139 SPTR mem;
2140
2141 dtype = DTYPEG(sptr);
2142 dtype = DTyArgType(dtype);
2143
2144 for (mem = DTyAlgTyMember(dtype); mem > NOSYM; mem = SYMLKG(mem)) {
2145 if (CLASSG(mem) && FINALG(mem) < 0)
2146 return 1;
2147 }
2148 return 0;
2149 }
2150
2151 static int
build_vft(DTYPE dtype,SPTR ** vft)2152 build_vft(DTYPE dtype, SPTR **vft)
2153 {
2154
2155 SPTR vf;
2156 int vf2, offset;
2157 SPTR *tmp;
2158 SPTR *buf;
2159 static int sz;
2160 int vf_cnt;
2161 SPTR member = DTyAlgTyMember(dtype);
2162 int parent = PARENTG(member);
2163
2164 if (parent) {
2165 vf_cnt = build_vft(DTYPEG(parent), vft);
2166 } else {
2167 vf_cnt = 0;
2168 }
2169
2170 buf = *vft;
2171 if (!buf) {
2172 sz = 0;
2173 }
2174
2175 for (vf = member; vf > NOSYM; vf = SYMLKG(vf)) {
2176 if (CCSYMG(vf) && CLASSG(vf)) {
2177 int bind = TBPLNKG(vf);
2178 SPTR proc = VTABLEG(vf);
2179 if (bind) {
2180 offset = VTOFFG(bind) - 1;
2181 if (offset < 0)
2182 continue;
2183 if (offset >= sz) {
2184 sz = offset + 16;
2185 NEW(tmp, SPTR, sz);
2186 memset(tmp, 0, sz * sizeof(SPTR));
2187 for (vf2 = 0; vf2 < vf_cnt; ++vf2) {
2188 tmp[vf2] = buf[vf2];
2189 }
2190 if (buf)
2191 FREE(buf);
2192 buf = tmp;
2193 }
2194 if (!buf[offset] && offset >= vf_cnt)
2195 vf_cnt = (offset + 1);
2196 buf[offset] = proc;
2197 }
2198 }
2199 }
2200
2201 *vft = buf;
2202 return vf_cnt;
2203 }
2204
2205 static int
write_vft(int sptr,DTYPE dtype)2206 write_vft(int sptr, DTYPE dtype)
2207 {
2208 int i;
2209 SPTR vf;
2210 SPTR *vft;
2211 int vft_sz, gblsym;
2212 char *nmptr, tname[MXIDLN + 50], name[MXIDLN];
2213 const char *fntype;
2214
2215 vft = 0;
2216 vft_sz = build_vft(dtype, &vft);
2217 assert(vft_sz >= 0, "write_vft: Invalid vft size", vft_sz, ERR_Fatal);
2218
2219 if (vft_sz == 0)
2220 return 0;
2221
2222 sprintf(name, "%s$vft", SYMNAME(sptr));
2223 sprintf(tname, "[%d x i8*]", vft_sz);
2224 fprintf(ASMFIL, "@%s = global %s [", name, tname);
2225
2226 /* Add to ag table */
2227 get_typedef_ag(name, tname);
2228 gblsym = find_ag(name);
2229 AG_DEFD(gblsym) = 1;
2230
2231 /* Check dtype of getsname(vf) and bitcast accordingly */
2232 fntype = NULL;
2233 for (i = 0; i < vft_sz; ++i) {
2234 vf = vft[i];
2235 if (vf) {
2236 LL_ABI_Info *abi = ll_proto_get_abi(ll_proto_key(vf));
2237 if (abi)
2238 fntype = ll_abi_function_type(abi)->str;
2239 }
2240 if (vf && !fntype) {
2241 if (STYPEG(vf) == ST_PROC)
2242 fntype = "void()";
2243 else if (SCG(vf) == SC_CMBLK) {
2244 /* example: oop219 - shape_mode_0 is in vft table */
2245 gblsym = find_ag(get_llvm_name(vf));
2246 nmptr = AG_NAME(gblsym);
2247 sprintf(tname, "struct%s", nmptr);
2248 if (!find_ag(tname)) {
2249 fntype = "i8* null";
2250 continue;
2251 }
2252 sprintf(tname, "%%struct%s", nmptr);
2253 }
2254 }
2255
2256 /* Emit the vft entry */
2257 if (vf && fntype)
2258 fprintf(ASMFIL, "i8* bitcast(%s* @%s to i8*)", fntype, getsname(vf));
2259 else
2260 fprintf(ASMFIL, "i8* null");
2261
2262 if (i < (vft_sz - 1))
2263 fprintf(ASMFIL, ", ");
2264 }
2265
2266 fprintf(ASMFIL, "]\n");
2267 FREE(vft);
2268 return vft_sz;
2269 }
2270
2271 /* Create a string in ll to reference the start of a table with
2272 * name @<name><suffix>.
2273 *
2274 * If is_struct is true, then the table is actually a struct and
2275 * n_elts will be ignored.
2276 *
2277 * The only use of is_struct is to generate a pointer to the finalizer created
2278 * in write_final_table().
2279 */
2280 static void
put_ll_table_addr(const char * name,const char * suffix,bool is_struct,int n_elts,bool explicit_gep_type)2281 put_ll_table_addr(const char *name, const char *suffix, bool is_struct,
2282 int n_elts, bool explicit_gep_type)
2283 {
2284 int gblsym;
2285 char buf[256];
2286 char *elem_type;
2287
2288 elem_type = "";
2289 /* Decide if we need extra element type argument to GEP */
2290 if (explicit_gep_type)
2291 elem_type = "i8, ";
2292
2293 asrt(!(n_elts && is_struct));
2294
2295 sprintf(buf, "%s%s", name, suffix);
2296 gblsym = find_ag(buf);
2297
2298 if (n_elts && gblsym)
2299 fprintf(ASMFIL,
2300 "i8* bitcast(i8* getelementptr("
2301 "%si8* bitcast(%s* @%s to i8*), i32 0) to i8*)",
2302 elem_type, AG_TYPENAME(gblsym), AG_NAME(gblsym));
2303 else if (n_elts && !gblsym) /* Usually the case for finalizers */
2304 fprintf(ASMFIL,
2305 "i8* bitcast(i8* getelementptr("
2306 "%si8* bitcast([%d x i8*]* @%s%s to i8*), i32 0) to i8*)",
2307 elem_type, n_elts, name, suffix ? suffix : "");
2308 else if (is_struct)
2309 fprintf(ASMFIL, "i8* bitcast(%s* @%s to i8*)", AG_TYPENAME(gblsym),
2310 AG_NAME(gblsym));
2311 else
2312 fprintf(ASMFIL, "i8* null");
2313 }
2314
2315 static void
write_typedescs(void)2316 write_typedescs(void)
2317 {
2318 SPTR sptr;
2319 DTYPE dtype;
2320 int tag, member, level, vft;
2321 char *last, *name, *sname, *suffix;
2322 char ftname[MXIDLN], tdtname[MXIDLN];
2323 int len, gblsym, eq, has_layout_desc;
2324 int ft, size, integer_size, subscript_size;
2325 int subprog;
2326 SPTR inmod;
2327
2328 integer_size = subscript_size = 32;
2329 integer_size = 64;
2330 if (XBIT(68, 0x1)) {
2331 subscript_size = 64;
2332 }
2333
2334 for (sptr = gbl.typedescs; sptr > NOSYM; sptr = TDLNKG(sptr)) {
2335 if (UPLEVELG(sptr))
2336 continue;
2337
2338 gblsym = 0;
2339 subprog =
2340 (gbl.outersub && SCG(sptr) == SC_EXTERN) ? gbl.outersub : gbl.currsub;
2341 if (has_final_procedures(sptr)) {
2342 dtype = DTYPEG(sptr);
2343 dtype = DTyArgType(dtype);
2344 gblsym = get_ag(sptr);
2345 if (!gblsym)
2346 gblsym = find_ag(get_ag_searchnm(sptr));
2347 if (gblsym)
2348 ft = write_final_table(sptr, dtype);
2349 continue;
2350 } else {
2351 ft = has_pending_final_procedures(sptr);
2352 }
2353 inmod = INMODULEG(subprog);
2354 if (inmod > NOSYM) {
2355 name = SYMNAME(sptr);
2356 if (strncmp(SYMNAME(inmod), name, strlen(SYMNAME(inmod))) != 0) {
2357 continue;
2358 }
2359 } else {
2360 name = SYMNAME(sptr);
2361 if (strncmp(SYMNAME(subprog), name, strlen(SYMNAME(subprog))) != 0) {
2362 continue;
2363 }
2364 }
2365 len = strlen(SYMNAME(sptr)) + 1;
2366 NEW(name, char, len);
2367 strcpy(name, SYMNAME(sptr));
2368 suffix = strchr(name, '$');
2369 if (suffix)
2370 *suffix = '\0';
2371 eq = strcmp(SYMNAME(inmod), name);
2372 /* Do not generate type descriptor if it is not in the scope of the current
2373 subprogram or if subprogram is in a use associated module.
2374
2375 Note: NEEDMOD is set on use associated module names
2376 */
2377 if (inmod > NOSYM && (eq != 0 || NEEDMODG(inmod))) {
2378 FREE(name);
2379 continue;
2380 } else if (eq && strcmp(SYMNAME(subprog), name) != 0) {
2381 FREE(name);
2382 continue;
2383 }
2384 FREE(name);
2385 if (SCG(sptr) == SC_EXTERN) {
2386 gblsym = get_ag(sptr);
2387 if (!gblsym && !(gblsym = find_ag(get_llvm_name(sptr))))
2388 continue;
2389 } else {
2390 gblsym = 0;
2391 }
2392
2393 if (gblsym && AG_DEFD(gblsym))
2394 continue;
2395
2396 dtype = DTYPEG(sptr);
2397 dtype = DTyArgType(dtype);
2398 tag = DTyAlgTyTag(dtype);
2399 member = DTyAlgTyMember(dtype);
2400 begin_layout_desc(sptr, dtype);
2401 write_layout_desc(dtype, 0);
2402 has_layout_desc = end_layout_desc();
2403
2404 vft = write_vft(sptr, dtype);
2405 level = 0;
2406 sname = SYMNAME(sptr);
2407
2408 if (ft) {
2409 const char *suffix;
2410 int gs;
2411 LIBSYMP(sptr, XBIT(119, 0x2000000) != 0); // suppress double underscore
2412 name = getsname(sptr);
2413 LIBSYMP(sptr, false);
2414 last = name + strlen(name) - 1;
2415 if (strchr(name, '$')) {
2416 if (*last != '_')
2417 suffix = "$ft";
2418 else if (XBIT(119, 0x2000000) && strchr(sname, '_'))
2419 suffix = "$ft__";
2420 else
2421 suffix = "$ft_";
2422 name = sname;
2423 } else if (XBIT(119, 0x2000000) && strchr(sname, '_')) {
2424 suffix = *last == '_' ? "ft__" : "_ft__";
2425 } else {
2426 suffix = *last == '_' ? "ft_" : "_ft";
2427 }
2428 /* make sure it is not in ag table first */
2429 sprintf(ftname, "%s%s", name, suffix);
2430 gs = find_ag(ftname);
2431 if (!gs) {
2432 char typeName[20];
2433 sprintf(typeName, "[%d x i8*]", FINAL_TABLE_SZ);
2434 get_typedef_ag(ftname, typeName);
2435 gs = find_ag(ftname);
2436 AG_FINAL(gs) = 1;
2437 }
2438 }
2439 name = getsname(sptr);
2440
2441 /* Create a type name and struct for the type descriptor data type */
2442 sprintf(tdtname, "%%struct%s", name);
2443 level = count_parent_pointers(PARENTG(member), 0);
2444
2445 /* Array of pointers: the types this inherits/extends (parents) */
2446 if (level) {
2447 fprintf(ASMFIL, "%%struct%s$parents = type < { [%d x i8*] } >\n", name,
2448 level);
2449 fprintf(ASMFIL, "@%s$parents = global %%struct%s$parents < {\n", name,
2450 name);
2451 fprintf(ASMFIL, " [%d x i8*] [\n", level);
2452 write_parent_pointers(member, level);
2453 fprintf(ASMFIL, " ]\n");
2454 fprintf(ASMFIL, "} >, align 8\n");
2455 }
2456
2457 /* Create the type for the type descriptor (in ll) */
2458 size = level * sizeof(void *);
2459 size += (9 * 4) + (5 * sizeof(void *)) + sizeof(strlen(sname));
2460 fprintf(ASMFIL, "%s = type ", tdtname);
2461
2462 /* keep entry in ag table even though we print it here - just to keep
2463 * track */
2464 if (!find_ag(tdtname)) {
2465 int gs;
2466 DTYPE ttype;
2467 char *ptr;
2468 char typeName[100];
2469 LL_Type *llt;
2470
2471 sprintf(typeName, "[8 x i%d], i%d, [5 x i8*], [%d x i8]", subscript_size,
2472 integer_size, (int)strlen(sname));
2473
2474 ptr = tdtname + 1; /* move past first letter '%' */
2475 get_typedef_ag(ptr, typeName);
2476 ttype = mk_struct_for_llvm_init(name, 0);
2477 llt = make_lltype_from_dtype(ttype);
2478 gs = get_typedef_ag(ptr, NULL);
2479 set_ag_lltype(gs, llt);
2480 }
2481
2482 fprintf(ASMFIL, "< { [8 x i%d], [6 x i8*], [%d x i8] } >\n", subscript_size,
2483 strlen(sname));
2484
2485 /* Create the global instance of the type descriptor */
2486 fprintf(ASMFIL, "@%s = global %s < {\n", name, tdtname);
2487
2488 /* First array of values */
2489 fprintf(ASMFIL, " [8 x i%d] [", subscript_size);
2490 fprintf(ASMFIL, "i%d 43, ", subscript_size);
2491 fprintf(ASMFIL, "i%d %d, ", subscript_size, !UNLPOLYG(tag) ? 33 : 43);
2492 fprintf(ASMFIL, "i%d %d, ", subscript_size, level);
2493 fprintf(ASMFIL, "i%d %d, ", subscript_size, size_of(dtype));
2494 fprintf(ASMFIL, "i%d 0, i%d 0, i%d 0, i%d 0],\n", subscript_size,
2495 subscript_size, subscript_size, subscript_size);
2496
2497 /* Pointer array: symbol address and tables (vft, ft, layout) */
2498 fprintf(ASMFIL, " [6 x i8*] [\n");
2499 if (TYPDEF_INITG(tag) > NOSYM) {
2500 /* pointer to initialized prototype */
2501 const char *initname = getsname(TYPDEF_INITG(tag));
2502 fprintf(ASMFIL,
2503 " i8* bitcast(i8* getelementptr(i8, i8* "
2504 "bitcast(%%struct%s* @%s to i8*), i32 %ld) to i8*),\n",
2505 initname, initname, ADDRESSG(TYPDEF_INITG(tag)));
2506 } else {
2507 fprintf(ASMFIL, " i8* null,\n");
2508 }
2509
2510 fprintf(ASMFIL, " i8* bitcast(%s* @%s to i8*),\n", tdtname,
2511 getsname(sptr));
2512
2513 /* Pointer to vft */
2514 fprintf(ASMFIL, " ");
2515 put_ll_table_addr(sname, "$vft", false, vft,
2516 ll_feature_explicit_gep_load_type(&cpu_llvm_module->ir));
2517 fprintf(ASMFIL, ",\n");
2518
2519 /* Pointer to parent list */
2520 if (level > 0) {
2521 fprintf(ASMFIL,
2522 " i8* bitcast(i8* getelementptr(i8, i8* "
2523 "bitcast(%%struct%s$parents* @%s$parents to i8*), i32 0) to i8*)"
2524 ",\n", name, name);
2525 } else {
2526 fprintf(ASMFIL, " i8* null,\n"); /* 0 */
2527 }
2528
2529
2530 /* Pointer to finalizer table (always same size) */
2531 fprintf(ASMFIL, " ");
2532 if (ft)
2533 put_ll_table_addr(ftname, "", false, FINAL_TABLE_SZ,
2534 ll_feature_explicit_gep_load_type(&cpu_llvm_module->ir));
2535 else
2536 put_ll_table_addr(getsname(sptr), "ft_", false, 0,
2537 ll_feature_explicit_gep_load_type(&cpu_llvm_module->ir));
2538 fprintf(ASMFIL, ",\n");
2539
2540 /* Pointer to layout descriptor */
2541 fprintf(ASMFIL, " ");
2542 if (has_layout_desc)
2543 put_ll_table_addr(sname, "$ld", true, 0,
2544 ll_feature_explicit_gep_load_type(&cpu_llvm_module->ir));
2545 else
2546 fprintf(ASMFIL, "i8* null");
2547 fprintf(ASMFIL, "\n");
2548
2549 /* Third array (string symbol name) */
2550 fprintf(ASMFIL, " ],\n");
2551 fprintf(ASMFIL, " [%d x i8] c\"%s\"\n", (int)strlen(sname), sname);
2552 fprintf(ASMFIL, "} >");
2553 if (level)
2554 fprintf(ASMFIL, ", align 1");
2555 fprintf(ASMFIL, "\n");
2556
2557 /* Add name and its type (gname) to global symbol table */
2558 if (gblsym) {
2559 AG_DEFD(gblsym) = 1;
2560 AG_SIZE(gblsym) = size;
2561 AG_TYPEDESC(gblsym) = 1; /* This is a type descriptor */
2562 AG_DTYPESC(gblsym) = 0;
2563 }
2564 process_sptr(sptr);
2565 }
2566
2567 gbl.typedescs = NOSYM;
2568 }
2569
2570 /* TODO: get_ag will add sptr to the AG table. We have to do this or we will
2571 * get undefined references to externally defined type descriptors.
2572 */
2573 bool
is_typedesc_defd(SPTR sptr)2574 is_typedesc_defd(SPTR sptr)
2575 {
2576 SPTR gblsym;
2577
2578 if ((gblsym = get_ag(sptr))) /* Force add sptr to the ag table */
2579 return AG_DEFD(gblsym);
2580 return AG_DEFD(find_ag(getsname(sptr)));
2581 }
2582
2583 static void
write_externs(void)2584 write_externs(void)
2585 {
2586 SPTR sptr, gblsym;
2587 INT nmptr;
2588 char typeptr[10], *ifacenm;
2589 LL_Type *llt;
2590
2591 for (sptr = gbl.externs; sptr > NOSYM; sptr = SYMLKG(sptr)) {
2592 /* upper.c will place internal procedures on this list since
2593 * unifed.c needs to see the internal procedures on this
2594 * list.
2595 */
2596 if (SCG(sptr) != SC_STATIC)
2597 {
2598
2599 /* find an interface first */
2600 ifacenm = get_llvm_ifacenm(sptr);
2601 gblsym = find_ag(ifacenm);
2602
2603 if (!gblsym) {
2604 gblsym = find_ag(get_llvm_name(sptr));
2605 if (!gblsym && REFG(sptr))
2606 gblsym = get_ag(sptr);
2607 }
2608
2609 if (AG_TYPENMPTR(gblsym) == 0) {
2610 if (STYPEG(sptr) != ST_PROC) {
2611 llt = get_ftn_extern_lltype(sptr);
2612 nmptr = add_ag_name((char *)llt->str);
2613 AG_TYPENMPTR(gblsym) = nmptr;
2614 continue;
2615 }
2616 if (LLTYPE(sptr) && (LLTYPE(sptr)->data_type == LL_VOID)) {
2617 nmptr = add_ag_name(
2618 char_type(get_return_dtype(DT_NONE, NULL, 0), SPTR_NULL));
2619 AG_TYPENMPTR(gblsym) = nmptr;
2620 } else if (get_return_type(sptr) == 0) {
2621 nmptr = add_ag_name(
2622 char_type(get_return_dtype(DT_NONE, NULL, 0), SPTR_NULL));
2623 AG_TYPENMPTR(gblsym) = nmptr;
2624 } else if (CFUNCG(sptr) && LLTYPE(sptr) && STYPEG(sptr) == ST_PROC) {
2625 write_ftn_type(LLTYPE(sptr), typeptr, 0);
2626 nmptr = add_ag_name(typeptr);
2627 AG_TYPENMPTR(gblsym) = nmptr;
2628 /* Use the following else-if once we rely on better stb data for
2629 * CFUNC return values. This includes enabling GARGRET:
2630 *
2631 * else if (CFUNCG(sptr) && STYPEG(sptr) == ST_PROC) {
2632 * llt = make_lltype_from_dtype(DTYPEG(sptr));
2633 * assert(llt && llt->alt_type, "write_externs: Invalid LL_Type",
2634 * sptr, 4);
2635 * AG_TYPENMPTR(gblsym) = add_ag_name((char *)llt->alt_type->str);
2636 */
2637 } else {
2638 nmptr = add_ag_name((char *)char_type(
2639 get_return_dtype(DTYPEG(sptr), NULL, 0), SPTR_NULL));
2640 AG_TYPENMPTR(gblsym) = nmptr;
2641 }
2642 }
2643 }
2644 }
2645 for (sptr = gbl.basevars; sptr > NOSYM; sptr = SYMLKG(sptr))
2646 get_ag(sptr);
2647 }
2648
2649 /**
2650 \brief Read thru Data Initialization File and ...
2651 */
2652 static void
dinits(void)2653 dinits(void)
2654 {
2655 DREC *p;
2656 int tdtype;
2657 ISZ_T tconval;
2658 SPTR sptr;
2659 int sectionindex = DATA_SEC;
2660 DSRT *dsrtp;
2661 DSRT *item;
2662 DSRT *prev;
2663 int save_funccount = gbl.func_count;
2664
2665 lcl_inits = NULL;
2666 section_inits = NULL;
2667 extern_inits = NULL;
2668 #if DEBUG
2669 if (!CommonBlockInits)
2670 CommonBlockInits = hashset_alloc(hash_functions_direct);
2671 else
2672 hashset_clear(CommonBlockInits);
2673 #endif
2674
2675 for (p = dinit_read(); p; p = dinit_read()) {
2676 tdtype = p->dtype;
2677 tconval = p->conval;
2678 if (tdtype != DINIT_LOC && tdtype != DINIT_SLOC) {
2679 if (tdtype == DINIT_STRING) {
2680 /* skip over the string */
2681 dinit_fskip(tconval);
2682 } else if (tdtype == DINIT_SECT) {
2683 sectionindex = tconval;
2684 } else if (tdtype == DINIT_DATASECT) {
2685 sectionindex = DATA_SEC;
2686 #ifdef DINIT_FUNCCOUNT
2687 } else if (tdtype == DINIT_FUNCCOUNT) {
2688 gbl.func_count = tconval;
2689 #endif
2690 }
2691 continue;
2692 }
2693 sptr = (SPTR)tconval;
2694 #if DEBUG
2695 assert(sptr > 0, "dinits:bad sptr", sptr, ERR_Severe);
2696 #endif
2697 if (SCG(sptr) == SC_CMBLK) {
2698 int cmblk;
2699 #if DEBUG
2700 assert(DINITG(sptr), "assem.dinits cmblk DINIT flag 0", sptr, ERR_Severe);
2701 #endif
2702 item = GET_DSRT;
2703 item->sptr = sptr;
2704 item->offset = ADDRESSG(sptr);
2705 item->filepos = dinit_ftell();
2706 item->sectionindex = sectionindex;
2707 item->func_count = gbl.func_count;
2708 p = dinit_read();
2709 /*
2710 * if next dinit record is an offset, then the offset applies
2711 * to this symbol; update the the item's offset and file
2712 * position. NOTE that this does not interfere with the
2713 * remaining dinit_read since records are skipped until we
2714 * get to the next LOC (or eof).
2715 */
2716 if (p->dtype == DINIT_OFFSET) {
2717 item->offset += p->conval;
2718 item->filepos = dinit_ftell();
2719 }
2720 cmblk = MIDNUMG(sptr);
2721 #if DEBUG
2722 assert(STYPEG(cmblk) == ST_CMBLK, "assem.dinits NOT ST_CMBLK", sptr,
2723 ERR_Severe);
2724 #endif
2725 prev = NULL;
2726 dsrtp = DSRTG(cmblk);
2727 if (dsrtp && dsrtp->ladd->offset < item->offset) {
2728 dsrtp = dsrtp->ladd;
2729 }
2730 for (; dsrtp; dsrtp = dsrtp->next) {
2731 if (dsrtp->offset > item->offset)
2732 break;
2733 if (dsrtp->offset == item->offset) {
2734 /* check for zero-sized object */
2735 if (size_of(DTYPEG(sptr)) != 0 && size_of(DTYPEG(dsrtp->sptr)) != 0) {
2736 error(S_0164_Overlapping_data_initializations_of_OP1, ERR_Warning,
2737 0, SYMNAME(sptr), CNULL);
2738 goto Continue;
2739 }
2740 }
2741 prev = dsrtp;
2742 }
2743 if (prev == NULL) {
2744 item->next = DSRTG(cmblk);
2745 DSRTP(cmblk, item);
2746 #if DEBUG
2747 hashset_replace(CommonBlockInits, INT2HKEY(cmblk));
2748 #endif
2749 } else {
2750 item->next = prev->next;
2751 prev->next = item;
2752 }
2753 DSRTG(cmblk)->ladd = item;
2754 } else if (SECTG(sptr)) {
2755 /* initialized variable in a named section */
2756 item = GET_DSRT;
2757 item->sptr = sptr;
2758 item->offset = ADDRESSG(sptr);
2759 item->filepos = dinit_ftell();
2760 item->sectionindex = sectionindex;
2761 item->func_count = gbl.func_count;
2762 prev = NULL;
2763 for (dsrtp = section_inits; dsrtp; dsrtp = dsrtp->next)
2764 prev = dsrtp;
2765 if (prev == NULL) {
2766 item->next = section_inits;
2767 section_inits = item;
2768 } else {
2769 item->next = prev->next;
2770 prev->next = item;
2771 }
2772 } else if (REFG(sptr) && !CFUNCG(sptr)) {
2773 /* ref'd local var */
2774 item = GET_DSRT;
2775 item->sptr = sptr;
2776 item->offset = ADDRESSG(sptr);
2777 item->filepos = dinit_ftell();
2778 item->sectionindex = sectionindex;
2779 item->func_count = gbl.func_count;
2780 p = dinit_read();
2781
2782 /*
2783 * if next dinit record is an offset, then the offset applies
2784 * to this symbol; update the the item's offset and file
2785 * position. NOTE that this does not interfere with the
2786 * remaining dinit_read since records are skipped until we
2787 * get to the next LOC (or eof).
2788 */
2789 if (p->dtype == DINIT_OFFSET) {
2790 item->offset += p->conval;
2791 item->filepos = dinit_ftell();
2792 }
2793 prev = NULL;
2794 for (dsrtp = lcl_inits; dsrtp; dsrtp = dsrtp->next) {
2795 if (dsrtp->offset > item->offset)
2796 break;
2797 if (dsrtp->offset == item->offset) {
2798 int sptr = dsrtp->sptr;
2799 if (sptr && DTY(DTYPEG(sptr)) == TY_ARRAY && SCG(sptr) == SC_STATIC &&
2800 extent_of(DTYPEG(sptr)) == 0)
2801 goto Continue;
2802 error(S_0164_Overlapping_data_initializations_of_OP1, ERR_Warning, 0,
2803 SYMNAME(sptr), CNULL);
2804 goto Continue;
2805 }
2806 prev = dsrtp;
2807 }
2808 if (prev == NULL) {
2809 item->next = lcl_inits;
2810 lcl_inits = item;
2811 } else {
2812 item->next = prev->next;
2813 prev->next = item;
2814 }
2815 } else if (CFUNCG(sptr)) {
2816 /* inited BIND(C) module variable */
2817 item = GET_DSRT;
2818 item->sptr = sptr;
2819 item->offset = ADDRESSG(sptr);
2820 item->sectionindex = sectionindex;
2821 item->filepos = dinit_ftell();
2822 item->func_count = gbl.func_count;
2823
2824 p = dinit_read();
2825 /*
2826 * if next dinit record is an offset, then the offset applies
2827 * to this symbol; update the the item's offset and file
2828 * position. NOTE that this does not interfere with the
2829 * remaining dinit_read since records are skipped until we
2830 * get to the next LOC (or eof).
2831 */
2832 if (p->dtype == DINIT_OFFSET) {
2833 item->offset += p->conval;
2834 item->filepos = dinit_ftell();
2835 }
2836
2837 prev = NULL;
2838 for (dsrtp = extern_inits; dsrtp; dsrtp = dsrtp->next) {
2839 if (sptr != dsrtp->sptr)
2840 break;
2841 if (dsrtp->offset > item->offset)
2842 break;
2843 prev = dsrtp;
2844 }
2845 if (prev == NULL) {
2846 item->next = extern_inits;
2847 extern_inits = item;
2848 } else {
2849 item->next = prev->next;
2850 prev->next = item;
2851 }
2852 }
2853 Continue:;
2854 /* we may have read ahead to another dinit record, check if it's a STRING */
2855 if (p->dtype == DINIT_STRING) {
2856 /* skip over the string */
2857 dinit_fskip(p->conval);
2858 }
2859 }
2860
2861 gbl.func_count = save_funccount;
2862 } /* endroutine dinits */
2863
2864 #if DEBUG
2865 static void
dump_dinit_structure(DSRT * p)2866 dump_dinit_structure(DSRT *p)
2867 {
2868 fprintf(gbl.dbgfil,
2869 "dsrt[%p]: {sptr = %d, offset = %d, section = %d, "
2870 "filepos = %d, func_count = %d, dtype = %d, len =%d, conval = %d, "
2871 "next = %p, ladd = %p}\n",
2872 p, p->sptr, p->offset, p->sectionindex, p->filepos, p->func_count,
2873 p->dtype, p->len, p->conval, p->next, p->ladd);
2874 }
2875
2876 static void
dump_dinit_chain(const char * name,DSRT * p)2877 dump_dinit_chain(const char *name, DSRT *p)
2878 {
2879 if (p) {
2880 fprintf(gbl.dbgfil, "%s: {\n", name);
2881 for (; p; p = p->next)
2882 dump_dinit_structure(p);
2883 fputs("}\n", gbl.dbgfil);
2884 }
2885 }
2886
2887 static void
dump_common_chain(hash_key_t key,void * _)2888 dump_common_chain(hash_key_t key, void *_)
2889 {
2890 SPTR sptr = (SPTR)HKEY2INT(key);
2891 char buffer[32];
2892
2893 snprintf(buffer, 32, "common-%d", sptr);
2894 dump_dinit_chain(buffer, DSRTG(sptr));
2895 }
2896
2897 static void
dump_all_dinits(void)2898 dump_all_dinits(void)
2899 {
2900 if (!gbl.dbgfil)
2901 gbl.dbgfil = stderr;
2902 dump_dinit_chain("local inits", lcl_inits);
2903 dump_dinit_chain("section inits", section_inits);
2904 dump_dinit_chain("extern inits", extern_inits);
2905 hashset_iterate(CommonBlockInits, dump_common_chain, NULL);
2906 }
2907 #endif
2908
2909 /* 'b'-byte boundary */
2910 static int
align_dir_value(int b)2911 align_dir_value(int b)
2912 {
2913 int j, i;
2914 if (XBIT(119, 0x10)) { /* linux */
2915 for (j = 1, i = 0; j < b; j *= 2, ++i)
2916 ;
2917 return i;
2918 }
2919 return b;
2920 }
2921
2922 /* 'n'-byte alignment */
2923 void
assem_emit_align(int n)2924 assem_emit_align(int n)
2925 {
2926 int i = align_dir_value(n);
2927 if (i)
2928 fprintf(ASMFIL, "\t.align\t%d\n", i);
2929 }
2930
2931 void
put_section(int sect)2932 put_section(int sect)
2933 {
2934 }
2935
2936 int
get_hollerith_size(int sptr)2937 get_hollerith_size(int sptr)
2938 {
2939 int add_null = 0;
2940 if (HOLLG(sptr)) {
2941 int len = DTyCharLength(DTYPEG(sptr));
2942 if (flg.quad && len >= MIN_ALIGN_SIZE) {
2943 add_null = ALIGN(len, DATA_ALIGN) - len;
2944 } else {
2945 add_null = ALIGN(len, alignment(DT_INT)) - len;
2946 }
2947 return add_null;
2948 }
2949 return DTyCharLength(DTYPEG(sptr));
2950 }
2951
2952 /**
2953 \param sptr is a Fortran character constant or Hollerith constant.
2954 \param add_null is 1 if null character is added, otherwise 0.
2955 */
2956 void
put_fstr(SPTR sptr,int add_null)2957 put_fstr(SPTR sptr, int add_null)
2958 {
2959 const char *retc = char_type(DTYPEG(sptr), sptr);
2960 int len = 0;
2961
2962 #ifdef HOLLG
2963 if (HOLLG(sptr)) {
2964 len = get_hollerith_size(sptr);
2965 }
2966 #endif
2967 fprintf(ASMFIL, "@%s = internal constant %s [", get_llvm_name(sptr), retc);
2968 put_string_n(stb.n_base + CONVAL1G(sptr),
2969 DTyCharLength(DTYPEG(sptr)) + add_null, 0);
2970 #ifdef HOLLG
2971 if (HOLLG(sptr)) {
2972 while (len) {
2973 fputc(',', ASMFIL);
2974 put_string_n(" ", 1, 0);
2975 --len;
2976 }
2977 }
2978 #endif
2979 fputc(']', ASMFIL);
2980 }
2981
2982 static void
put_kstr(SPTR sptr,int add_null)2983 put_kstr(SPTR sptr, int add_null)
2984 /* put out data initializations for kanji string (2 bytes/char) */
2985 {
2986 unsigned char *p;
2987 const char *retc;
2988 int len;
2989 int bytes;
2990
2991 retc = char_type(DTYPEG(sptr), sptr);
2992 fprintf(ASMFIL, "@%s = internal constant %s [", get_llvm_name(sptr), retc);
2993
2994 sptr = SymConval1(sptr);
2995 assert(STYPEG(sptr) == ST_CONST && DTY(DTYPEG(sptr)) == TY_CHAR,
2996 "assem/put_kstr(): bad sptr", sptr, ERR_Severe);
2997
2998 len = DTyCharLength(DTYPEG(sptr));
2999 p = (unsigned char *)stb.n_base + CONVAL1G(sptr);
3000 while (len > 0) {
3001 int val = kanji_char(p, len, &bytes);
3002
3003 p += bytes;
3004 len -= bytes;
3005
3006 fprintf(ASMFIL, "i16 %d", val);
3007 if (len)
3008 fprintf(ASMFIL, ",");
3009 }
3010 fputc(']', ASMFIL);
3011 }
3012
3013 /* from scc assem.c : */
3014
3015 /*
3016 * return the maximum alignment suitable for the symbol
3017 * with respect to its size.
3018 *
3019 */
3020 static int
max_align(SPTR sptr)3021 max_align(SPTR sptr)
3022 {
3023 DTYPE dtype;
3024 ISZ_T sz;
3025 int align;
3026
3027 dtype = DTYPEG(sptr);
3028 sz = size_of_sym(sptr);
3029 if (!PDALN_IS_DEFAULT(sptr)) {
3030 align = (1 << PDALNG(sptr)) - 1;
3031 } else if (sz > max_cm_align) {
3032 align = max_cm_align;
3033 } else if (sz >= MIN_ALIGN_SIZE) {
3034 align = DATA_ALIGN;
3035 } else {
3036 align = align_unconstrained(dtype);
3037 }
3038 return align;
3039 }
3040
3041 #if DEBUG
3042 /* Dump an entry in the AG table */
3043 static void
dump_gblsym(int gblsym)3044 dump_gblsym(int gblsym)
3045 {
3046 printf("gblsym:%d, %s, %s, typedesc:%d\n", gblsym, AG_NAME(gblsym),
3047 AG_TYPENMPTR(gblsym) ? AG_TYPENAME(gblsym) : "N/A",
3048 AG_TYPEDESC(gblsym));
3049 }
3050
3051 /* Dump the AG table, TODO: Add to coding.n for DBGBIT and gbl.dbgfil */
3052 static void
dump_ag(void)3053 dump_ag(void)
3054 {
3055 int i;
3056 for (i = 0; i < agb.s_avl; ++i)
3057 if (AG_HASHLK(i))
3058 dump_gblsym(i);
3059 }
3060
3061 static void
dump_allag(void)3062 dump_allag(void)
3063 {
3064 int i;
3065 for (i = 0; i < agb.s_avl; ++i)
3066 dump_gblsym(i);
3067 }
3068 #endif /* Debug */
3069
3070 /*
3071 * return ptr to assem's global symtab.
3072 */
3073
3074 SPTR
get_ag(SPTR sptr)3075 get_ag(SPTR sptr)
3076 {
3077 SPTR gblsym;
3078 int stype;
3079 char *ag_name;
3080 ISZ_T size;
3081
3082 stype = STYPEG(sptr);
3083 if (gbl.internal == 1 && gbl.rutype == RU_PROG && sptr == gbl.currsub)
3084 ag_name = get_main_progname();
3085 else
3086 ag_name = get_llvm_name(sptr);
3087 gblsym = find_ag(ag_name);
3088
3089 if (gblsym)
3090 goto Found;
3091
3092 /* Enter new symbol into the global symbol table */
3093 gblsym = make_gblsym(sptr, ag_name);
3094 if (CLASSG(sptr) && DESCARRAYG(sptr)) {
3095 /* add type descriptor to global list */
3096 char tdtname[MXIDLN];
3097 AG_SYMLK(gblsym) = ag_global;
3098 ag_global = gblsym;
3099 AG_SIZE(gblsym) = 0;
3100 AG_TYPEDESC(gblsym) = 1; /* This is a type descriptor */
3101 AG_DEFD(gblsym) = 0;
3102
3103 /* Default value used for when we have an external reference to
3104 * a type descriptor in assemble_end().
3105 */
3106 sprintf(tdtname, "struct%s", ag_name);
3107 add_ag_typename(gblsym, tdtname);
3108 } else
3109 if (stype == ST_CMBLK) {
3110 AG_SYMLK(gblsym) = ag_cmblks;
3111 ag_cmblks = gblsym;
3112 AG_SIZE(gblsym) = SIZEG(sptr);
3113 AG_ALLOC(gblsym) = ALLOCG(sptr);
3114 #if defined(TARGET_WIN)
3115 AG_DLL(gblsym) = DLLG(sptr);
3116 #endif
3117 if (!MODCMNG(sptr) || DEFDG(sptr))
3118 AG_DEFD(gblsym) = 1;
3119 if (FROMMODG(sptr) && MODCMNG(sptr)) {
3120 /* set flag to emit an external reference */
3121 AG_ISMOD(gblsym) = 1;
3122 }
3123 #if defined(TARGET_WIN)
3124 /* windows hack (see f19172) - for now, mark all module commmons as
3125 * defined; need to solve having non-dll/dll versions of a .mod file.
3126 */
3127 AG_DEFD(gblsym) = 1;
3128 #endif
3129 if (!XBIT(57, 0x10000000) && CCSYMG(sptr) && PDALNG(sptr) == 4) {
3130 AG_ALIGN(gblsym) = max_cm_align + 1;
3131 }
3132 } else if ((stype == ST_ARRAY) & !CFUNCG(sptr)) {
3133 AG_SYMLK(gblsym) = ag_other;
3134 ag_other = gblsym;
3135 AG_SIZE(gblsym) = size_of(DTYPEG(sptr));
3136 }
3137 else if (stype == ST_BASE) {
3138 /* base address symbol */
3139 AG_SYMLK(gblsym) = ag_global;
3140 ag_global = gblsym;
3141 AG_SIZE(gblsym) = 0;
3142 }
3143 else if ((stype == ST_VAR) || (stype == ST_STRUCT) || (stype == ST_ARRAY)) {
3144 /* CFUNCG() : BIND(C) module variables visible
3145 externally
3146 */
3147
3148 if (!CFUNCG(sptr))
3149 return SPTR_NULL;
3150
3151 AG_SYMLK(gblsym) = ag_cmblks;
3152 ag_cmblks = gblsym;
3153 AG_SIZE(gblsym) = size_of_sym(sptr);
3154 AG_ALIGN(gblsym) = max_align(sptr) + 1;
3155
3156 if (DINITG(sptr))
3157 AG_DSIZE(gblsym) = size_of_sym(sptr);
3158
3159 AG_ALLOC(gblsym) = 0;
3160 AG_DEFD(gblsym) = 1;
3161 }
3162
3163 else
3164 #ifdef CUDAG
3165 if (!(CUDAG(sptr) & CUDA_BUILTIN))
3166 #endif
3167 {
3168 /* NOTE: ST_ENTRY and ST_PROC added to the same list */
3169 AG_SYMLK(gblsym) = ag_procs;
3170 ag_procs = gblsym;
3171
3172 if (stype == ST_PROC) {
3173 /* check for iface */
3174 DTYPE dtype = DTYPEG(sptr);
3175 if ((DTY(dtype) == TY_PROC) && (DTyInterface(dtype) == sptr)) {
3176 AG_ISIFACE(gblsym) = 1; /* check this when datatype is processed. */
3177 AG_SIZE(gblsym) = 0;
3178 AG_DEVICE(gblsym) = 0;
3179 #if defined(TARGET_WIN)
3180 AG_DLL(gblsym) = DLLG(sptr);
3181 #endif
3182 return gblsym;
3183 }
3184 }
3185 if (stype == ST_ENTRY) {
3186 AG_SIZE(gblsym) = 1; /* subprogram defined in file */
3187 if (SCG(sptr) != SC_STATIC) {
3188 global_sptr = gblsym;
3189 llvm_set_unique_sym(gblsym);
3190 }
3191 } else {
3192 AG_SIZE(gblsym) = 0;
3193 AG_DEVICE(gblsym) = 0;
3194 #ifdef CUDAG
3195 if (CUDAG(sptr) & (CUDA_DEVICE | CUDA_GLOBAL))
3196 AG_DEVICE(gblsym) = 1;
3197 if (CUDAG(gbl.currsub) & (CUDA_DEVICE | CUDA_GLOBAL))
3198 AG_DEVICE(gblsym) = 1;
3199 #endif
3200 if (NEEDMODG(sptr)) {
3201 AG_ISMOD(gblsym) = 1;
3202 #if defined(TARGET_WIN)
3203 if (TYPDG(sptr)) {
3204 AG_REF(gblsym) = 1;
3205 AG_NEEDMOD(gblsym) = 1;
3206 }
3207 #else
3208 AG_REF(gblsym) = 1;
3209 if (TYPDG(sptr))
3210 AG_NEEDMOD(gblsym) = 1;
3211 #endif
3212 } else if (REFG(sptr))
3213 AG_REF(gblsym) = SCG(sptr) != SC_NONE;
3214 }
3215 #if defined(TARGET_WIN)
3216 AG_DLL(gblsym) = DLLG(sptr);
3217 #endif
3218 }
3219 return gblsym;
3220
3221 Found:
3222 if (CLASSG(sptr) && DESCARRAYG(sptr)) {
3223 return SPTR_NULL;
3224 }
3225 switch (stype) {
3226 case ST_PROC:
3227 case ST_ENTRY:
3228 if (AG_STYPE(gblsym) == ST_CMBLK) {
3229 error(S_0166_OP1_cannot_be_a_common_block_and_a_subprogram, ERR_Severe, 0,
3230 SYMNAME(sptr), CNULL);
3231 return SPTR_NULL;
3232 }
3233 /* if a ST_PROC and ST_ENTRY occur in the same file, make sure
3234 * that the symbol is recorded as ST_ENTRY.
3235 */
3236 if (stype == ST_ENTRY) {
3237 AG_STYPE(gblsym) = ST_ENTRY;
3238 if (SCG(sptr) != SC_STATIC) {
3239 global_sptr = gblsym;
3240 llvm_set_unique_sym(gblsym);
3241 }
3242 AG_SIZE(gblsym) = 1;
3243 } else if (REFG(sptr))
3244 AG_REF(gblsym) |= SCG(sptr) != SC_NONE;
3245 break;
3246 case ST_ARRAY:
3247 /*
3248 * an array declared in a module declared as visable to c
3249 * with BIND(C) : marked CFUNCG()
3250 */
3251 if (!CFUNCG(sptr))
3252 break;
3253 /* else fall through */
3254 case ST_VAR:
3255 case ST_STRUCT:
3256 if (!CFUNCG(sptr))
3257 return SPTR_NULL;
3258 /* fall through */
3259 case ST_CMBLK:
3260 if (AG_STYPE(gblsym) != stype) {
3261 error(S_0166_OP1_cannot_be_a_common_block_and_a_subprogram, ERR_Severe, 0,
3262 SYMNAME(sptr), CNULL);
3263 return SPTR_NULL;
3264 }
3265 size = SIZEG(sptr);
3266 if (DINITG(sptr)) {
3267 /* common block is init'd in subprogram */
3268 if (AG_DSIZE(gblsym))
3269 ; /* already dinit'd */
3270 else {
3271 if (size < AG_SIZE(gblsym))
3272 /* dinit size < previous size */
3273 error(S_0168_Incompatible_size_of_common_block_OP1, ERR_Severe, 0,
3274 SYMNAME(sptr), CNULL);
3275 AG_SIZE(gblsym) = size;
3276 }
3277 AG_DEFD(gblsym) = 1;
3278 } else if (AG_DSIZE(gblsym) && AG_DSIZE(gblsym) < size)
3279 /* prev dinit size < size */
3280 error(S_0155_OP1_OP2, ERR_Severe, 0,
3281 "Same name common blocks with different sizes in same file not "
3282 "supported",
3283 "");
3284 else if (AG_SIZE(gblsym) < size) {
3285 AG_SIZE(gblsym) = size;
3286 }
3287 if (!MODCMNG(sptr) || DEFDG(sptr))
3288 AG_DEFD(gblsym) = 1;
3289 #if defined(TARGET_WIN)
3290 AG_DEFD(gblsym) = 1;
3291 /* windows hack (see f19172) - for now, mark all module commmons as
3292 * defined; need to solve having non-dll/dll versions of a .mod file.
3293 */
3294 #endif
3295 /* Add processing COMMON variables which have different names in different
3296 * context. */
3297 if (flg.debug)
3298 lldbg_create_cmblk_mem_mdnode_list(sptr, gblsym);
3299 break;
3300 case ST_BASE:
3301 break;
3302 default:
3303 interr("assem get_ag, bad stype of ", sptr, ERR_Severe);
3304 }
3305
3306 return gblsym;
3307 }
3308
3309 bool
has_typedef_ag(int gblsym)3310 has_typedef_ag(int gblsym)
3311 {
3312 return AG_TYPENMPTR(gblsym) > 0;
3313 }
3314
3315 void
set_ag_lltype(int gblsym,LL_Type * llt)3316 set_ag_lltype(int gblsym, LL_Type *llt)
3317 {
3318 assert(gblsym, "set_ag_lltype: Invalid gblsym", gblsym, ERR_Fatal);
3319 AG_LLTYPE(gblsym) = llt;
3320 }
3321
3322 LL_Type *
get_ag_lltype(int gblsym)3323 get_ag_lltype(int gblsym)
3324 {
3325 #if DEBUG
3326 if (!AG_LLTYPE(gblsym)) {
3327 char bf[100];
3328 sprintf(bf, "get_ag_lltype: No LLTYPE set for gblsym %s", AG_NAME(gblsym));
3329 interr(bf, gblsym, ERR_Fatal);
3330 }
3331 #endif
3332 return AG_LLTYPE(gblsym);
3333 }
3334
3335 void
set_ag_return_lltype(int gblsym,LL_Type * llt)3336 set_ag_return_lltype(int gblsym, LL_Type *llt)
3337 {
3338 assert(gblsym, "set_ag_return_lltype: Invalid gblsym", gblsym, ERR_Fatal);
3339 AG_RET_LLTYPE(gblsym) = llt;
3340 }
3341
3342 LL_Type *
get_ag_return_lltype(int gblsym)3343 get_ag_return_lltype(int gblsym)
3344 {
3345 assert(gblsym, "get_ag_return_lltype: Invalid gblsym", gblsym, ERR_Fatal);
3346 return AG_RET_LLTYPE(gblsym);
3347 }
3348
3349 static SPTR
find_local_ag(char * ag_name)3350 find_local_ag(char *ag_name)
3351 {
3352 SPTR gsym;
3353 int hashval = name_to_hash(ag_name, strlen(ag_name));
3354
3355 for (gsym = agb_local.hashtb[hashval]; gsym; gsym = AGL_HASHLK(gsym))
3356 if (!strcmp(ag_name, AGL_NAME(gsym)))
3357 return gsym;
3358 return SPTR_NULL;
3359 }
3360
3361 static int
add_ag_fptr_name(char * ag_name)3362 add_ag_fptr_name(char *ag_name)
3363 {
3364 int i, nptr, len, needed;
3365 char *np;
3366
3367 len = strlen(ag_name);
3368 nptr = fptr_local.n_avl;
3369 fptr_local.n_avl += (len + 1);
3370
3371 if ((len + 1) >= (32 * 16))
3372 needed = len + 1;
3373 else
3374 needed = 32 * 16;
3375
3376 NEED(fptr_local.n_avl + 1, fptr_local.n_base, char, fptr_local.n_size,
3377 fptr_local.n_size + needed);
3378 np = fptr_local.n_base + nptr;
3379 for (i = 0; i < len; i++)
3380 *np++ = *ag_name++;
3381 *np = '\0';
3382
3383 return nptr;
3384 }
3385
3386 #if defined(TARGET_WIN)
3387 void
dllexport_mod(int modu)3388 dllexport_mod(int modu)
3389 {
3390 int gg;
3391 gg = get_ag(modu);
3392 if (gg && AG_STYPE(gg) != ST_ENTRY) {
3393 AG_STYPE(gg) = ST_ENTRY;
3394 AG_DLL(gg) = DLL_EXPORT;
3395 }
3396 }
3397 #endif
3398
3399 // TODO: this ought to check for buffer overrun
3400 char *
getextfuncname(SPTR sptr)3401 getextfuncname(SPTR sptr)
3402 {
3403 static char name[MXIDLN]; /* 1 for null, 3 for extra '_' , */
3404 char *p, *q, ch;
3405 bool has_underscore = false;
3406 int stype, m;
3407 stype = STYPEG(sptr);
3408 if (ALTNAMEG(sptr)) {
3409 return get_altname(sptr);
3410 }
3411 if (gbl.internal && CONTAINEDG(sptr)) {
3412 p = name;
3413 m = INMODULEG(gbl.outersub);
3414 if (m) {
3415 q = SYMNAME(m);
3416 while ((ch = *q++)) {
3417 if (ch == '$')
3418 *p++ = flg.dollar;
3419 else
3420 *p++ = ch;
3421 }
3422 *p++ = '_';
3423 }
3424 q = SYMNAME(gbl.outersub);
3425 while ((ch = *q++)) {
3426 if (ch == '$')
3427 *p++ = flg.dollar;
3428 else
3429 *p++ = ch;
3430 }
3431 *p++ = '_';
3432 q = SYMNAME(sptr);
3433 while ((ch = *q++)) {
3434 if (ch == '$')
3435 *p++ = flg.dollar;
3436 else
3437 *p++ = ch;
3438 }
3439 *p = '\0';
3440 return name;
3441 }
3442 if (XBIT(119, 0x1000)) { /* add leading underscore */
3443 name[0] = '_';
3444 p = name + 1;
3445 } else
3446 p = name;
3447 m = INMODULEG(sptr);
3448 if (m) {
3449 q = SYMNAME(m);
3450 while ((ch = *q++)) {
3451 if (ch == '$')
3452 *p++ = flg.dollar;
3453 else
3454 *p++ = ch;
3455 }
3456 *p++ = '_';
3457 }
3458 if (stype != ST_ENTRY || gbl.rutype != RU_PROG) {
3459 q = SYMNAME(sptr);
3460 } else {
3461 #if defined(TARGET_WIN)
3462 /* we have a mix of undecorated and decorated names on win32 */
3463 strcpy(name, "_MAIN_");
3464 return name;
3465 #else
3466 q = "MAIN";
3467 #endif
3468 }
3469 while ((ch = *q++)) {
3470 if (ch == '$')
3471 *p++ = flg.dollar;
3472 else
3473 *p++ = ch;
3474 if (ch == '_')
3475 has_underscore = true;
3476 }
3477 /*
3478 * append underscore to name??? -
3479 * - always for entry,
3480 * - procedure if not compiler-created and not a "C" external..
3481 * - modified by -x 119 0x0100000 or -x 119 0x02000000
3482 */
3483 if (stype != ST_PROC || (!CCSYMG(sptr) && !CFUNCG(sptr))) {
3484 /* functions marked as !DEC$ ATTRIBUTES C get no underbar */
3485 if (!XBIT(119, 0x01000000) && !CFUNCG(sptr) && !CREFG(sptr)) {
3486 *p++ = '_';
3487 if (XBIT(119, 0x2000000) && has_underscore && !LIBSYMG(sptr))
3488 *p++ = '_';
3489 }
3490 }
3491 *p = '\0';
3492 return name;
3493 } /* getextfuncname */
3494
3495 static char *
getfuncname(SPTR sptr)3496 getfuncname(SPTR sptr)
3497 {
3498 if (!sptr)
3499 return "xxxxxx";
3500 if (gbl.outlined || ISTASKDUPG(GBL_CURRFUNC))
3501 return SYMNAME(sptr);
3502 return getextfuncname(sptr);
3503 }
3504
3505 /*
3506 * return ptr to symbol name, suitable for assembly code listing. For
3507 * strings and constants, a name must be created:
3508 *
3509 * BIG FAT WARNING: This routine formats the name into a static buffer
3510 * whose address is returned. Don't capture this result and reuse
3511 * the string in any context where getsname() might be called again,
3512 * because the buffer will be overwritten with a new name!
3513 */
3514 char *
getsname(SPTR sptr)3515 getsname(SPTR sptr)
3516 {
3517 static char name[MXIDLN]; /* 1 for null, 3 for extra '_' ,
3518 * 4 for @### with mscall
3519 */
3520 char *p, *q, ch;
3521 bool has_underscore = false;
3522 int stype, m;
3523 char *prepend = "\0";
3524
3525 switch (stype = STYPEG(sptr)) {
3526 case ST_LABEL:
3527 sprintf(name, "%sB%d_%d", ULABPFX, gbl.func_count, sptr);
3528 break;
3529 case ST_CONST:
3530 case ST_PARAM:
3531 sprintf(name, ".C%d_%s", sptr, getfuncname(gbl.currsub));
3532 break;
3533 case ST_BASE:
3534 return SYMNAME(sptr);
3535 case ST_VAR:
3536 case ST_ARRAY:
3537 case ST_STRUCT:
3538 case ST_UNION:
3539 case ST_PLIST:
3540 switch (SCG(sptr)) {
3541 case SC_EXTERN:
3542 if (ALTNAMEG(sptr) && CFUNCG(sptr))
3543 return get_altname(sptr);
3544 goto xlate_name;
3545 case SC_CMBLK:
3546 if (ALTNAMEG(sptr)) {
3547 return get_altname(sptr);
3548 }
3549 /* modification needed on this name ? */
3550 if (CFUNCG(sptr))
3551 return SYMNAME(sptr);
3552 return getsname(MIDNUMG(sptr));
3553 case SC_STATIC:
3554 if (CLASSG(sptr) && DESCARRAYG(sptr))
3555 goto xlate_name;
3556 #ifdef BASEADDRG
3557 if (BASEADDRG(sptr)) {
3558 return SYMNAME(BASESYMG(sptr));
3559 }
3560 #endif
3561 if (ALTNAMEG(sptr))
3562 return get_altname(sptr);
3563 if (UPLEVELG(sptr) || (gbl.outlined && gbl.internal <= 1)) {
3564 if (DINITG(sptr)) {
3565 if (ENCLFUNCG(sptr) && ENCLFUNCG(sptr) == gbl.currsub)
3566 return static_name;
3567 return outer_static_name;
3568 }
3569 return outer_bss_name;
3570 }
3571 if (SECTG(sptr)) {
3572 #ifdef CUDAG
3573 if (gbl.currsub && (CUDAG(gbl.currsub) & CUDA_CONSTRUCTOR)) {
3574 if (global_sptr) { /* prepend a module or routine name defined in this
3575 file */
3576 prepend = AG_NAME(global_sptr);
3577 }
3578 }
3579 #endif
3580 sprintf(name, ".SECTION%d_%d_%s", gbl.func_count, sptr, prepend);
3581 return name;
3582 }
3583 if (ALTNAMEG(sptr)) {
3584 return get_altname(sptr);
3585 }
3586 if (DINITG(sptr)) {
3587 if (static_name_global == 1) {
3588 /* zero sized array reference, use BSS instead of STATICS */
3589 if ((DTY(DTYPEG(sptr)) == TY_ARRAY) && SCG(sptr) == SC_STATIC &&
3590 extent_of(DTYPEG(sptr)) == 0) {
3591 bss_name_global = 2;
3592 SYMLKP(bss_base, gbl.basevars);
3593 gbl.basevars = bss_base;
3594 ADDRESSP(sptr, gbl.bss_addr);
3595 if (gbl.bss_addr == 0)
3596 gbl.bss_addr = 4;
3597 } else {
3598 static_name_global = 2;
3599 SYMLKP(static_base, gbl.basevars);
3600 gbl.basevars = static_base;
3601 }
3602 }
3603 /* zero sized array reference, use BSS instead of STATICS */
3604 if ((DTY(DTYPEG(sptr)) == TY_ARRAY) && SCG(sptr) == SC_STATIC &&
3605 extent_of(DTYPEG(sptr)) == 0) {
3606
3607 ADDRESSP(sptr, gbl.bss_addr);
3608 if (gbl.bss_addr == 0)
3609 gbl.bss_addr = 4;
3610 return bss_name;
3611 }
3612 if (gbl.outlined)
3613 return outer_static_name;
3614 return static_name;
3615 }
3616 if (bss_name_global == 1) {
3617 /* make sure the bss_name gets output */
3618 bss_name_global = 2;
3619 SYMLKP(bss_base, gbl.basevars);
3620 gbl.basevars = bss_base;
3621 }
3622 return bss_name;
3623 case SC_PRIVATE:
3624 sprintf(name, "%s_%d", SYMNAME(sptr), sptr);
3625 return name;
3626 default:
3627 sprintf(name, ".V%d_%d", gbl.func_count, sptr);
3628 }
3629 break;
3630 case ST_CMBLK:
3631 #if defined(TARGET_OSX)
3632 if (FROMMODG(sptr)) { /* common block is from a module */
3633 int md;
3634 md = SCOPEG(sptr);
3635 if (md && NEEDMODG(md)) {
3636 /* module is use-associated */
3637 TYPDP(md, 1);
3638 }
3639 }
3640 #endif
3641 if (ALTNAMEG(sptr))
3642 return get_altname(sptr);
3643 if
3644 CFUNCG(sptr)
3645 {
3646 /* common block C name compatibility : no underscore */
3647 return SYMNAME(sptr);
3648 }
3649
3650 xlate_name:
3651 if (XBIT(119, 0x1000)) { /* add leading underscore */
3652 name[0] = '_';
3653 p = name + 1;
3654 } else
3655 p = name;
3656 q = SYMNAME(sptr);
3657 while ((ch = *q++)) {
3658 if (ch == '$')
3659 *p++ = flg.dollar;
3660 else
3661 *p++ = ch;
3662 if (ch == '_')
3663 has_underscore = true;
3664 }
3665 /*
3666 * append underscore to name??? -
3667 * - always for common block (note - common block may have CCSYM set),
3668 * - not compiler-created external variable,
3669 * - modified by -x 119 0x0100000 or -x 119 0x02000000
3670 */
3671 #ifdef OMP_OFFLOAD_LLVM
3672 if (!OMPACCRTG(sptr))
3673 #endif
3674 if ((STYPEG(sptr) == ST_CMBLK || !CCSYMG(sptr)) && !CFUNCG(sptr)) {
3675 if (!XBIT(119, 0x01000000)) {
3676 *p++ = '_';
3677 if (XBIT(119, 0x2000000) && has_underscore &&
3678 !CCSYMG(sptr) && !LIBSYMG(sptr))
3679 *p++ = '_';
3680 }
3681 }
3682 *p = '\0';
3683 #if defined(TARGET_WIN)
3684 if (!XBIT(121, 0x200000) && STYPEG(sptr) == ST_CMBLK && !CCSYMG(sptr) &&
3685 XBIT(119, 0x01000000))
3686 upcase_name(name);
3687 #endif
3688 break;
3689 case ST_ENTRY:
3690 case ST_PROC:
3691 if (ALTNAMEG(sptr)) {
3692 return get_altname(sptr);
3693 }
3694 if ((flg.smp || XBIT(34, 0x200)) && OUTLINEDG(sptr)) {
3695 sprintf(name, "%s", SYMNAME(sptr));
3696 p = name;
3697 }
3698 else if (gbl.internal && CONTAINEDG(sptr)) {
3699 p = name;
3700 if (gbl.outersub) {
3701 m = INMODULEG(gbl.outersub);
3702 if (m) {
3703 q = SYMNAME(m);
3704 while ((ch = *q++)) {
3705 if (ch == '$')
3706 *p++ = flg.dollar;
3707 else
3708 *p++ = ch;
3709 }
3710 *p++ = '_';
3711 }
3712 q = SYMNAME(gbl.outersub);
3713 while ((ch = *q++)) {
3714 if (ch == '$')
3715 *p++ = flg.dollar;
3716 else
3717 *p++ = ch;
3718 }
3719 *p++ = '_';
3720 }
3721 q = SYMNAME(sptr);
3722 while ((ch = *q++)) {
3723 if (ch == '$')
3724 *p++ = flg.dollar;
3725 else
3726 *p++ = ch;
3727 }
3728 *p = '\0';
3729 return name;
3730 }
3731 if (XBIT(119, 0x1000)) { /* add leading underscore */
3732 name[0] = '_';
3733 p = name + 1;
3734 } else
3735 p = name;
3736 m = INMODULEG(sptr);
3737 if (m) {
3738 q = SYMNAME(m);
3739 while ((ch = *q++)) {
3740 if (ch == '$')
3741 *p++ = flg.dollar;
3742 else
3743 *p++ = ch;
3744 }
3745 *p++ = '_';
3746 }
3747 if (stype != ST_ENTRY || gbl.rutype != RU_PROG) {
3748 q = SYMNAME(sptr);
3749 } else if ((flg.smp || XBIT(34, 0x200)) && OUTLINEDG(sptr)) {
3750 q = SYMNAME(sptr);
3751 } else {
3752 #if defined(TARGET_WIN)
3753 /* we have a mix of undecorated and decorated names on win32 */
3754 strcpy(name, "_MAIN_");
3755 return name;
3756 #else
3757 q = "MAIN";
3758 #endif
3759 }
3760 while ((ch = *q++)) {
3761 if (ch == '$')
3762 *p++ = flg.dollar;
3763 else
3764 *p++ = ch;
3765 if (ch == '_')
3766 has_underscore = true;
3767 }
3768 /*
3769 * append underscore to name??? -
3770 * - always for entry,
3771 * - procedure if not compiler-created and not a "C" external..
3772 * - modified by -x 119 0x0100000 or -x 119 0x02000000
3773 */
3774 if (stype != ST_PROC || (!CCSYMG(sptr) && !CFUNCG(sptr))) {
3775 /* functions marked as !DEC$ ATTRIBUTES C get no underbar */
3776 if (!XBIT(119, 0x01000000) && !CFUNCG(sptr) && !CREFG(sptr) &&
3777 !CONTAINEDG(sptr)) {
3778 *p++ = '_';
3779 if (XBIT(119, 0x2000000) && has_underscore && !LIBSYMG(sptr))
3780 *p++ = '_';
3781 }
3782 }
3783 *p = '\0';
3784 if (MSCALLG(sptr) && !CFUNCG(sptr) && !XBIT(119, 0x4000000)) {
3785 if (ARGSIZEG(sptr) == -1)
3786 sprintf(name, "%s@0", name);
3787 else if (ARGSIZEG(sptr) > 0) {
3788 sprintf(name, "%s@%d", name, ARGSIZEG(sptr));
3789 }
3790 }
3791 if (!XBIT(121, 0x200000) &&
3792 ((MSCALLG(sptr) && !STDCALLG(sptr)) ||
3793 (CREFG(sptr) && !CFUNCG(sptr) && !CCSYMG(sptr))))
3794 /* if WINNT calling conventions are used, the name must be
3795 * uppercase unless the subprogram has the STDCALL attribute.
3796 * All cref intrinsic are lowercase.
3797 */
3798 upcase_name(name);
3799
3800 break;
3801 default:
3802 interr("getsname: bad stype for", sptr, ERR_Severe);
3803 strcpy(name, "b??");
3804 }
3805 return name;
3806 }
3807
3808 static void
upcase_name(char * name)3809 upcase_name(char *name)
3810 {
3811 char *p;
3812 int ch;
3813 for (p = name; (ch = *p); p++)
3814 if (ch >= 'a' && ch <= 'z')
3815 *p = ch + ('A' - 'a');
3816 }
3817
3818 char *
get_main_progname(void)3819 get_main_progname(void)
3820 {
3821 static char name[MXIDLN];
3822 char *nm = SYMNAME(gbl.currsub);
3823 sprintf(name, "%s", nm);
3824 if (!XBIT(119, 0x01000000)) {
3825 strcat(name, "_");
3826 }
3827 return name;
3828 }
3829
3830 static void
set_ag_ref(SPTR sptr)3831 set_ag_ref(SPTR sptr)
3832 {
3833 int gblsym;
3834 char *ifacenm;
3835 if (gbl.currsub)
3836 ifacenm = get_llvm_ifacenm(sptr);
3837 else
3838 ifacenm = get_llvm_name(sptr);
3839 gblsym = find_ag(ifacenm);
3840 if (gblsym) {
3841 AG_REF(gblsym) = 1;
3842 }
3843 }
3844
3845 void
sym_is_refd(SPTR sptr)3846 sym_is_refd(SPTR sptr)
3847 {
3848 ISZ_T size;
3849 DTYPE dtype = DTYPEG(sptr);
3850 int stype = STYPEG(sptr);
3851
3852 switch (stype) {
3853 case ST_PLIST:
3854 case ST_VAR:
3855 case ST_ARRAY:
3856 case ST_STRUCT:
3857 case ST_UNION:
3858 if (REFG(sptr))
3859 break;
3860 switch (SCG(sptr)) {
3861 case SC_DUMMY:
3862
3863 if (!is_passbyval_dummy(sptr))
3864 arg_is_refd(sptr);
3865 break;
3866 case SC_LOCAL:
3867 /*
3868 * assign address to automatic variable: auto offsets are
3869 * negative relative to the frame pointer. the current size of
3870 * of the stack frame is saved as a positive value; the last
3871 * offset assigned is the negative of the current frame size.
3872 * The negative of the current frame size is aligned so that the
3873 * variable ends on this boundary. The offset assigned is this
3874 * value minus its size in bytes. The new size of the stack frame
3875 * is the negative of the offset.
3876 * ASSUMPTIONS:
3877 * 1. the value frame pointer is an address whose alignment
3878 * matches that of the scalar item having the most strict
3879 * requrement.
3880 * 2. there are not gaps between the address located by the
3881 * frame pointer and the auto area (first offset is -1)
3882 */
3883 if (DINITG(sptr) || SAVEG(sptr) ||
3884 ((STYPEG(sptr) != ST_VAR || gbl.rutype == RU_PROG) && !flg.recursive &&
3885 (!CCSYMG(sptr) || INLNG(sptr)))) {
3886 /* can't put compiler-created symbols in static memory
3887 * until sched changes how it accesses its temporaries.
3888 * if it's a compiler-created symbol created by the
3889 * inliner, it's ok to place in static memory.
3890 * In any case, don't put scalars in static memory by default except
3891 * for main programs.
3892 */
3893 if (DINITG(sptr) || SAVEG(sptr) || STYPEG(sptr) != ST_VAR) {
3894 SCP(sptr, SC_STATIC);
3895 if (PARREFG(sptr))
3896 PARREFP(sptr, 0);
3897 if (!SAVEG(sptr) && !DINITG(sptr)) {
3898 if (!flg.smp && !XBIT(34, 0x200))
3899 LOCLIFETMP(sptr, 1);
3900 }
3901 goto static_shared;
3902 }
3903 }
3904 if (stype == ST_PLIST)
3905 size = PLLENG(sptr) * size_of(dtype);
3906 else
3907 size = size_of(dtype);
3908 /* For uplevel structure and ident_t in host subroutine(non outlined)
3909 * we set REFD field when we create it so that it does not gets here.
3910 * Because we don't want it to call assn_stkoff which will assign
3911 * negative addresses which may inadvertly cause it in create local
3912 * equivalence array.
3913 */
3914 if ((flg.smp || XBIT(34, 0x200)) && gbl.outlined)
3915 break;
3916 if (!SOCPTRG(sptr))
3917 break;
3918 assn_stkoff(sptr, dtype, size);
3919 break;
3920 case SC_STATIC:
3921 /*
3922 rhs structure constructure does not have DINITG or SAVED set
3923 To do list:
3924 We can create the type first so that we can reference to it and
3925 then we can print out the shape later if we make BSS a structure.
3926 Currrently we make BSS array for easy declaration (no other reason)
3927 We can use the same scheme for .STATICS.
3928 if (!DINITG(sptr) && !SAVEG(sptr))
3929 break;
3930 */
3931 if ((CLASSG(sptr) && DESCARRAYG(sptr)) || SECTG(sptr)) {
3932 ADDRESSP(sptr, 0); /* type descriptor for poly variable */
3933 break;
3934 }
3935 if (ALTNAMEG(sptr)) {
3936 ADDRESSP(sptr, 0); /* C interface */
3937 break;
3938 }
3939 static_shared:
3940 if (stype == ST_PLIST)
3941 size = PLLENG(sptr) * size_of(dtype);
3942 else
3943 size = size_of(dtype);
3944 assn_static_off(sptr, dtype, size);
3945 /* All other dinit'd symbol should ready be ref'd in host routine.
3946 * This left acc symbols to be ref'd here or any other symbol that
3947 * is referenced in outlined function only.
3948 */
3949 if (gbl.outlined && DINITG(sptr) && CCSYMG(sptr)) {
3950 ENCLFUNCP(sptr, gbl.currsub);
3951 }
3952 break;
3953 case SC_CMBLK:
3954 break;
3955 case SC_EXTERN:
3956 if (CLASSG(sptr) && DESCARRAYG(sptr)) {
3957 ADDRESSP(sptr, 0); /* type descriptor for poly variable */
3958 }
3959 break;
3960 case SC_PRIVATE:
3961 if (stype == ST_PLIST)
3962 size = PLLENG(sptr) * size_of(dtype);
3963 else
3964 size = size_of(dtype);
3965 if (!((flg.quad && size >= MIN_ALIGN_SIZE) || QALNG(sptr)))
3966 align_unconstrained(dtype); // XXX: sets dtypeutl.c#constrained
3967 break;
3968 case SC_NONE:
3969 default:
3970 break;
3971 }
3972 REFP(sptr, 1);
3973 break;
3974
3975 case ST_PROC:
3976 /* for PGF90, all ST_PROCs are on the gbl.externs list already */
3977 if (REFG(sptr) == 0 && SCG(sptr) == SC_EXTERN) {
3978 REFP(sptr, 1);
3979
3980 set_ag_ref(sptr);
3981 }
3982 break;
3983 case ST_CONST:
3984 SCP(sptr, SC_STATIC);
3985 if (SYMLKG(sptr) == 0) {
3986 SYMLKP(sptr, gbl.consts);
3987 gbl.consts = sptr;
3988 if (DTYPEG(sptr) == DT_ADDR && CONVAL1G(sptr))
3989 sym_is_refd(SymConval1(sptr));
3990 }
3991 break;
3992
3993 case ST_ENTRY: /* (found on entry ili only) */
3994 case ST_LABEL:
3995 break;
3996
3997 default:
3998
3999 break;
4000 }
4001 }
4002
4003 /**
4004 * For f90, the locals of a subprogram (the host) which contains internal
4005 * procedures must be allocated before generating code for the contained
4006 * procedures. At this time, the compiler does not know what and how host
4007 * local variables are referenced by the contained procedures. If we
4008 * don't allocate locals now, the cg may place local variables on the
4009 * stack, and at least two problems occur when the only reference is
4010 * from the internal procedure:
4011 * 1. a host local is initialized.
4012 * 2. a host local appears in a namelist group.
4013 */
4014 void
hostsym_is_refd(SPTR sptr)4015 hostsym_is_refd(SPTR sptr)
4016 {
4017 DTYPE dtype;
4018 int stype;
4019 ISZ_T size;
4020
4021 dtype = DTYPEG(sptr);
4022 switch (stype = STYPEG(sptr)) {
4023 case ST_PLIST:
4024 case ST_VAR:
4025 case ST_ARRAY:
4026 case ST_STRUCT:
4027 case ST_UNION:
4028 if (REFG(sptr))
4029 break;
4030 switch (SCG(sptr)) {
4031 case SC_LOCAL:
4032 /*
4033 * assign address to automatic variable: auto offsets are
4034 * negative relative to the frame pointer. the current size of
4035 * of the stack frame is saved as a positive value; the last
4036 * offset assigned is the negative of the current frame size.
4037 * The negative of the current frame size is aligned so that the
4038 * variable ends on this boundary. The offset assigned is this
4039 * value minus its size in bytes. The new size of the stack frame
4040 * is the negative of the offset.
4041 * ASSUMPTIONS:
4042 * 1. the value frame pointer is an address whose alignment
4043 * matches that of the scalar item having the most strict
4044 * requrement.
4045 * 2. there are not gaps between the address located by the
4046 * frame pointer and the auto area (first offset is -1)
4047 */
4048 if (DINITG(sptr) || SAVEG(sptr) ||
4049 (!flg.recursive && (!CCSYMG(sptr) || INLNG(sptr)))) {
4050 /* can't put compiler-created symbols in static memory
4051 * until sched changes how it accesses its temporaries.
4052 * if it's a compiler-created symbol created by the
4053 * inliner, it's ok to place in static memory.
4054 */
4055 SCP(sptr, SC_STATIC);
4056 if (PARREFG(sptr))
4057 PARREFP(sptr, 0);
4058 if (!SAVEG(sptr) && !DINITG(sptr)) {
4059 if (!flg.smp && !XBIT(34, 0x200))
4060 LOCLIFETMP(sptr, 1);
4061 }
4062 goto static_shared;
4063 }
4064 if (stype == ST_PLIST)
4065 size = PLLENG(sptr) * size_of(dtype);
4066 else {
4067 if (dtype == DT_ASSCHAR || dtype == DT_DEFERCHAR) {
4068 size = size_of(DT_PTR);
4069 } else
4070 size = size_of(dtype);
4071 }
4072 if (flg.smp && !SOCPTRG(sptr))
4073 break;
4074 assn_stkoff(sptr, dtype, size);
4075 break;
4076 case SC_STATIC:
4077 if (CLASSG(sptr) && DESCARRAYG(sptr)) {
4078 ADDRESSP(sptr, 0); /* type descriptor for poly variable */
4079 break;
4080 }
4081 static_shared:
4082 if (stype == ST_PLIST)
4083 size = PLLENG(sptr) * size_of(dtype);
4084 else
4085 size = size_of(dtype);
4086 assn_static_off(sptr, dtype, size);
4087 break;
4088 default:
4089 interr("hostsym_is_refd: bad sc\n", SCG(sptr), ERR_Severe);
4090 }
4091 REFP(sptr, 1);
4092 break;
4093
4094 default:
4095 interr("hostsym_is_refd:bad sty", sptr, ERR_Warning);
4096 }
4097 }
4098
4099 /**
4100 \brief Assign an address to a dummy argument which is allocated in the local
4101 area.
4102
4103 It's assumed that the alignment and size requirements for each argument are
4104 those that are required for pointer-sized integer.
4105 */
4106 void
arg_is_refd(int sptr)4107 arg_is_refd(int sptr)
4108 {
4109 DTYPE dtype;
4110 INT size;
4111
4112 if (!HOMEDG(sptr) || REFG(sptr))
4113 return;
4114
4115 /* haven't homed or space has been alloc'ed */
4116 /* for now, get pointer-sized int allocation */
4117 dtype = DT_ADDR;
4118 size = size_of(dtype); /* is really ptr to */
4119
4120 /* hack to avoid problems with zero-length strings.
4121 * make character*0 appear like character*1 */
4122 if (size == 0)
4123 size = 1;
4124
4125 REFP(sptr, 1);
4126 HOMEDP(sptr, 0);
4127
4128 /* sptr is the .cxxxx indirection temp; progagate information to
4129 * the sptr of the argument
4130 */
4131 if (REDUCG(sptr) && MIDNUMG(sptr)) {
4132 int arg;
4133 arg = MIDNUMG(sptr);
4134 ADDRESSP(arg, ADDRESSG(sptr));
4135 HOMEDP(arg, 0);
4136 }
4137 }
4138
4139 /**
4140 \brief Get the alignment in bytes of a symbol representing a variable
4141 */
4142 unsigned
align_of_var(SPTR sptr)4143 align_of_var(SPTR sptr)
4144 {
4145 DTYPE dtype = DTYPEG(sptr);
4146 if (!PDALN_IS_DEFAULT(sptr))
4147 return 1u << PDALNG(sptr);
4148 if (QALNG(sptr))
4149 return 4 * align_of(DT_INT);
4150 if (dtype) {
4151 if (flg.quad && !DESCARRAYG(sptr) && zsize_of(dtype) >= MIN_ALIGN_SIZE) {
4152 return DATA_ALIGN + 1;
4153 }
4154 return align_of(dtype);
4155 }
4156 if (STYPEG(sptr) == ST_PROC) /* No DTYPE */
4157 return align_of(DT_ADDR);
4158 return 0;
4159 }
4160
4161 static void
assn_stkoff(SPTR sptr,DTYPE dtype,ISZ_T size)4162 assn_stkoff(SPTR sptr, DTYPE dtype, ISZ_T size)
4163 {
4164 int a;
4165 ISZ_T addr;
4166
4167 /* hack to avoid problems with zero-length strings.
4168 * make character*0 appear like character*1 */
4169 if (size == 0)
4170 size = 1;
4171 if (XBIT(129, 0x40000000) && size > ALN_MINSZ && !DESCARRAYG(sptr)) {
4172 a = CACHE_ALIGN;
4173 size += ALN_UNIT * stk_aln_n;
4174 if (stk_aln_n <= ALN_THRESH)
4175 stk_aln_n++;
4176 else
4177 stk_aln_n = 1;
4178 } else if (STACK_CAN_BE_32_BYTE_ALIGNED && size >= 32) {
4179 a = 31;
4180 /* Round-up 'size' since sym's offset is 'aligned next' - size. */
4181 size = ALIGN(size, a);
4182 } else if ((flg.quad && size >= MIN_ALIGN_SIZE) ||
4183 (QALNG(sptr) && !DESCARRAYG(sptr))) {
4184 a = DATA_ALIGN;
4185 /* round-up size since sym's offset is 'aligned next' - size */
4186 size = ALIGN(size, a);
4187 } else {
4188 a = align_unconstrained(dtype);
4189 }
4190 addr = -gbl.locaddr;
4191 addr = ALIGN_AUTO(addr, a) - size;
4192 ADDRESSP(sptr, addr);
4193 gbl.locaddr = -addr;
4194 SYMLKP(sptr, gbl.locals);
4195 gbl.locals = sptr;
4196 if (DBGBIT(5, 32)) {
4197 fprintf(gbl.dbgfil, "addr: %6d size: %6d %-32s (%s)\n", (int)addr,
4198 (int)size, getprint(sptr), getprint((int)gbl.currsub));
4199 }
4200 }
4201
4202 static void
assn_static_off(SPTR sptr,DTYPE dtype,ISZ_T size)4203 assn_static_off(SPTR sptr, DTYPE dtype, ISZ_T size)
4204 {
4205 int a;
4206 ISZ_T addr;
4207
4208 if (DINITG(sptr))
4209 addr = gbl.saddr;
4210 else
4211 addr = gbl.bss_addr;
4212 if (size == 0)
4213 size = 1;
4214 if (XBIT(129, 0x40000000) && size > ALN_MINSZ && DTY(dtype) != TY_CHAR) {
4215 a = CACHE_ALIGN;
4216 size += ALN_UNIT * bss_aln_n;
4217 if (bss_aln_n <= ALN_THRESH)
4218 bss_aln_n++;
4219 else
4220 bss_aln_n = 1;
4221 } else if ((flg.quad && size >= MIN_ALIGN_SIZE) || QALNG(sptr)) {
4222 a = DATA_ALIGN;
4223 } else {
4224 a = align_unconstrained(dtype);
4225 }
4226 addr = ALIGN(addr, a);
4227 ADDRESSP(sptr, addr);
4228 if (DINITG(sptr)) {
4229 gbl.saddr = addr + size;
4230 SYMLKP(sptr, gbl.statics);
4231 gbl.statics = sptr;
4232 if (static_name_global == 1) {
4233 /* make sure the static_name gets output */
4234 static_name_global = 2;
4235 SYMLKP(static_base, gbl.basevars);
4236 gbl.basevars = static_base;
4237 }
4238 if (DBGBIT(5, 32)) {
4239 fprintf(gbl.dbgfil, "saddr: %6d size: %6d %-32s (%s)\n", (int)addr,
4240 (int)size, getprint(sptr), getprint((int)gbl.currsub));
4241 }
4242 } else {
4243 gbl.bss_addr = addr + size;
4244 SYMLKP(sptr, gbl.bssvars);
4245 gbl.bssvars = sptr;
4246 if (bss_name_global == 1) {
4247 /* make sure the bss_name gets output */
4248 bss_name_global = 2;
4249 SYMLKP(bss_base, gbl.basevars);
4250 gbl.basevars = bss_base;
4251 }
4252 if (DBGBIT(5, 32)) {
4253 fprintf(gbl.dbgfil, "baddr: %6d size: %6d %-32s (%s)\n", (int)addr,
4254 (int)size, getprint(sptr), getprint((int)gbl.currsub));
4255 }
4256 }
4257 }
4258
4259 /**
4260 \brief Makes adjustments to the list \p loc_list
4261 \param loc_list list of local symbols linked by SYMLK
4262 \param loc_addr total size of the equivalenced locals
4263
4264 The equivalence processor assigns positive offsets to the local variables
4265 which appear in equivalence statements. Target addresses must be assigned
4266 using the offsets provided by the equivalence processor.
4267 */
4268 void
fix_equiv_locals(SPTR loc_list,ISZ_T loc_addr)4269 fix_equiv_locals(SPTR loc_list, ISZ_T loc_addr)
4270 {
4271 SPTR sym;
4272 ISZ_T maxa;
4273
4274 if (loc_list != NOSYM) {
4275 maxa = alignment(DT_DBLE); /* align new size just in case */
4276 gbl.locaddr = ALIGN(gbl.locaddr + loc_addr, maxa);
4277 do {
4278 /* NOTE: REF flag of sym set during equivalence processing */
4279 sym = loc_list;
4280 loc_list = SYMLKG(loc_list);
4281
4282 ADDRESSP(sym, -gbl.locaddr + ADDRESSG(sym));
4283 SCP(sym, SC_LOCAL);
4284 SYMLKP(sym, gbl.locals);
4285 gbl.locals = sym;
4286 } while (loc_list != NOSYM);
4287 }
4288 }
4289
4290 /*
4291 * similiar to fix_equiv_locals except that these local variables were
4292 * saved and/or dinit'd. for these variables, switch the storage class to
4293 * SC_STATIC.
4294 * the equivalence processor assigns positive offsets to the local variables
4295 * which appear in equivalence statements. Target addresses must be
4296 * assigned using the offsets provided by the equivalence processor.
4297 */
4298 void
fix_equiv_statics(SPTR loc_list,ISZ_T loc_addr,bool dinitflg)4299 fix_equiv_statics(SPTR loc_list, /* list of local symbols linked by SYMLK */
4300 ISZ_T loc_addr, /* total size of the equivalenced locals */
4301 bool dinitflg) /* variables were dinit'd */
4302 {
4303 SPTR sym;
4304 int maxa;
4305 ISZ_T addr;
4306
4307 #if DEBUG
4308 assert(loc_list != NOSYM, "fix_equiv_statics: bad loc_list", 0, ERR_Severe);
4309 #endif
4310 maxa = alignment(DT_DBLE); /* align new size just in case */
4311 if (dinitflg) {
4312 addr = gbl.saddr;
4313 addr = ALIGN(addr, maxa);
4314 do {
4315 /* NOTE: REF flag of sym set during equivalence processing */
4316 sym = loc_list;
4317 loc_list = SYMLKG(loc_list);
4318 ADDRESSP(sym, addr + ADDRESSG(sym));
4319 SCP(sym, SC_STATIC);
4320 SYMLKP(gbl.statics, sym);
4321 gbl.statics = sym;
4322 DINITP(sym, 1); /* ensure getsname thinks it's in STATIC */
4323 } while (loc_list != NOSYM);
4324 gbl.saddr = addr += loc_addr;
4325 if (static_name_global == 1) {
4326 /* make sure the static_name gets output */
4327 static_name_global = 2;
4328 SYMLKP(static_base, gbl.basevars);
4329 gbl.basevars = static_base;
4330 }
4331 } else {
4332 addr = gbl.bss_addr;
4333 addr = ALIGN(addr, maxa);
4334 do {
4335 /* NOTE: REF flag of sym set during equivalence processing */
4336 sym = loc_list;
4337 loc_list = SYMLKG(loc_list);
4338 ADDRESSP(sym, addr + ADDRESSG(sym));
4339 SYMLKP(sym, gbl.bssvars);
4340 gbl.bssvars = sym;
4341 SCP(sym, SC_STATIC);
4342 } while (loc_list != NOSYM);
4343 gbl.bss_addr = addr += loc_addr;
4344 if (bss_name_global == 1) {
4345 /* make sure the bss_name gets output */
4346 bss_name_global = 2;
4347 SYMLKP(bss_base, gbl.basevars);
4348 gbl.basevars = bss_base;
4349 }
4350 }
4351 }
4352
4353 /* DEBUG Routines */
4354
4355 void
assem_emit_line(int findex,int lineno)4356 assem_emit_line(int findex, int lineno)
4357 {
4358 }
4359
4360 void
assem_emit_file_line(int findex,int lineno)4361 assem_emit_file_line(int findex, int lineno)
4362 {
4363 }
4364
4365 static char straddrbuf[20];
4366 static char straddrpbuf[sizeof(bss_name) + 11 + 2];
4367
4368 static char *
straddr(int sptr)4369 straddr(int sptr)
4370 {
4371 sprintf(straddrbuf, "%ld", (long)ADDRESSG(sptr));
4372 return (straddrbuf);
4373 }
4374
4375 static char *
straddrp(int sptr,char * bufptr)4376 straddrp(int sptr, char *bufptr)
4377 {
4378 sprintf(straddrpbuf, "%s+%ld", bufptr, (long)ADDRESSG(sptr));
4379 return (straddrpbuf);
4380 }
4381
4382 char *
getaddrdebug(SPTR sptr)4383 getaddrdebug(SPTR sptr)
4384 {
4385 switch (STYPEG(sptr)) {
4386
4387 case ST_LABEL:
4388 return getsname(sptr);
4389
4390 case ST_STAG:
4391 case ST_TYPEDEF:
4392 case ST_MEMBER:
4393 return straddr(sptr);
4394
4395 case ST_VAR:
4396 case ST_ARRAY:
4397 case ST_STRUCT:
4398 case ST_UNION:
4399 switch (SCG(sptr)) {
4400 case SC_PRIVATE:
4401 case SC_NONE:
4402 case SC_LOCAL:
4403 case SC_DUMMY:
4404 case SC_CMBLK:
4405 return straddr(sptr);
4406 case SC_STATIC:
4407 if (CLASSG(sptr) && DESCARRAYG(sptr)) {
4408 return getsname(sptr);
4409 }
4410 #ifdef BASEADDRG
4411 if (BASEADDRG(sptr)) {
4412 return straddrp(sptr, SYMNAME(BASESYMG(sptr)));
4413 }
4414 #endif
4415 if (UPLEVELG(sptr) || (gbl.outlined && gbl.internal <= 1)) {
4416 if (DINITG(sptr))
4417 return straddrp(sptr, outer_static_name);
4418 return straddrp(sptr, outer_bss_name);
4419 }
4420 if (DINITG(sptr)) {
4421 if (static_name_global == 1) {
4422 /* make sure the static_name gets output */
4423 static_name_global = 2;
4424 SYMLKP(static_base, gbl.basevars);
4425 gbl.basevars = static_base;
4426 }
4427 if (gbl.outlined)
4428 return straddrp(sptr, outer_static_name);
4429 else
4430 return straddrp(sptr, static_name);
4431 }
4432 if (bss_name_global == 1) {
4433 /* make sure the bss_name gets output */
4434 bss_name_global = 2;
4435 SYMLKP(bss_base, gbl.basevars);
4436 gbl.basevars = bss_base;
4437 }
4438 return straddrp(sptr, bss_name);
4439
4440 case SC_EXTERN:
4441 return getsname(sptr);
4442 case SC_BASED:
4443 return 0;
4444 }
4445
4446 case ST_CMBLK:
4447 case ST_ENTRY:
4448 case ST_PROC:
4449 case ST_INTRIN:
4450 case ST_GENERIC:
4451 case ST_PD:
4452 switch (SCG(sptr)) {
4453 case SC_DUMMY:
4454 return straddr(sptr);
4455 case SC_NONE:
4456 case SC_LOCAL:
4457 case SC_STATIC:
4458 case SC_CMBLK:
4459 case SC_EXTERN:
4460 return getsname(sptr);
4461 case SC_PRIVATE:
4462 case SC_BASED:
4463 break;
4464 }
4465 return 0;
4466 default:
4467 return 0;
4468 }
4469 }
4470
4471 /* Profiling Routines */
4472
4473 int
get_private_size()4474 get_private_size()
4475 {
4476 char name[32];
4477 if (gbl.prvt_sym_sz == 0) {
4478 strcpy(name, ".prvt");
4479 sprintf(&name[5], "%04d", gbl.func_count);
4480 gbl.prvt_sym_sz = getsymbol(name);
4481 STYPEP(gbl.prvt_sym_sz, ST_VAR);
4482 CCSYMP(gbl.prvt_sym_sz, 1);
4483 DTYPEP(gbl.prvt_sym_sz, DT_INT8);
4484 DINITP(gbl.prvt_sym_sz, 1);
4485 SCP(gbl.prvt_sym_sz, SC_STATIC);
4486 }
4487 return gbl.prvt_sym_sz;
4488 }
4489 int
get_stack_size()4490 get_stack_size()
4491 {
4492 char name[10];
4493 if (gbl.stk_sym_sz == 0) {
4494 strcpy(name, ".stk");
4495 sprintf(&name[4], "%04d", gbl.func_count);
4496 gbl.stk_sym_sz = getsymbol(name);
4497 STYPEP(gbl.stk_sym_sz, ST_VAR);
4498 CCSYMP(gbl.stk_sym_sz, 1);
4499 DTYPEP(gbl.stk_sym_sz, DT_INT8);
4500 DINITP(gbl.stk_sym_sz, 1);
4501 SCP(gbl.stk_sym_sz, SC_STATIC);
4502 }
4503 return gbl.stk_sym_sz;
4504 }
4505
4506 /**
4507 \brief The F90 front-end may have allocated private variables - need to
4508 adjust the initial size of the private area.
4509 */
4510 void
set_private_size(ISZ_T sz)4511 set_private_size(ISZ_T sz)
4512 {
4513 prvt.addr = sz + 0;
4514 }
4515
4516 void
set_bss_addr(int size)4517 set_bss_addr(int size)
4518 {
4519 gbl.bss_addr = size;
4520 } /* set_bss_addr */
4521
4522 int
get_bss_addr()4523 get_bss_addr()
4524 {
4525 return gbl.bss_addr;
4526 } /* get_bss_addr */
4527
4528 int
runtime_alignment(SPTR syma)4529 runtime_alignment(SPTR syma)
4530 {
4531 SPTR sptr;
4532 int offset;
4533
4534 sptr = SymConval1(syma);
4535 if (sptr) {
4536 sym_is_refd(sptr);
4537 }
4538 offset = CONVAL2G(syma);
4539 #undef ALN
4540 #define ALN(x, a) ((x)&a)
4541 if (!sptr) {
4542 return ALN(offset, DATA_ALIGN);
4543 }
4544 switch (SCG(sptr)) {
4545 case SC_LOCAL:
4546 case SC_PRIVATE:
4547 case SC_STATIC:
4548 case SC_CMBLK:
4549 /*
4550 * The stack, common blocks, bss, and data sections are
4551 * cache aligned.
4552 */
4553 return ALN(ADDRESSG(sptr) + offset, DATA_ALIGN);
4554 break;
4555 case SC_BASED:
4556 break;
4557 case SC_DUMMY:
4558 /* fall thru - QALN set by ipa */
4559 case SC_EXTERN:
4560 if (QALNG(sptr))
4561 return ALN(offset, DATA_ALIGN);
4562 break;
4563 case SC_NONE:
4564 break;
4565 }
4566 return -1;
4567 } /* end runtime_alignment( int syma ) */
4568
4569 int
runtime_32_byte_alignment(SPTR acon_sptr)4570 runtime_32_byte_alignment(SPTR acon_sptr)
4571 {
4572 SPTR var_sptr;
4573
4574 if (!STACK_CAN_BE_32_BYTE_ALIGNED)
4575 return -1;
4576
4577 var_sptr = SymConval1(acon_sptr);
4578 if (!var_sptr)
4579 return -1;
4580
4581 sym_is_refd(var_sptr);
4582
4583 if (SCG(var_sptr) == SC_LOCAL) {
4584 ENFORCE_32_BYTE_STACK_ALIGNMENT;
4585 return ALN(ADDRESSG(var_sptr) + CONVAL2G(acon_sptr), 31);
4586 }
4587 return -1;
4588 } /* end runtime_32_byte_alignment( int acon_sptr ) */
4589
4590 int
is_cache_aligned(SPTR syma)4591 is_cache_aligned(SPTR syma)
4592 {
4593 if (runtime_alignment(syma))
4594 return 0;
4595 return 1;
4596 }
4597
4598 void
create_static_name(char * name,int usestatic,int num)4599 create_static_name(char *name, int usestatic, int num)
4600 {
4601 if (usestatic) {
4602 sprintf(name, ".GL.STAT%d", num);
4603 } else {
4604 sprintf(name, ".GL.BSS%d", num);
4605 }
4606 } /* create_static_name */
4607
4608 /*
4609 * Create a new name for the base address of the statics,
4610 * initialized and uninitialized.
4611 * Put these names in static_name and bss_name.
4612 * Create symbols (ST_IDENT) to hold these names.
4613 * Go through the list of statics in gbl.statics and gbl.bssvars,
4614 * set the BASEADDR field and set the MIDNUM field to the appropriate symbol
4615 */
4616 void
create_static_base(int num)4617 create_static_base(int num)
4618 {
4619 int sptr;
4620 if (num <= 0) {
4621 static_name_initialized = 0;
4622 static_name_global = 0;
4623 static_base = SPTR_NULL;
4624 bss_name_initialized = 0;
4625 bss_name_global = 0;
4626 bss_base = SPTR_NULL;
4627 return;
4628 }
4629 if (gbl.outlined)
4630 create_static_name(outer_bss_name, 0, num);
4631 else
4632 create_static_name(bss_name, 0, num);
4633 bss_base = addnewsym(bss_name);
4634 STYPEP(bss_base, ST_BASE);
4635 bss_name_initialized = 1;
4636 if (gbl.bssvars <= NOSYM) {
4637 SYMLKP(bss_base, NOSYM);
4638 bss_name_global = 1;
4639 if (gbl.bss_addr > 0) {
4640 bss_name_global = 2;
4641 SYMLKP(bss_base, gbl.basevars);
4642 gbl.basevars = bss_base;
4643 }
4644 } else {
4645 bss_name_global = 2;
4646 SYMLKP(bss_base, gbl.basevars);
4647 gbl.basevars = bss_base;
4648 for (sptr = gbl.bssvars; sptr > NOSYM; sptr = SYMLKG(sptr)) {
4649 BASEADDRP(sptr, 1);
4650 BASESYMP(sptr, bss_base);
4651 }
4652 }
4653 if (gbl.outlined)
4654 create_static_name(outer_static_name, 1, num);
4655 else
4656 create_static_name(static_name, 1, num);
4657 static_base = addnewsym(static_name);
4658 STYPEP(static_base, ST_BASE);
4659 static_name_initialized = 1;
4660 if (gbl.statics <= NOSYM) {
4661 SYMLKP(static_base, NOSYM);
4662 static_name_global = 1;
4663 if (gbl.saddr > 0) {
4664 static_name_global = 2;
4665 SYMLKP(static_base, gbl.basevars);
4666 gbl.basevars = static_base;
4667 }
4668 } else {
4669 static_name_global = 2;
4670 SYMLKP(static_base, gbl.basevars);
4671 gbl.basevars = static_base;
4672 for (sptr = gbl.statics; sptr > NOSYM; sptr = SYMLKG(sptr)) {
4673 BASEADDRP(sptr, 1);
4674 BASESYMP(sptr, static_base);
4675 }
4676 }
4677 } /* create_static_base */
4678
4679 /**
4680 \brief Get the list to attach !dbg for the symbol \p sptr
4681 \param sptr the symbol (of an object)
4682 */
4683 LL_ObjToDbgList **
llassem_get_objtodbg_list(SPTR sptr)4684 llassem_get_objtodbg_list(SPTR sptr)
4685 {
4686 switch (SCG(sptr)) {
4687 case SC_STATIC:
4688 if (CLASSG(sptr) && DESCARRAYG(sptr))
4689 return NULL;
4690 #ifdef BASEADDRG
4691 if (BASEADDRG(sptr))
4692 return NULL; // SYMNAME(BASESYMG(sptr));
4693 #endif
4694 if (ALTNAMEG(sptr))
4695 return NULL; // get_altname(sptr);
4696 if (UPLEVELG(sptr)) {
4697 if (DINITG(sptr))
4698 return NULL; // outer_static_name;
4699 return NULL; // outer_bss_name;
4700 }
4701 if (SECTG(sptr)) {
4702 // sprintf(name, ".SECTION%d_%d_%s", gbl.func_count, sptr, prepend);
4703 return NULL; // name;
4704 }
4705 if (ALTNAMEG(sptr))
4706 return NULL; // get_altname(sptr);
4707 if (DINITG(sptr)) {
4708 if (gbl.outlined && ENCLFUNCG(sptr) && (ENCLFUNCG(sptr) == gbl.currsub))
4709 return &static_dbg_list;
4710 /* zero sized array reference, use BSS instead of STATICS */
4711 if ((DTY(DTYPEG(sptr)) == TY_ARRAY) && SCG(sptr) == SC_STATIC &&
4712 extent_of(DTYPEG(sptr)) == 0)
4713 return &bss_dbg_list;
4714 if (gbl.outlined) {
4715 if (gbl.internal > 1)
4716 return NULL; // contained_static_name;
4717 return NULL; // outer_static_name;
4718 }
4719 return &static_dbg_list;
4720 }
4721 if (gbl.outlined) {
4722 if (gbl.internal > 1)
4723 return NULL; // contained_bss_name;
4724 return NULL; // outer_bss_name;
4725 }
4726 return &bss_dbg_list;
4727 default:
4728 break;
4729 }
4730 return NULL;
4731 }
4732
4733 /**
4734 \brief Get the LLVM name of the symbol \p sptr
4735 \param sptr The symbol
4736 \return a name (as a possibly transient string)
4737
4738 NB: This \e may return a pointer to a global buffer, so a subsequent call can
4739 silently clobber the string returned.
4740 */
4741 char *
get_llvm_name(SPTR sptr)4742 get_llvm_name(SPTR sptr)
4743 {
4744 static char name[MXIDLN]; /* 1 for null, 3 for extra '_' ,
4745 * 4 for @### with mscall
4746 */
4747 char *p, *q, ch;
4748 bool has_underscore = false;
4749 int m;
4750 char *prepend = "\0";
4751 const SYMTYPE stype = STYPEG(sptr);
4752
4753 switch (stype) {
4754 case ST_MEMBER:
4755 return SYMNAME(sptr);
4756
4757 case ST_LABEL:
4758 sprintf(name, "%sB%d_%d", ULABPFX, gbl.func_count, sptr);
4759 break;
4760 case ST_CONST:
4761 case ST_PARAM:
4762 sprintf(name, ".C%d_%s", sptr, getfuncname(gbl.currsub));
4763 break;
4764 case ST_BASE:
4765 if (MIDNUMG(sptr))
4766 return SYMNAME(MIDNUMG(sptr));
4767 return SYMNAME(sptr);
4768 case ST_VAR:
4769 case ST_ARRAY:
4770 case ST_STRUCT:
4771 case ST_UNION:
4772 case ST_NML:
4773 case ST_PLIST:
4774 switch (SCG(sptr)) {
4775 case SC_DUMMY:
4776 if (MIDNUMG(sptr)) {
4777 if ((SC_DUMMY == SCG(MIDNUMG(sptr))) ||
4778 (!HOMEDG(sptr) && ((gbl.internal != 1) || (!PASSBYVALG(sptr)))))
4779 sptr = MIDNUMG(sptr);
4780 }
4781 return SYMNAME(sptr);
4782
4783 case SC_EXTERN:
4784 if (ALTNAMEG(sptr) && CFUNCG(sptr))
4785 return get_altname(sptr);
4786 goto xlate_name;
4787 case SC_CMBLK:
4788 if (ALTNAMEG(sptr))
4789 return get_altname(sptr);
4790 /* modification needed on this name ? */
4791 if (CFUNCG(sptr))
4792 return SYMNAME(sptr);
4793 return getsname(MIDNUMG(sptr));
4794
4795 case SC_LOCAL:
4796 if ((!REFG(sptr) && DINITG(sptr)) || !DINITG(sptr)) {
4797
4798 if (CCSYMG(sptr)) {
4799 /* append sptr to avoid duplicate local symbol name */
4800 sprintf(name, "%s_%d", SYMNAME(sptr), sptr);
4801 return name;
4802 }
4803 /* keep name as shown in our symbol table */
4804 sprintf(name, "%s_%d", SYMNAME(sptr), sptr);
4805 return name;
4806 }
4807 case SC_STATIC:
4808 if (CLASSG(sptr) && DESCARRAYG(sptr))
4809 goto xlate_name;
4810 #ifdef BASEADDRG
4811 if (BASEADDRG(sptr))
4812 return SYMNAME(BASESYMG(sptr));
4813 #endif
4814 if (ALTNAMEG(sptr))
4815 return get_altname(sptr);
4816 if (UPLEVELG(sptr)) {
4817 if (DINITG(sptr))
4818 return outer_static_name;
4819 return outer_bss_name;
4820 }
4821 if (SECTG(sptr)) {
4822 #ifdef CUDAG
4823 if (gbl.currsub && (CUDAG(gbl.currsub) & CUDA_CONSTRUCTOR) &&
4824 global_sptr) {
4825 /* prepend a module or routine name defined in this file */
4826 prepend = AG_NAME(global_sptr);
4827 }
4828 #endif
4829 sprintf(name, ".SECTION%d_%d_%s", gbl.func_count, sptr, prepend);
4830 return name;
4831 }
4832 if (ALTNAMEG(sptr))
4833 return get_altname(sptr);
4834 if (DINITG(sptr)) {
4835 if (gbl.outlined && ENCLFUNCG(sptr) && (ENCLFUNCG(sptr) == gbl.currsub))
4836 return static_name;
4837 if (static_name_global == 1) {
4838 /* zero sized array reference, use BSS instead of STATICS */
4839 if ((DTY(DTYPEG(sptr)) == TY_ARRAY) && extent_of(DTYPEG(sptr)) == 0) {
4840 bss_name_global = 2;
4841 SYMLKP(bss_base, gbl.basevars);
4842 gbl.basevars = bss_base;
4843 ADDRESSP(sptr, gbl.bss_addr);
4844 if (gbl.bss_addr == 0)
4845 gbl.bss_addr = 4;
4846 } else {
4847 static_name_global = 2;
4848 SYMLKP(static_base, gbl.basevars);
4849 gbl.basevars = static_base;
4850 }
4851 }
4852 /* zero sized array reference, use BSS instead of STATICS */
4853 if ((DTY(DTYPEG(sptr)) == TY_ARRAY) && extent_of(DTYPEG(sptr)) == 0) {
4854 ADDRESSP(sptr, gbl.bss_addr);
4855 if (gbl.bss_addr == 0)
4856 gbl.bss_addr = 4;
4857 return bss_name;
4858 }
4859 if (gbl.outlined) {
4860 if (gbl.internal > 1)
4861 return contained_static_name;
4862 return outer_static_name;
4863 }
4864 return static_name;
4865 }
4866 if (bss_name_global == 1) {
4867 /* make sure the bss_name gets output */
4868 bss_name_global = 2;
4869 SYMLKP(bss_base, gbl.basevars);
4870 gbl.basevars = bss_base;
4871 }
4872 if (gbl.outlined) {
4873 if (gbl.internal > 1)
4874 return contained_bss_name;
4875 return outer_bss_name;
4876 }
4877 return bss_name;
4878
4879 case SC_BASED:
4880 if (MIDNUMG(sptr) && SCG(MIDNUMG(sptr)) == SC_DUMMY)
4881 return SYMNAME(MIDNUMG(sptr));
4882 // fall-through
4883 case SC_PRIVATE:
4884 sprintf(name, "%s_%d", SYMNAME(sptr), sptr);
4885 break;
4886 default:
4887 sprintf(name, ".V%d_%d", gbl.func_count, sptr);
4888 break;
4889 }
4890 return name;
4891 case ST_CMBLK:
4892 #if defined(TARGET_OSX)
4893 if (FROMMODG(sptr)) { /* common block is from a module */
4894 int md;
4895 md = SCOPEG(sptr);
4896 if (md && NEEDMODG(md)) {
4897 /* module is use-associated */
4898 TYPDP(md, 1);
4899 }
4900 }
4901 #endif
4902 if (ALTNAMEG(sptr))
4903 return get_altname(sptr);
4904 if (CFUNCG(sptr)) {
4905 /* common block C name compatibility : no underscore */
4906 return SYMNAME(sptr);
4907 }
4908
4909 xlate_name:
4910 if (XBIT(119, 0x1000)) { /* add leading underscore */
4911 name[0] = '_';
4912 p = name + 1;
4913 } else {
4914 p = name;
4915 }
4916 q = SYMNAME(sptr);
4917 while ((ch = *q++)) {
4918 if (ch == '$')
4919 *p++ = flg.dollar;
4920 else
4921 *p++ = ch;
4922 if (ch == '_')
4923 has_underscore = true;
4924 }
4925 /*
4926 * append underscore to name??? -
4927 * - always for common block (note - common block may have CCSYM set),
4928 * - not compiler-created external variable,
4929 * - modified by -x 119 0x0100000 or -x 119 0x02000000
4930 */
4931 #ifdef OMP_OFFLOAD_LLVM
4932 if (!OMPACCRTG(sptr))
4933 #endif
4934 if ((STYPEG(sptr) == ST_CMBLK || !CCSYMG(sptr)) && !CFUNCG(sptr)) {
4935 if (!XBIT(119, 0x01000000)) {
4936 *p++ = '_';
4937 if (XBIT(119, 0x2000000) && has_underscore &&
4938 !CCSYMG(sptr) && !LIBSYMG(sptr))
4939 *p++ = '_';
4940 }
4941 }
4942 *p = '\0';
4943 #if defined(TARGET_WIN)
4944 if (!XBIT(121, 0x200000) && STYPEG(sptr) == ST_CMBLK && !CCSYMG(sptr) &&
4945 XBIT(119, 0x01000000))
4946 upcase_name(name);
4947 #endif
4948 break;
4949 case ST_ENTRY:
4950 case ST_PROC:
4951 if (ALTNAMEG(sptr)) {
4952 return get_altname(sptr);
4953 }
4954 if (SCG(sptr) == SC_DUMMY)
4955 return SYMNAME(sptr);
4956 if ((flg.smp || XBIT(34, 0x200)) && OUTLINEDG(sptr)) {
4957 sprintf(name, "%s", SYMNAME(sptr));
4958 p = name;
4959 }
4960 else if (gbl.internal && CONTAINEDG(sptr)) {
4961 p = name;
4962 if (gbl.outersub) {
4963 m = INMODULEG(gbl.outersub);
4964 if (m) {
4965 q = SYMNAME(m);
4966 while ((ch = *q++)) {
4967 if (ch == '$')
4968 *p++ = flg.dollar;
4969 else
4970 *p++ = ch;
4971 }
4972 *p++ = '_';
4973 }
4974 q = SYMNAME(gbl.outersub);
4975 while ((ch = *q++)) {
4976 if (ch == '$')
4977 *p++ = flg.dollar;
4978 else
4979 *p++ = ch;
4980 }
4981 *p++ = '_';
4982 }
4983 q = SYMNAME(sptr);
4984 while ((ch = *q++)) {
4985 if (ch == '$')
4986 *p++ = flg.dollar;
4987 else
4988 *p++ = ch;
4989 }
4990 *p = '\0';
4991 return name;
4992 }
4993 if (XBIT(119, 0x1000)) { /* add leading underscore */
4994 name[0] = '_';
4995 p = name + 1;
4996 } else
4997 p = name;
4998 m = INMODULEG(sptr);
4999 if (m) {
5000 q = SYMNAME(m);
5001 while ((ch = *q++)) {
5002 if (ch == '$')
5003 *p++ = flg.dollar;
5004 else
5005 *p++ = ch;
5006 }
5007 *p++ = '_';
5008 }
5009 if (stype != ST_ENTRY || gbl.rutype != RU_PROG) {
5010 q = SYMNAME(sptr);
5011 } else if ((flg.smp || XBIT(34, 0x200) || gbl.usekmpc) && OUTLINEDG(sptr)) {
5012 q = SYMNAME(sptr);
5013 } else {
5014 #if defined(TARGET_WIN)
5015 /* we have a mix of undecorated and decorated names on win32 */
5016 strcpy(name, "_MAIN_");
5017 return name;
5018 #else
5019 q = "MAIN";
5020 #endif
5021 }
5022 while ((ch = *q++)) {
5023 if (ch == '$')
5024 *p++ = flg.dollar;
5025 else
5026 *p++ = ch;
5027 if (ch == '_')
5028 has_underscore = true;
5029 }
5030 /*
5031 * append underscore to name??? -
5032 * - always for entry,
5033 * - procedure if not compiler-created and not a "C" external..
5034 * - modified by -x 119 0x0100000 or -x 119 0x02000000
5035 */
5036 if (stype != ST_PROC || (!CCSYMG(sptr) && !CFUNCG(sptr))) {
5037 /* functions marked as !DEC$ ATTRIBUTES C get no underbar */
5038 if (!XBIT(119, 0x01000000) && !CFUNCG(sptr) && !CREFG(sptr)
5039 #ifdef CONTAINEDG
5040 && !CONTAINEDG(sptr)
5041 #endif
5042 ) {
5043 *p++ = '_';
5044 if (XBIT(119, 0x2000000) && has_underscore && !LIBSYMG(sptr))
5045 *p++ = '_';
5046 }
5047 }
5048 *p = '\0';
5049 if (MSCALLG(sptr) && !CFUNCG(sptr) && !XBIT(119, 0x4000000)) {
5050 if (ARGSIZEG(sptr) == -1)
5051 sprintf(name, "%s@0", name);
5052 else if (ARGSIZEG(sptr) > 0) {
5053 sprintf(name, "%s@%d", name, ARGSIZEG(sptr));
5054 }
5055 }
5056 if (!XBIT(121, 0x200000) &&
5057 ((MSCALLG(sptr) && !STDCALLG(sptr)) ||
5058 (CREFG(sptr) && !CFUNCG(sptr) && !CCSYMG(sptr))))
5059 /* if WINNT calling conventions are used, the name must be
5060 * uppercase unless the subprogram has the STDCALL attribute.
5061 * All cref intrinsic are lowercase.
5062 */
5063 upcase_name(name);
5064 break;
5065 default:
5066 interr("get_llvm_name: bad stype for", sptr, ERR_Severe);
5067 strcpy(name, "b??");
5068 break;
5069 }
5070 return name;
5071 }
5072
5073 char *
get_string_constant(int sptr)5074 get_string_constant(int sptr)
5075 {
5076 char *name, *to, *from;
5077 int c, len, newlen;
5078
5079 if (STYPEG(sptr) == ST_CONST) {
5080 len = size_of(DTYPEG(sptr));
5081 newlen = 3;
5082 from = stb.n_base + CONVAL1G(sptr);
5083 while (len--) {
5084 c = *from++ & 0xff;
5085 if (c == '\"' || c == '\'' || c == '\\') {
5086 newlen += 2;
5087 } else if (c >= ' ' && c <= '~') {
5088 newlen++;
5089 } else if (c == '\n') {
5090 newlen += 2;
5091 } else {
5092 newlen += 4;
5093 }
5094 }
5095 name = (char *)getitem(LLVM_LONGTERM_AREA, (newlen + 3) * sizeof(char));
5096 *name = '\"';
5097 to = name + 1;
5098 from = stb.n_base + CONVAL1G(sptr);
5099 len = size_of(DTYPEG(sptr));
5100 while (len--) {
5101 c = *from++ & 0xff;
5102 if (c == '\"' || c == '\'' || c == '\\') {
5103 *to++ = '\\';
5104 *to++ = c;
5105 } else if (c >= ' ' && c <= '~') {
5106 *to++ = c;
5107 } else if (c == '\n') {
5108 *to++ = '\\';
5109 *to++ = 'n';
5110 } else {
5111 *to++ = '\\';
5112 sprintf(to, "%03o", c);
5113 to += 3;
5114 }
5115 }
5116 *to++ = '\"';
5117 }
5118 return name;
5119 }
5120
5121 static char *
write_ftn_type(LL_Type * ll_type,char * argptr,int byval)5122 write_ftn_type(LL_Type *ll_type, char *argptr, int byval)
5123 {
5124 // NB, the original code looks to be buggy
5125 switch (ll_type->data_type) {
5126 case LL_PTR:
5127 case LL_ARRAY:
5128 case LL_STRUCT:
5129 case LL_FUNCTION:
5130 case LL_VOID:
5131 sprintf(argptr, "i8*");
5132 break;
5133 case LL_I1:
5134 case LL_I8:
5135 case LL_I16:
5136 case LL_I24:
5137 case LL_I32:
5138 case LL_I40:
5139 case LL_I48:
5140 case LL_I56:
5141 case LL_I64:
5142 case LL_I128:
5143 case LL_I256:
5144 sprintf(argptr, "i%d", ll_type_int_bits(ll_type));
5145 break;
5146 default:
5147 sprintf(argptr, "%s", ll_type->str);
5148 break;
5149 }
5150 return argptr + strlen(argptr);
5151 }
5152
5153 static int
get_ag_size(int gblsym)5154 get_ag_size(int gblsym)
5155 {
5156 return gblsym ? AG_SIZE(gblsym) : 0;
5157 }
5158
5159 int
get_ag_argdtlist_length(int gblsym)5160 get_ag_argdtlist_length(int gblsym)
5161 {
5162 return gblsym ? AG_ARGDTLIST_LENGTH(gblsym) : 0;
5163 }
5164
5165 int
has_valid_ag_argdtlist(int gblsym)5166 has_valid_ag_argdtlist(int gblsym)
5167 {
5168 return gblsym ? AG_ARGDTLIST_IS_VALID(gblsym) : false;
5169 }
5170
5171 void
set_ag_argdtlist_is_valid(int gblsym)5172 set_ag_argdtlist_is_valid(int gblsym)
5173 {
5174 AG_ARGDTLIST_IS_VALID(gblsym) = true;
5175 }
5176
5177 char *
get_ag_typename(int gblsym)5178 get_ag_typename(int gblsym)
5179 {
5180 return AG_TYPENAME(gblsym);
5181 }
5182
5183 int
add_ag_typename(int gblsym,const char * typeName)5184 add_ag_typename(int gblsym, const char *typeName)
5185 {
5186 INT nmptr;
5187 nmptr = add_ag_name(typeName);
5188 AG_TYPENMPTR(gblsym) = nmptr;
5189 return AG_TYPENMPTR(gblsym);
5190 }
5191
5192 SPTR
get_intrin_ag(char * ag_name,DTYPE dtype)5193 get_intrin_ag(char *ag_name, DTYPE dtype)
5194 {
5195 SPTR gblsym = find_ag(ag_name);
5196
5197 if (gblsym)
5198 return gblsym;
5199
5200 /* Enter new symbol into the global symbol table */
5201 gblsym = make_gblsym(SPTR_NULL, ag_name);
5202 AG_SYMLK(gblsym) = ag_intrin;
5203 ag_intrin = gblsym;
5204 return gblsym;
5205 }
5206
5207 SPTR
get_dummy_ag(SPTR sptr)5208 get_dummy_ag(SPTR sptr)
5209 {
5210 SPTR gblsym;
5211 int nptr, hashval;
5212 char *ag_name;
5213
5214 ag_name = get_llvm_name(sptr);
5215 hashval = name_to_hash(ag_name, strlen(ag_name));
5216 gblsym = find_local_ag(ag_name);
5217
5218 if (gblsym)
5219 return gblsym;
5220
5221 /* Enter new symbol into the global symbol table */
5222 gblsym = (SPTR)agb_local.s_avl++;
5223 NEED(agb_local.s_avl + 1, agb_local.s_base, AG, agb_local.s_size,
5224 agb_local.s_size + 32);
5225
5226 nptr = add_ag_local_name(ag_name);
5227
5228 BZERO(&agb_local.s_base[gblsym], AG, 1);
5229 AGL_NMPTR(gblsym) = nptr;
5230 AGL_HASHLK(gblsym) = agb_local.hashtb[hashval];
5231 agb_local.hashtb[hashval] = gblsym;
5232 AGL_SYMLK(gblsym) = ag_local;
5233 ag_local = gblsym;
5234 if (MIDNUMG(sptr))
5235 AGL_DTYPE(gblsym) = DTYPEG(MIDNUMG(sptr));
5236 else
5237 AGL_DTYPE(gblsym) = DTYPEG(sptr);
5238 return gblsym;
5239 }
5240
5241 SPTR
get_llvm_funcptr_ag(SPTR sptr,const char * ag_name)5242 get_llvm_funcptr_ag(SPTR sptr, const char *ag_name)
5243 {
5244 SPTR gblsym = find_ag(ag_name);
5245
5246 if (gblsym)
5247 goto Found;
5248
5249 /* Enter new symbol into the global symbol table */
5250 gblsym = make_gblsym(sptr, ag_name);
5251 AG_SIZE(gblsym) = 0;
5252 AG_ISIFACE(gblsym) = 1;
5253 AG_DEVICE(gblsym) = 0;
5254 AG_SYMLK(gblsym) = ag_funcptr;
5255 ag_funcptr = gblsym;
5256
5257 Found:
5258 return gblsym;
5259 }
5260
5261 void
deleteag_llvm_argdtlist(int gblsym)5262 deleteag_llvm_argdtlist(int gblsym)
5263 {
5264 DTLIST *t = AG_ARGDTLIST(gblsym);
5265 DTLIST *pre;
5266 while (t) {
5267 pre = t;
5268 t = t->next;
5269 free(pre);
5270 }
5271 AG_ARGDTLIST(gblsym) = NULL;
5272 }
5273
5274 char *
get_argdtlist(int gblsym)5275 get_argdtlist(int gblsym)
5276 {
5277 if (gblsym)
5278 return (char *)AG_ARGDTLIST(gblsym);
5279 return NULL;
5280 }
5281
5282 char *
get_next_argdtlist(char * argdtlist)5283 get_next_argdtlist(char *argdtlist)
5284 {
5285 if (argdtlist)
5286 return (char *)(((DTLIST *)argdtlist)->next);
5287 return NULL;
5288 }
5289
5290 /* arg_num: Is zero based. arg_num zero is the initial element in the argdtlist
5291 * if it exists, NULL otherwise.
5292 */
5293 static DTLIST *
get_argdt(SPTR gblsym,int arg_num)5294 get_argdt(SPTR gblsym, int arg_num)
5295 {
5296 int i;
5297 DTLIST *arg;
5298
5299 for (i = 0, arg = AG_ARGDTLIST(gblsym); arg && (i < arg_num);
5300 ++i, arg = (DTLIST *)get_next_argdtlist((char *)arg)) {
5301 ; /* Iterate */
5302 }
5303
5304 return (arg && (i == arg_num)) ? arg : NULL;
5305 }
5306
5307 void
addag_llvm_argdtlist(SPTR gblsym,int arg_num,SPTR arg_sptr,LL_Type * lltype)5308 addag_llvm_argdtlist(SPTR gblsym, int arg_num, SPTR arg_sptr, LL_Type *lltype)
5309 {
5310 bool added;
5311 DTLIST *newt;
5312 DTLIST *t = AG_ARGDTLIST(gblsym);
5313 assert(arg_sptr, "Adding argument with unknown sptr", arg_sptr, ERR_Fatal);
5314
5315 /* If we have already added this arg, update the sptr */
5316 added = false;
5317 if (arg_num < AG_ARGDTLIST_LENGTH(gblsym)) {
5318 newt = (DTLIST *)get_argdt(gblsym, arg_num);
5319 assert(newt, "addag_llvm_argdtlist: Could not locate sptr", arg_sptr,
5320 ERR_Fatal);
5321 } else {
5322 NEW(newt, DTLIST, 1);
5323 memset(newt, 0, sizeof(DTLIST));
5324 added = true;
5325 }
5326
5327 /* Instantiate */
5328 newt->lltype = lltype;
5329 newt->byval = PASSBYVALG(arg_sptr);
5330 newt->sptr = arg_sptr;
5331
5332 /* Link if this is a new entry */
5333 if (added) {
5334 if (t == NULL) {
5335 AG_ARGDTLIST(gblsym) = newt;
5336 t = AG_ARGDTLIST(gblsym);
5337 t->tail = newt;
5338 } else {
5339 t->tail->next = newt;
5340 t->tail = newt;
5341 }
5342 ++AG_ARGDTLIST_LENGTH(gblsym);
5343 }
5344
5345 AG_ARGDTLIST_IS_VALID(gblsym) = true;
5346 }
5347
5348 LL_Type *
get_lltype_from_argdtlist(char * argdtlist)5349 get_lltype_from_argdtlist(char *argdtlist)
5350 {
5351 if (argdtlist)
5352 return ((DTLIST *)argdtlist)->lltype;
5353 return NULL;
5354 }
5355
5356 bool
get_byval_from_argdtlist(const char * argdtlist)5357 get_byval_from_argdtlist(const char *argdtlist)
5358 {
5359 if (argdtlist)
5360 return ((DTLIST *)argdtlist)->byval;
5361 return false; /* Fortran is pass by ref by default */
5362 }
5363
5364 SPTR
get_sptr_from_argdtlist(char * argdtlist)5365 get_sptr_from_argdtlist(char *argdtlist)
5366 {
5367 if (argdtlist)
5368 return ((DTLIST *)argdtlist)->sptr;
5369 return SPTR_NULL;
5370 }
5371
5372 bool
is_llvmag_entry(int gblsym)5373 is_llvmag_entry(int gblsym)
5374 {
5375 if (gblsym == 0)
5376 return false;
5377 return (AG_STYPE(gblsym) == ST_ENTRY);
5378 }
5379
5380 void
set_llvmag_entry(int gblsym)5381 set_llvmag_entry(int gblsym)
5382 {
5383 if (gblsym != 0) {
5384 AG_STYPE(gblsym) = ST_ENTRY;
5385 }
5386 }
5387
5388 bool
is_llvmag_iface(int gblsym)5389 is_llvmag_iface(int gblsym)
5390 {
5391 if (gblsym == 0)
5392 return false;
5393 return (AG_ISIFACE(gblsym) == 1);
5394 }
5395
5396 static void
write_module_as_subroutine(void)5397 write_module_as_subroutine(void)
5398 {
5399 DTYPE dtype = DTYPEG(gbl.currsub);
5400 const char *name = get_llvm_name(gbl.currsub);
5401
5402 init_output_file();
5403 FTN_HAS_INIT() = 1;
5404 print_token("define");
5405 print_space(1);
5406 write_type(make_lltype_from_dtype(dtype));
5407 print_space(1);
5408 print_token("@");
5409 print_token(name);
5410 print_token("() noinline");
5411 print_token(" { ");
5412 print_nl();
5413 print_line(".L.entry:");
5414
5415 /* print return statement */
5416 print_token("\t");
5417 print_token("ret");
5418 print_space(1);
5419 write_type(make_lltype_from_dtype(dtype));
5420 ll_proto_set_defined_body(name, true);
5421
5422 if (dtype == 0) {
5423 print_nl();
5424 print_token(" } ");
5425 print_nl();
5426 return;
5427 }
5428
5429 switch (dttypes[dtype]) {
5430 case _TY_INT:
5431 print_token(" 0");
5432 case _TY_REAL:
5433 print_token(" 0.0");
5434 case _TY_CMPLX:
5435 default:
5436 print_token(" undef");
5437 }
5438 print_nl();
5439 print_token(" } ");
5440 print_nl();
5441 }
5442
5443 int
find_funcptr_name(SPTR sptr)5444 find_funcptr_name(SPTR sptr)
5445 {
5446 int gblsym, hashval, len;
5447 char *np, *sp, sptrnm[MXIDLN];
5448
5449 /* Key */
5450 sprintf(sptrnm, "%s_%d", get_llvm_name(sptr), sptr); /* Local name */
5451 len = strlen(sptrnm);
5452 hashval = name_to_hash(sptrnm, len);
5453
5454 for (gblsym = fptr_local.hashtb[hashval]; gblsym;
5455 gblsym = FPTR_HASHLK(gblsym)) {
5456 np = sptrnm;
5457 sp = FPTR_NAME(gblsym);
5458 do {
5459 if (*np++ != *sp++)
5460 goto Continue;
5461 } while (*sp);
5462 if (np - sptrnm != len)
5463 continue;
5464 goto Found;
5465 Continue:
5466 if (gblsym == FPTR_HASHLK(gblsym))
5467 return 0;
5468 }
5469 return 0;
5470
5471 Found:
5472 return gblsym;
5473 }
5474
5475 SPTR
local_funcptr_sptr_to_gblsym(SPTR sptr)5476 local_funcptr_sptr_to_gblsym(SPTR sptr)
5477 {
5478 const int key = find_funcptr_name(sptr);
5479 assert(key,
5480 "local_funcptr_sptr_to_gblsym: No funcptr associated with sptr:", sptr,
5481 ERR_Fatal);
5482 return find_ag(FPTR_IFACENM(key));
5483 }
5484
5485 void
set_llvm_iface_oldname(int gblsym,char * nm)5486 set_llvm_iface_oldname(int gblsym, char *nm)
5487 {
5488 INT nmptr;
5489 nmptr = add_ag_name(nm);
5490 AG_OLDNMPTR(gblsym) = nmptr;
5491 }
5492
5493 /*
5494 * This function will store name that will be used to search in ag global table
5495 * Global name is: <ag_name>_%sptr
5496 * <ag_name> is supposedly in format of:
5497 * get_llvm_name(module/function)_$_<ifacename> With the assumption that
5498 * module/function would be unique. Reason why we use derived type name insteaf
5499 * of interface function name because interface is not available when we read
5500 * .ilm file.
5501 */
5502 void
llvm_funcptr_store(SPTR sptr,char * ag_name)5503 llvm_funcptr_store(SPTR sptr, char *ag_name)
5504 {
5505 int hashval, gblsym;
5506 char sptrnm[MXIDLN];
5507 INT nmptr;
5508
5509 gblsym = find_funcptr_name(sptr);
5510 if (gblsym > 0)
5511 return;
5512
5513 gblsym = fptr_local.s_avl++;
5514 NEED(fptr_local.s_avl + 1, fptr_local.s_base, FPTRSYM, fptr_local.s_size,
5515 fptr_local.s_size + 5);
5516
5517 BZERO(&fptr_local.s_base[gblsym], FPTRSYM, 1);
5518
5519 sprintf(sptrnm, "%s_%d", get_llvm_name(sptr), sptr);
5520 hashval = name_to_hash(sptrnm, strlen(sptrnm));
5521 fptr_local.hashtb[hashval] = gblsym;
5522 FPTR_HASHLK(gblsym) = fptr_local.hashtb[hashval];
5523 FPTR_SYMLK(gblsym) = ptr_local;
5524 nmptr = add_ag_fptr_name(sptrnm); /* fnptr_local key */
5525 FPTR_NMPTR(gblsym) = nmptr;
5526 nmptr = add_ag_fptr_name(ag_name); /* gblsym key */
5527 FPTR_IFACENMPTR(gblsym) = nmptr;
5528 ptr_local = gblsym;
5529 }
5530
5531 /* create struct which will be filled uplevel variables addresses. */
5532 DTYPE
make_uplevel_arg_struct(void)5533 make_uplevel_arg_struct(void)
5534 {
5535 SPTR gblsym;
5536 DTYPE dtype;
5537 int mem1, mem2, i;
5538 ISZ_T size, total_size;
5539 char name[MXIDLN], tname[MXIDLN + 8];
5540
5541 /* Instance and type name */
5542 sprintf(name, "_ul_%s_%d", get_llvm_name(gbl.currsub),
5543 gbl.currsub); /* Instance */
5544 sprintf(tname, "struct%s", name); /* Type */
5545 dtype = mk_struct_for_llvm_init(name, 16);
5546
5547 size = size_of(DT_ADDR);
5548 total_size = 0;
5549 mem1 = 0;
5550 mem2 = NOSYM;
5551
5552 if (gbl.internal == 1 && gbl.outlined && gbl.outersub)
5553 gblsym = find_ag(get_ag_searchnm(gbl.outersub));
5554 else
5555 gblsym = find_ag(get_ag_searchnm(gbl.currsub));
5556
5557 for (i = 0; i < AG_UPLEVEL_AVL(gblsym); i++) {
5558 if (AG_UPLEVEL_OLD(gblsym, i))
5559 mem2 = add_member_for_llvm(AG_UPLEVEL_NEW(gblsym, i), mem2, DT_ADDR,
5560 total_size);
5561 else {
5562 mem2 = add_member_for_llvm(AG_UPLEVEL_NEW(gblsym, i), mem2, DT_INT8,
5563 total_size);
5564 }
5565 AG_UPLEVEL_MEM(gblsym, i) = mem2;
5566 if (mem1 == 0)
5567 mem1 = mem2;
5568 total_size += size;
5569 DTySetAlgTySize(dtype, AG_UPLEVEL_AVL(gblsym) * size);
5570 }
5571 if (AG_UPLEVEL_AVL(gblsym) == 0) {
5572 /* make up some dump member otherwise the bridge will create opague
5573 * structure and llvm will complain */
5574 mem1 = add_member_for_llvm(DTyAlgTyTag(dtype), mem2, DT_ADDR, total_size);
5575 DTySetAlgTySize(dtype, size);
5576 }
5577
5578 /* fill member */
5579 DTySetAlgTyAlign(dtype, alignment(DT_ADDR));
5580 DTySetFst(dtype, mem1);
5581
5582 /* Create an lldef entry and add to struct_def list to be printed later */
5583 make_lltype_from_dtype(dtype);
5584 return dtype;
5585 }
5586
5587 void
add_uplevel_to_host(int * ptr,int cnt)5588 add_uplevel_to_host(int *ptr, int cnt)
5589 {
5590 int hsize;
5591 int havl;
5592 UPLEVEL_PAIR *hptr;
5593 UPLEVEL_PAIR *nptr;
5594 int total, i, j, gblsym;
5595
5596 gblsym = find_ag(get_llvm_name(gbl.outersub));
5597
5598 if (!gblsym)
5599 return;
5600
5601 hsize = AG_UPLEVEL_SZ(gblsym);
5602 havl = AG_UPLEVEL_AVL(gblsym);
5603 hptr = AG_UPLEVELPTR(gblsym);
5604
5605 /* need to filter out SC_STATIC and SC_CMBLK */
5606 if (havl == 0) {
5607 NEW(hptr, UPLEVEL_PAIR, cnt);
5608 memset(hptr, 0, sizeof(UPLEVEL_PAIR) * cnt);
5609 AG_UPLEVEL_SZ(gblsym) = cnt;
5610 for (i = 0; i < cnt; i++) {
5611 hptr[i].oldsptr = ptr[i];
5612 }
5613 AG_UPLEVEL_AVL(gblsym) = cnt;
5614 AG_UPLEVELPTR(gblsym) = hptr;
5615 } else {
5616 /* Reallocate ptr and make size = cnt+hsize so that we don't have
5617 * to do that often
5618 */
5619 NEW(nptr, UPLEVEL_PAIR, cnt + havl);
5620 memset(nptr, 0, sizeof(UPLEVEL_PAIR) * (cnt + havl));
5621 total = 0;
5622 for (i = 0, j = 0; i < cnt && j < hsize; total++) {
5623 if (hptr[j].oldsptr < *ptr) {
5624 nptr[total].oldsptr = hptr[j].oldsptr;
5625 j++;
5626 } else {
5627 nptr[total].oldsptr = *ptr;
5628 i++;
5629 ptr++;
5630 }
5631 }
5632 if (i < cnt) {
5633 do {
5634 nptr[total].oldsptr = *ptr;
5635 i++;
5636 total++;
5637 ptr++;
5638 } while (i < cnt);
5639
5640 } else if (j < hsize) {
5641 do {
5642 nptr[total].oldsptr = hptr[j].oldsptr;
5643 j++;
5644 total++;
5645 } while (j < hsize);
5646 }
5647 FREE(AG_UPLEVELPTR(gblsym));
5648 AG_UPLEVEL_AVL(gblsym) = total;
5649 AG_UPLEVEL_SZ(gblsym) = cnt + hsize;
5650 AG_UPLEVELPTR(gblsym) = nptr;
5651 }
5652 }
5653
5654 int
get_uplevel_address_size()5655 get_uplevel_address_size()
5656 {
5657 int gblsym;
5658 gblsym = find_ag(get_llvm_name(gbl.outersub));
5659 if (gblsym)
5660 return AG_UPLEVEL_AVL(gblsym);
5661 return 0;
5662 }
5663
5664 // FIXME: We are accessing a DT_PTR's element type (a DTYPE), but going to use
5665 // it as a TY_KIND.
5666 INLINE static TY_KIND
ThisIsAnAccessBug(DTYPE dtype)5667 ThisIsAnAccessBug(DTYPE dtype)
5668 {
5669 return (TY_KIND)DTySeqTyElement(dtype);
5670 }
5671
5672 /* If AG_UPLEVEL_OLD is 0, then it is len of character of the previous argument
5673 * and
5674 * it is passing by value - it is 32-bit in size for 32-bit and 64-bit for
5675 * 64-bit target.
5676 */
5677 void
_fixup_llvm_uplevel_symbol(void)5678 _fixup_llvm_uplevel_symbol(void)
5679 {
5680 int gblsym, outer_gblsym, i, j;
5681 SPTR sptr;
5682 DTYPE dtype;
5683 int cnt;
5684 int loopcnt;
5685 UPLEVEL_PAIR *ptr;
5686
5687 if (gbl.stbfil)
5688 return;
5689 if (gbl.internal > 1) {
5690 outer_gblsym = find_ag(get_llvm_name(gbl.outersub));
5691 gblsym = find_ag(get_llvm_name(gbl.currsub));
5692
5693 AG_UPLEVEL_AVL(gblsym) = AG_UPLEVEL_AVL(outer_gblsym);
5694 AG_UPLEVEL_SZ(gblsym) = AG_UPLEVEL_SZ(outer_gblsym);
5695 NEW(ptr, UPLEVEL_PAIR, AG_UPLEVEL_SZ(gblsym));
5696 memset(ptr, 0, sizeof(UPLEVEL_PAIR) * AG_UPLEVEL_SZ(gblsym));
5697
5698 for (i = 0; i < AG_UPLEVEL_AVL(gblsym); i++) {
5699 if (AG_UPLEVEL_OLD(outer_gblsym, i)) {
5700 ptr[i].oldsptr = AG_UPLEVEL_OLD(outer_gblsym, i);
5701 ptr[i].newsptr = llvm_get_uplevel_newsptr(ptr[i].oldsptr);
5702 sptr = ptr[i].newsptr;
5703 } else {
5704 /* makeup something */
5705 if (sptr && CLENG(sptr)) {
5706 ptr[i].newsptr = CLENG(sptr);
5707 } else {
5708 ptr[i].newsptr = gethost_dumlen(sptr, 0);
5709 if (SCG(ptr[i].newsptr) == SC_DUMMY) {
5710 PASSBYVALP(ptr[i].newsptr, 1);
5711 ADDRTKNP(ptr[i].newsptr, 1);
5712 CLENP(sptr, ptr[i].newsptr);
5713 } else {
5714 SCP(ptr[i].newsptr, SC_LOCAL);
5715 }
5716 }
5717 sptr = SPTR_NULL;
5718 }
5719 }
5720 AG_UPLEVELPTR(gblsym) = ptr;
5721 } else if (gbl.internal) {
5722 gblsym = find_ag(get_ag_searchnm(gbl.currsub));
5723 ptr = AG_UPLEVELPTR(gblsym);
5724 loopcnt = cnt = AG_UPLEVEL_AVL(gblsym);
5725 for (i = 0, j = 0; i < loopcnt; i++, j++) {
5726
5727 /* resolve symbol */
5728 sptr = llvm_get_uplevel_newsptr(ptr[i].oldsptr);
5729 dtype = DTYPEG(sptr);
5730
5731 /* ptr always points to the original list. We may need to
5732 * reallocate new memory for charlen.
5733 */
5734 if (DTYG(dtype) == TY_CHAR || DTYG(dtype) == TY_NCHAR ||
5735 (DTYG(dtype) == TY_PTR && (ThisIsAnAccessBug(dtype) == TY_CHAR)) ||
5736 (DTYG(dtype) == TY_PTR && (ThisIsAnAccessBug(dtype) == TY_NCHAR))) {
5737 /* add extra space to put char len */
5738 cnt++;
5739
5740 /* allocate new memory so that ptr is intact because we still need
5741 * to use info from ptr.
5742 */
5743 if (ptr == AG_UPLEVELPTR(gblsym)) {
5744 (AG_UPLEVEL_SZ(gblsym))++;
5745 NEW((AG_UPLEVELPTR(gblsym)), UPLEVEL_PAIR, AG_UPLEVEL_SZ(gblsym));
5746 memcpy(AG_UPLEVELPTR(gblsym), ptr, sizeof(UPLEVEL_PAIR) * loopcnt);
5747 } else {
5748 /* reallocate new memory */
5749 NEED(cnt + 1, AG_UPLEVELPTR(gblsym), UPLEVEL_PAIR,
5750 AG_UPLEVEL_SZ(gblsym), (AG_UPLEVEL_SZ(gblsym) + 2));
5751 }
5752 /* pair old symbol and resolved symbol in the list */
5753 AG_UPLEVEL_NEW(gblsym, j) = sptr;
5754 AG_UPLEVEL_OLD(gblsym, j) = ptr[i].oldsptr;
5755 j++;
5756
5757 /* place char len next to its sptr, set old symbol is 0 */
5758 AG_UPLEVEL_OLD(gblsym, j) = 0;
5759 if (CLENG(sptr)) {
5760 AG_UPLEVEL_NEW(gblsym, j) = CLENG(sptr);
5761 } else {
5762 AG_UPLEVEL_NEW(gblsym, j) = getdumlen();
5763 if (SCG(sptr) == SC_DUMMY) {
5764 PASSBYVALP(AG_UPLEVEL_NEW(gblsym, j), 1);
5765 CLENP(sptr, AG_UPLEVEL_NEW(gblsym, j));
5766 } else {
5767 SCP(AG_UPLEVEL_NEW(gblsym, j), SC_LOCAL);
5768 CLENP(sptr, AG_UPLEVEL_NEW(gblsym, j));
5769 }
5770 }
5771 } else {
5772 AG_UPLEVEL_NEW(gblsym, j) = sptr;
5773 AG_UPLEVEL_OLD(gblsym, j) = ptr[i].oldsptr;
5774 }
5775 }
5776 if (ptr != AG_UPLEVELPTR(gblsym)) {
5777 AG_UPLEVEL_AVL(gblsym) = cnt;
5778 FREE(ptr);
5779 ptr = NULL;
5780 }
5781 }
5782 }
5783
5784 static void
dump_uplevel_sptr(int gblsym)5785 dump_uplevel_sptr(int gblsym)
5786 {
5787 int i;
5788 for (i = 0; i < AG_UPLEVEL_AVL(gblsym); i++) {
5789 printf("oldsptr:%d newsptr:%d %s\n", AG_UPLEVEL_OLD(gblsym, i),
5790 AG_UPLEVEL_NEW(gblsym, i), get_llvm_name(AG_UPLEVEL_NEW(gblsym, i)));
5791 }
5792 }
5793
5794 static int uplevelcnt = 0;
5795 static int *upptr = NULL;
5796
5797 void
_add_llvm_uplevel_symbol(int oldsptr)5798 _add_llvm_uplevel_symbol(int oldsptr)
5799 {
5800 int size;
5801
5802 size = uplevelcnt;
5803 if (gbl.internal > 1) {
5804 if (uplevelcnt == 0) {
5805 NEW(upptr, int, 1);
5806 } else if (uplevelcnt + 1 >= size) {
5807 NEED(uplevelcnt + 1, upptr, int, size, size + 1);
5808 }
5809 upptr[uplevelcnt] = oldsptr;
5810 uplevelcnt++;
5811 }
5812 }
5813
5814 void
add_aguplevel_oldsptr(void)5815 add_aguplevel_oldsptr(void)
5816 {
5817 if (gbl.internal > 1 && upptr) {
5818 add_uplevel_to_host(upptr, uplevelcnt);
5819 FREE(upptr);
5820 upptr = NULL;
5821 uplevelcnt = 0;
5822 }
5823 }
5824
5825 void
load_uplevel_addresses(SPTR display_temp)5826 load_uplevel_addresses(SPTR display_temp)
5827 {
5828 int i, gblsym;
5829 DTYPE dtype;
5830 int ilix;
5831 SPTR sym;
5832 int dest_ilix;
5833 SPTR mem;
5834 int basenm, oldsym, ld_ilix;
5835
5836 if (gbl.internal == 1 && gbl.outlined && gbl.outersub)
5837 gblsym = find_ag(get_ag_searchnm(gbl.outersub));
5838 else
5839 gblsym = find_ag(get_ag_searchnm(gbl.currsub));
5840 if (!gblsym)
5841 return;
5842 dtype = DTYPEG(display_temp);
5843 if (DTY(dtype) != TY_STRUCT)
5844 dtype = make_uplevel_arg_struct();
5845 mem = DTyAlgTyMember(dtype);
5846 for (i = 0; i < AG_UPLEVEL_AVL(gblsym) && mem > NOSYM; i++) {
5847 sym = AG_UPLEVEL_NEW(gblsym, i);
5848 oldsym = AG_UPLEVEL_OLD(gblsym, i);
5849 ilix = mk_address(sym);
5850
5851 if (SCG(sym) == SC_PRIVATE) {
5852 /* host routine should not do anything with SC_PRIVATE
5853 * Outlined function should only load if variable is
5854 * local to its outlined function.
5855 */
5856 if (!gbl.outlined || (!is_llvm_local_private(sym))) {
5857 mem = SYMLKG(mem);
5858 continue;
5859 }
5860 } else if (gbl.outlined) {
5861 /* Don't load shared variable from host program if we are in outlined
5862 * function. Host program should already loaded the addresses.
5863 */
5864 mem = SYMLKG(mem);
5865 continue;
5866 }
5867
5868 dest_ilix = ad_acon(display_temp, ADDRESSG(mem));
5869
5870 if (oldsym == 0) {
5871 /* character len by value */
5872 basenm = addnme(NT_VAR, display_temp, 0, (INT)0);
5873 ld_ilix = ad3ili(IL_LDKR, ilix, addnme(NT_VAR, sym, 0, (INT)0), MSZ_I8);
5874 ilix = ad4ili(IL_STKR, ld_ilix, dest_ilix,
5875 addnme(NT_MEM, mem, basenm, (INT)0), MSZ_I8);
5876 goto cont;
5877 }
5878 if (SCG(sym) == SC_DUMMY && !PASSBYVALG(sym)) {
5879 ilix = mk_address(sym);
5880 }
5881
5882 basenm = addnme(NT_VAR, display_temp, 0, 0);
5883 ilix = ad3ili(IL_STA, ilix, dest_ilix, addnme(NT_MEM, mem, basenm, 0));
5884 cont:
5885 chk_block(ilix);
5886 mem = SYMLKG(mem);
5887 }
5888 }
5889
5890 int
get_sptr_uplevel_address(int sptr)5891 get_sptr_uplevel_address(int sptr)
5892 {
5893 int i, gblsym;
5894 gblsym = find_ag(get_ag_searchnm(gbl.currsub));
5895 for (i = 0; i < AG_UPLEVEL_AVL(gblsym); i++) {
5896 if (sptr == AG_UPLEVEL_NEW(gblsym, i)) {
5897 return AG_UPLEVEL_MEM(gblsym, i);
5898 }
5899 }
5900 return 0;
5901 }
5902
5903 int
ll_shallow_copy_uplevel(SPTR hostsptr,SPTR olsptr)5904 ll_shallow_copy_uplevel(SPTR hostsptr, SPTR olsptr)
5905 {
5906 /* copy information from the internal subprogram to the outlined program */
5907
5908 int hostgbl, olgbl;
5909 hostgbl = find_ag(get_llvm_name(hostsptr));
5910 olgbl = find_ag(get_llvm_name(olsptr));
5911
5912 AG_UPLEVELPTR(olgbl) = AG_UPLEVELPTR(hostgbl);
5913 AG_UPLEVEL_AVL(olgbl) = AG_UPLEVEL_AVL(hostgbl);
5914 return 0;
5915 }
5916
5917 char *
get_ag_name(int gblsym)5918 get_ag_name(int gblsym)
5919 {
5920 return AG_NAME(gblsym);
5921 }
5922
5923 void
assem_dinit(void)5924 assem_dinit(void)
5925 {
5926 /* intentionally empty */
5927 }
5928
5929