1 /*
2 * Copyright (c) 2011-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 llutil.c
20 Contains misc. utility routines for LLVM Code Generator
21 */
22
23 #include "llutil.h"
24 #include "dinitutl.h"
25 #include "dinit.h"
26 #include "ll_write.h"
27 #include "lldebug.h"
28 #include "dtypeutl.h"
29 #include "llassem.h"
30 #include "llassem_common.h"
31 #include "cgllvm.h"
32 #include "cgmain.h"
33 #include "x86.h"
34 #include "symfun.h"
35
36 typedef struct LLDEF {
37 DTYPE dtype;
38 LL_Type *ll_type;
39 int sptr;
40 int rank;
41 unsigned flags; /**< bitmask value. See LLDEF_Flags */
42 char *name;
43 int printed;
44 int addrspace;
45 OPERAND *values;
46 struct LLDEF *next;
47 } LLDEF;
48
49 #if DEBUG
50 static const char *ot_names[OT_LAST] = {
51 "OT_NONE", "OT_CONSTSPTR", "OT_VAR", "OT_TMP", "OT_LABEL",
52 "OT_CC", "OT_TARGET", "OT_CALL", "OT_CONSTVAL", "OT_UNDEF",
53 "OT_MDNODE", "OT_MEMBER", "OT_DEF", "OT_CONSTSTRING"};
54
55 const char *
get_ot_name(unsigned ot)56 get_ot_name(unsigned ot)
57 {
58 return (ot < OT_LAST) ? ot_names[ot] : "";
59 }
60 #endif
61
62 #define DBGTRACEIN(str) DBGXTRACEIN(DBGBIT(12, 0x20), 1, str)
63 #define DBGTRACEIN1(str, p1) DBGXTRACEIN1(DBGBIT(12, 0x20), 1, str, p1)
64 #define DBGTRACEIN2(str, p1, p2) DBGXTRACEIN2(DBGBIT(12, 0x20), 1, str, p1, p2)
65 #define DBGTRACEIN3(str, p1, p2, p3) \
66 DBGXTRACEIN3(DBGBIT(12, 0x20), 1, str, p1, p2, p3)
67 #define DBGTRACEIN4(str, p1, p2, p3, p4) \
68 DBGXTRACEIN4(DBGBIT(12, 0x20), 1, str, p1, p2, p3, p4)
69 #define DBGTRACEIN7(str, p1, p2, p3, p4, p5, p6, p7) \
70 DBGXTRACEIN7(DBGBIT(12, 0x20), 1, str, p1, p2, p3, p4, p5, p6, p7)
71
72 #define DBGTRACEOUT(str) DBGXTRACEOUT(DBGBIT(12, 0x20), 1, str)
73 #define DBGTRACEOUT1(str, p1) DBGXTRACEOUT1(DBGBIT(12, 0x20), 1, str, p1)
74 #define DBGTRACEOUT2(str, p1, p2) \
75 DBGXTRACEOUT2(DBGBIT(12, 0x20), 1, str, p1, p2)
76 #define DBGTRACEOUT3(str, p1, p2, p3) \
77 DBGXTRACEOUT3(DBGBIT(12, 0x20), 1, str, p1, p2, p3)
78 #define DBGTRACEOUT4(str, p1, p2, p3, p4) \
79 DBGXTRACEOUT4(DBGBIT(12, 0x20), 1, str, p1, p2, p3, p4)
80
81 #define DBGDUMPLLTYPE(str, llt) DBGXDUMPLLTYPE(DBGBIT(12, 0x20), 1, str, llt)
82
83 #define DBGTRACE(str) DBGXTRACE(DBGBIT(12, 0x20), 1, str)
84 #define DBGTRACE1(str, p1) DBGXTRACE1(DBGBIT(12, 0x20), 1, str, p1)
85 #define DBGTRACE2(str, p1, p2) DBGXTRACE2(DBGBIT(12, 0x20), 1, str, p1, p2)
86 #define DBGTRACE3(str, p1, p2, p3) \
87 DBGXTRACE3(DBGBIT(12, 0x20), 1, str, p1, p2, p3)
88 #define DBGTRACE4(str, p1, p2, p3, p4) \
89 DBGXTRACE4(DBGBIT(12, 0x20), 1, str, p1, p2, p3, p4)
90 #define DBGTRACE5(str, p1, p2, p3, p4, p5) \
91 DBGXTRACE5(DBGBIT(12, 0x20), 1, str, p1, p2, p3, p4, p5)
92
93 #define DT_VOID_NONE DT_NONE
94
95 #define DT_SBYTE DT_BINT
96
97 static char *llvm_cc_names[LLCC_LAST] = {
98 "none", "eq", "ne", "ugt", "uge", "ult", "ule", "sgt", "sge", "slt", "sle"};
99
100 static char *llvm_ccfp_names[LLCCF_LAST] = {
101 "none", "false", "oeq", "ogt", "oge", "olt", "ole", "one", "ord",
102 "ueq", "ugt", "uge", "ult", "ule", "une", "uno", "true"};
103
104 /* struct definition only used in CPU llvm backend
105 * accel takes a different approach */
106 static LLDEF *struct_def_list = NULL;
107 static LLDEF *llarray_def_list = NULL;
108 /* global variable declaration for GPU llvm backend
109 * CPU takes another approach, please check assemble_end in llassem_c.c. */
110 static LLDEF *gblvar_def_list = NULL;
111 /* not used yet */
112 static LLDEF *ftn_struct_def_list = NULL;
113
114 FTN_LLVM_ST ftn_llvm_st;
115 FILE *LLVMFIL = NULL;
116
117 static LL_ABI_Info *ll_abi_for_missing_prototype(LL_Module *module,
118 DTYPE return_dtype,
119 int func_sptr, int jsra_flags);
120 static bool LLTYPE_equiv(LL_Type *ty1, LL_Type *ty2);
121
122 static int is_gpu_module = false;
123
124 void
llvm_set_acc_module(void)125 llvm_set_acc_module(void)
126 {
127 is_gpu_module = true;
128 }
129
130 void
llvm_set_cpu_module(void)131 llvm_set_cpu_module(void)
132 {
133 is_gpu_module = false;
134 }
135
136 LL_Module*
llvm_get_current_module(void)137 llvm_get_current_module(void)
138 {
139 /* only TARGET_LLVM is defined; it is impossible to have both
140 * TARGET_ACCEL_LLVM and TARGET_LLVM undefined (Accel LLVM hasn't
141 * been enabled yet on ARM platform) */
142 return cpu_llvm_module;
143 }
144
145 void
llutil_struct_def_reset(void)146 llutil_struct_def_reset(void)
147 {
148 /* TODO: Please don't leak this */
149 struct_def_list = NULL;
150 }
151
152 void
llutil_gblvar_def_reset(void)153 llutil_gblvar_def_reset(void)
154 {
155 /* TODO: Please don't leak this either */
156 gblvar_def_list = NULL;
157 }
158
159 void
llutil_def_reset(void)160 llutil_def_reset(void)
161 {
162 llutil_struct_def_reset();
163 llutil_gblvar_def_reset();
164 }
165
166 void
llutil_dfile_init(void)167 llutil_dfile_init(void)
168 {
169 #if DEBUG
170 ll_dfile = gbl.dbgfil ? gbl.dbgfil : stderr;
171 #endif
172 }
173
174 static char *
llutil_alloc(INT size)175 llutil_alloc(INT size)
176 {
177 char *p = (char *)getitem(LLVM_LONGTERM_AREA, size);
178 memset(p, 0, size);
179 return p;
180 }
181
182 const char *
llutil_strdup(const char * str)183 llutil_strdup(const char *str)
184 {
185 char *p = llutil_alloc(strlen(str) + 1);
186 return strcpy(p, str);
187 }
188
189 /**
190 \brief allocate a new \c TMPS structure
191 */
192 TMPS *
make_tmps(void)193 make_tmps(void)
194 {
195 return (TMPS *)llutil_alloc(sizeof(TMPS));
196 }
197
198 void
ll_add_func_proto(int sptr,unsigned flags,int nargs,DTYPE * args)199 ll_add_func_proto(int sptr, unsigned flags, int nargs, DTYPE *args)
200 {
201 int i;
202 LL_Type *fty;
203 const DTYPE dtype = DTYPEG(sptr);
204 LL_Type **fsig = (LL_Type **)malloc(sizeof(LL_Type *) * (nargs + 1));
205 LL_ABI_Info *abi = ll_abi_alloc(llvm_get_current_module(), nargs);
206
207 ll_proto_init();
208 abi->arg[0].type = fsig[0] = make_lltype_from_dtype(dtype);
209 abi->arg[0].kind = LL_ARG_DIRECT;
210 for (i = 0; i < nargs; ++i) {
211 abi->arg[1 + i].type = fsig[1 + i] =
212 make_lltype_from_dtype(args[i]);
213 abi->arg[1 + i].kind = LL_ARG_DIRECT;
214 }
215 fty = ll_create_function_type(llvm_get_current_module(), fsig, nargs, false);
216 abi->is_fortran = true;
217 abi->is_iso_c = CFUNCG(sptr);
218 abi->is_pure = PUREG(sptr);
219 abi->fast_math = (flags & FAST_MATH_FLAG) != 0;
220 ll_proto_add(SYMNAME(sptr), abi);
221 free(fsig);
222 }
223
224 /**
225 \brief Compute load/store instruction flag bits corresponding to dtype.
226 \param dtype The DTYPE
227
228 The flags encode alignment in the \c LDST_LOGALIGN_MASK bits and volatile
229 types have the \c VOLATILE_FLAG bit set.
230
231 The returned flags are pre-shifted so they can be or'ed onto the instruction
232 flags.
233 */
234 LL_InstrListFlags
ldst_instr_flags_from_dtype(DTYPE dtype)235 ldst_instr_flags_from_dtype(DTYPE dtype)
236 {
237 unsigned align = alignment(dtype);
238 unsigned logalign = 0;
239 unsigned flags = 0;
240
241 /* Align is on the form 2^n-1. Compute n. */
242 while (align) {
243 logalign++;
244 align >>= 1;
245 }
246 flags |= logalign << LDST_LOGALIGN_SHIFT;
247
248 #ifdef MOD_VOLATILE
249 /* We should not be relying on MOD_VOLATILE to detect volatile loads
250 and stores in ILI. See routine ldst_instr_flags_from_dtype_and_nme
251 for right way to do it. When we're sure we have it right, the
252 code here should be deleted, and the description of the routine updateb. */
253 if (DTY(dtype) == TY_MOD && (DTY(dtype + 2) & MOD_VOLATILE))
254 flags |= VOLATILE_FLAG;
255 #endif
256
257 return (LL_InstrListFlags)flags;
258 }
259
260 /**
261 \brief Compute load/store instruction flag bits corresponding to dtype/nme.
262 \param dtype The DTYPE
263 \param nme The NME
264
265 The flags encode alignment in the \c LDST_LOGALIGN_MASK bits and the nme
266 NME_VOL
267 has the \c VOLATILE_FLAG bit set.
268
269 The returned flags are pre-shifted so they can be or'ed onto the instruction
270 flags.
271 */
272 LL_InstrListFlags
ldst_instr_flags_from_dtype_nme(DTYPE dtype,int nme)273 ldst_instr_flags_from_dtype_nme(DTYPE dtype, int nme)
274 {
275 unsigned flags = ldst_instr_flags_from_dtype(dtype);
276 if (nme == NME_VOL)
277 flags |= VOLATILE_FLAG;
278 return (LL_InstrListFlags)flags;
279 }
280
281 /*
282 * Convert a basic non-integer dtype to the corresponding LL_Type in module.
283 */
284 static LL_Type *
ll_convert_basic_dtype_with_addrspace(LL_Module * module,DTYPE dtype,int addrspace)285 ll_convert_basic_dtype_with_addrspace(LL_Module *module, DTYPE dtype, int addrspace)
286 {
287 enum LL_BaseDataType basetype = LL_NOTYPE;
288 LL_Type *type;
289
290 switch (DTY(dtype)) {
291 case TY_NONE:
292 basetype = LL_VOID;
293 break;
294 case TY_FLOAT:
295 case TY_CMPLX:
296 basetype = LL_FLOAT;
297 break;
298 case TY_DBLE:
299 case TY_DCMPLX:
300 case TY_QUAD:
301 /* TY_QUAD represents a long double on systems that map long
302 * double to IEEE64. */
303 basetype = LL_DOUBLE;
304 break;
305 case TY_FLOAT128:
306 case TY_CMPLX128:
307 /* TY_FLOAT128 represents a long double (or __float128) on
308 * systems where it maps to an IEEE128 quad precision. */
309 basetype = LL_FP128;
310 break;
311
312 default:
313 interr("ll_convert_basic_dtype: unknown data type", dtype, ERR_Fatal);
314 }
315
316 type = ll_create_basic_type(module, basetype, addrspace);
317
318 if (DT_ISCMPLX(dtype)) {
319 LL_Type *pair[2] = {type, type};
320 type = ll_create_anon_struct_type(module, pair, 2, /*FIXME*/ true, addrspace);
321 }
322
323 return type;
324 }
325
326 /*
327 * Convert a basic non-integer dtype to the corresponding LL_Type in module.
328 */
329 static LL_Type *
ll_convert_basic_dtype(LL_Module * module,DTYPE dtype)330 ll_convert_basic_dtype(LL_Module *module, DTYPE dtype)
331 {
332 return ll_convert_basic_dtype_with_addrspace(module, dtype, LL_AddrSp_Default);
333 }
334
335 #if defined(TARGET_LLVM_X8664)
336 /**
337 * \brief Convert a SIMD dtype to the corresponding LLVM type.
338 *
339 * Examples of SIMD dtypes are DT_128, DT_128F, DT_256, DT_512.
340 */
341 static LL_Type *
ll_convert_simd_dtype(LL_Module * module,DTYPE dtype)342 ll_convert_simd_dtype(LL_Module *module, DTYPE dtype)
343 {
344 enum LL_BaseDataType base;
345 unsigned num_elements;
346 LL_Type *base_type;
347 switch (dtype) {
348 case DT_128:
349 case DT_128I:
350 case DT_256:
351 case DT_256I:
352 case DT_512:
353 case DT_512I:
354 base = LL_I32;
355 break;
356 case DT_128F:
357 case DT_256F:
358 base = LL_FLOAT;
359 break;
360 case DT_128D:
361 case DT_256D:
362 base = LL_DOUBLE;
363 break;
364 default:
365 interr("ll_convert_simd_dtype: unhandled dtype", dtype, ERR_Fatal);
366 return NULL;
367 }
368 base_type = ll_create_basic_type(module, base, 0);
369 num_elements = size_of(dtype) / ll_type_bytes(base_type);
370 return ll_get_vector_type(base_type, num_elements);
371 }
372 #endif
373
374 /* Create a dummy function type from the return type. */
375 static LL_Type *
ll_convert_func_dtype(LL_Module * module,DTYPE dtype)376 ll_convert_func_dtype(LL_Module *module, DTYPE dtype)
377 {
378 LL_Type *ret_type = ll_convert_dtype(module, dtype);
379 return ll_create_function_type(module, &ret_type, 0, true);
380 }
381
382 /**
383 This routine is for use with fortran interfaces, specified by sptr
384 */
385 static LL_Type *
ll_convert_iface_sptr(LL_Module * module,SPTR iface_sptr)386 ll_convert_iface_sptr(LL_Module *module, SPTR iface_sptr)
387 {
388 int i, n_args;
389 SPTR gblsym;
390 LL_Type **args, *res;
391 LL_Type *llt;
392 char *dtl;
393
394 if (INMODULEG(iface_sptr))
395 gblsym = find_ag(get_llvm_name(iface_sptr));
396 else {
397 if (!(gblsym = find_ag(get_llvm_ifacenm(iface_sptr))))
398 gblsym = local_funcptr_sptr_to_gblsym(iface_sptr);
399 }
400 assert(gblsym, "ll_convert_iface_sptr: No gblsym found", iface_sptr, ERR_Fatal);
401
402 n_args = get_ag_argdtlist_length(gblsym);
403 args = (LL_Type**)calloc(1, (1 + n_args) * sizeof(LL_Type *));
404
405 /* Return type */
406 llt = get_ag_lltype(gblsym);
407 args[0] = ll_convert_dtype(module, DTYPEG(iface_sptr));
408
409 for (i = 1, dtl = (char *)get_argdtlist(gblsym); dtl;
410 dtl = (char *)get_next_argdtlist(dtl), ++i) {
411 llt = (LL_Type *)get_lltype_from_argdtlist(dtl);
412 args[i] = llt;
413 }
414
415 res = ll_create_function_type(module, args, n_args, false);
416 free(args);
417 return res;
418 }
419
420 /**
421 * \brief Layout the body of a struct type by scanning the member symbol table
422 * entries starting at member_sptr, and call ll_set_struct_body(struct_type).
423 *
424 * This code can layout both struct/union dtypes and common blocks.
425 *
426 * The provided struct_type should be created with
427 * ll_create_named_struct_type().
428 *
429 * Padding will be added to make the size of the new struct size_bytes, unless
430 * size_bytes is -1 which is ignored.
431 */
432 void
layout_struct_body(LL_Module * module,LL_Type * struct_type,int member_sptr,ISZ_T size_bytes)433 layout_struct_body(LL_Module *module, LL_Type *struct_type, int member_sptr,
434 ISZ_T size_bytes)
435 {
436 int sptr;
437 int packed = 0;
438 int padded = 0;
439 unsigned nmemb = 0;
440 LL_Type **memb_type;
441 unsigned *memb_off;
442 char *memb_pad, *cp;
443 ISZ_T bytes = 0;
444
445 /* Count the number of struct members so we can size the allocations. */
446 for (sptr = member_sptr; sptr > NOSYM; sptr = SYMLKG(sptr))
447 nmemb++;
448
449 /* Worst case struct we have to build has padding before every member + tail
450 * padding. */
451 memb_type = (LL_Type**)malloc(sizeof(LL_Type *) * (2 * nmemb + 1));
452 memb_off = (unsigned*)malloc(sizeof(unsigned) * (2 * nmemb + 2));
453 memb_pad = (char*)calloc((2 * nmemb) + 1, 1);
454 nmemb = 0;
455
456 /* Revisit struct members while keeping track if the built struct size so
457 * far in 'bytes'. Only add a typed member if:
458 *
459 * - Member is aligned according to its datatype. This way we can avoid LLVM
460 * packed structs.
461 * - Member doesn't overlap the struct built so far. This would happen for
462 * union members and bitfields.
463 * - Member doesn't extend beyond the end of the struct.
464 *
465 * If we choose to not add a member, it will be part of the padding added
466 * after it.
467 */
468 for (sptr = member_sptr; sptr > NOSYM; sptr = SYMLKG(sptr)) {
469 unsigned cur_size = 0;
470 LL_Type *cur_type = NULL;
471
472 #ifdef PACKG
473 packed = packed || PACKG(sptr);
474 #endif
475
476 if (ADDRESSG(sptr) < bytes)
477 continue;
478
479 if (size_bytes != -1 && ADDRESSG(sptr) >= size_bytes)
480 continue;
481
482 if ((!packed) && (alignment(DTYPEG(sptr)) & ADDRESSG(sptr)))
483 continue;
484
485 #ifdef POINTERG
486 if (POINTERG(sptr)) {
487 cur_type = ll_convert_dtype(module, DDTG(DTYPEG(sptr)));
488 cur_type = ll_get_pointer_type(cur_type);
489 cur_size = ll_type_bytes(cur_type);
490 }
491 #endif /* POINTERG */
492
493 /* Otherwise use the normal dtype. */
494 if (!cur_type) {
495 cur_type = ll_convert_dtype(module, DTYPEG(sptr));
496 if (DDTG(DTYPEG(sptr)) == DT_ASSCHAR ||
497 DDTG(DTYPEG(sptr)) == DT_DEFERCHAR)
498 cur_size = ZSIZEOF(DT_ADDR);
499 else if (DTY(DTYPEG(sptr)) == TY_ARRAY && extent_of(DTYPEG(sptr)) == 0)
500 cur_size = 0;
501 else
502 cur_size = ZSIZEOF(DTYPEG(sptr));
503 }
504
505 /* Skip empty struct array members. */
506 if (!cur_size)
507 continue;
508
509 if (size_bytes != -1 && ADDRESSG(sptr) + cur_size > size_bytes)
510 continue;
511
512 /* Add padding before. Use an [n x i8] array if needed. */
513 if (ADDRESSG(sptr) > bytes) {
514 unsigned pad_size = ADDRESSG(sptr) - bytes;
515 LL_Type *pad_type = ll_create_basic_type(module, LL_I8, 0);
516 if (pad_size > 1)
517 pad_type = ll_get_array_type(pad_type, pad_size, 0);
518
519 memb_off[nmemb] = bytes;
520 memb_pad[nmemb] = padded = 1;
521 memb_type[nmemb++] = pad_type;
522 bytes += pad_size;
523 }
524
525 /* Add current member. */
526 memb_off[nmemb] = bytes;
527 memb_type[nmemb++] = cur_type;
528 bytes += cur_size;
529 }
530
531 /* Finally add tail padding. */
532 if (size_bytes > bytes) {
533 unsigned pad_size = size_bytes - bytes;
534 LL_Type *pad_type = ll_create_basic_type(module, LL_I8, 0);
535 if (pad_size > 1)
536 pad_type = ll_get_array_type(pad_type, pad_size, 0);
537 memb_off[nmemb] = bytes;
538 memb_pad[nmemb] = padded = 1;
539 memb_type[nmemb++] = pad_type;
540 bytes += pad_size;
541 }
542
543 assert(size_bytes == -1 || bytes == size_bytes, "Inconsistent size", bytes,
544 ERR_Fatal);
545 memb_off[nmemb] = size_bytes;
546 cp = padded ? memb_pad : NULL;
547 ll_set_struct_body(struct_type, memb_type, memb_off, cp, nmemb, packed);
548 free(memb_pad);
549 free(memb_type);
550 free(memb_off);
551 }
552
553 /*
554 * Convert a TY_STRUCT or TY_UNION dtype to an LLVM LL_STRUCT type.
555 *
556 * LLVM can't represent full C structs and unions; it has no bitfield concept
557 * or union support. We build an LLVM struct type that has matching members
558 * where possible, and i8 padding otherwise.
559 */
560 static LL_Type *
ll_convert_struct_dtype(LL_Module * module,DTYPE dtype)561 ll_convert_struct_dtype(LL_Module *module, DTYPE dtype)
562 {
563 /* TY_STRUCT sptr size tag align ict */
564 const SPTR member_sptr = DTyAlgTyMember(dtype);
565 const unsigned size_bytes = DTyAlgTySize(dtype);
566 const SPTR tag_sptr = DTyAlgTyTag(dtype);
567 const char *prefix = DTY(dtype) == TY_UNION ? "union" : "struct";
568 LL_Type *old_type;
569 LL_Type *new_type;
570
571 /* Was this struct converted previously? Named structs are indexed by dtype.
572 */
573 old_type = ll_get_struct_type(module, dtype, false);
574 if (old_type)
575 return old_type;
576
577 /* No, this has not been converted yet, so we need to create a new named
578 * struct.
579 *
580 * Create an empty struct right away and fill in the body later. This is
581 * necessary because we recursively call ll_convert_dtype() while
582 * converting the struct body. Once the empty struct is created, the
583 * recursion will be terminated by ll_get_struct_type() above.
584 *
585 * The name picked for the type is not important,
586 * ll_create_named_struct_type() will ensure a unique type name.
587 */
588 if (tag_sptr)
589 new_type = ll_create_named_struct_type(module, dtype, true, "%s.%s", prefix,
590 SYMNAME(tag_sptr));
591 else
592 new_type = ll_create_named_struct_type(module, dtype, true, "a%s.dt%d",
593 prefix, dtype);
594
595 /* Make sure that the old-style struct definition exists. For now this is
596 * how struct definitions are printed. The mutual recursion between these
597 * functions is terminated by the ll_get_struct_type() call above returning
598 * non-NULL.
599 *
600 * This is only required for the CPU code generator. The GPU code
601 * generators use ll_write_user_structs(), so don't depend on
602 * process_dtype_struct().
603 */
604 if (module == cpu_llvm_module)
605 process_dtype_struct(dtype);
606
607 layout_struct_body(module, new_type, member_sptr, size_bytes);
608
609 return new_type;
610 }
611
612 /**
613 * \brief Convert a Fortran-style \c TY_ARRAY dtype to an LLVM array.
614 *
615 * This routine obtains the length information via the array descriptor.
616 */
617 LL_Type *
ll_convert_array_dtype(LL_Module * module,DTYPE dtype,int addrspace)618 ll_convert_array_dtype(LL_Module *module, DTYPE dtype, int addrspace)
619 {
620 int len;
621 ADSC *ad;
622 LL_Type *type = NULL;
623
624 if (DTY(dtype) == TY_ARRAY) {
625 DTYPE ddtype = DTySeqTyElement(dtype);
626 ADSC *ad = AD_DPTR(dtype);
627 int numdim = AD_NUMDIM(ad);
628 int numelm = AD_NUMELM(ad);
629
630 type = ll_convert_dtype(module, ddtype);
631
632 if (numdim >= 1 && numdim <= 7) {
633 /* Create nested LLVM arrays. */
634 int i;
635 for (i = 0; i < numdim; i++)
636 type = ll_get_array_type(type, get_dim_size(ad, i), addrspace);
637 return type;
638 }
639
640 if (numelm) {
641 assert((STYPEG(numelm) == ST_CONST) || (STYPEG(numelm) == ST_VAR),
642 "Array length is neither a constant nor variable", numelm, ERR_unused);
643 len = (STYPEG(numelm) == ST_CONST) ? get_bnd_cval(numelm) : 0;
644 } else {
645 len = 0;
646 }
647 } else if (DTY(dtype) == TY_CHAR) {
648 len = DTyCharLength(dtype);
649 if (len == 0)
650 len = 1;
651 type = ll_convert_dtype(module, DT_BINT);
652 } else if (DTY(dtype) == TY_NCHAR) {
653 len = DTyCharLength(dtype);
654 if (len == 0)
655 len = 1;
656 type = ll_convert_dtype(module, DT_SINT);
657 } else
658 interr("ll_convert_array_dtype: unhandled dtype", dtype, ERR_Fatal);
659
660 /* The array dimension is a symbol table reference.
661 * Use [0 x t] for variable-sized array types.
662 */
663 return ll_get_array_type(type, len, 0);
664 }
665
666
667
668 static LL_Type *
convert_dtype(LL_Module * module,DTYPE dtype,int addrspace)669 convert_dtype(LL_Module *module, DTYPE dtype, int addrspace)
670 {
671 LL_Type *subtype;
672 DTYPE dt;
673
674 switch (DTY(dtype)) {
675
676 case TY_NONE:
677 case TY_ANY:
678 case TY_NUMERIC:
679 return ll_create_basic_type(module, LL_VOID, addrspace);
680
681 case TY_PTR:
682 dt = DTySeqTyElement(dtype);
683 if (DTY(dt) == TY_PROC)
684 subtype = ll_create_basic_type(module, LL_I8, addrspace);
685 else
686 subtype = ll_convert_dtype_with_addrspace(module, DTySeqTyElement(dtype), addrspace);
687 /* LLVM doesn't have void pointers. Use i8* instead. */
688 if (subtype->data_type == LL_VOID)
689 subtype = ll_create_basic_type(module, LL_I8, addrspace);
690 return ll_get_pointer_type(subtype);
691
692 case TY_CHAR:
693 case TY_NCHAR:
694 case TY_ARRAY:
695 return ll_convert_array_dtype(module, dtype, addrspace);
696
697 case TY_STRUCT:
698 case TY_UNION:
699 return ll_convert_struct_dtype(module, dtype);
700
701 case TY_VECT:
702 subtype = ll_convert_dtype_with_addrspace(module, DTySeqTyElement(dtype), addrspace);
703 return ll_get_vector_type(subtype, DTyVecLength(dtype));
704
705 #if defined(TARGET_LLVM_X8664)
706 case TY_128:
707 case TY_256:
708 case TY_512:
709 return ll_convert_simd_dtype(module, dtype);
710 #endif
711 }
712 if (DT_ISINT(dtype))
713 return ll_create_int_type_with_addrspace(module, 8 * size_of(dtype), addrspace);
714
715 if (DT_ISBASIC(dtype))
716 return ll_convert_basic_dtype_with_addrspace(module, dtype, addrspace);
717
718 interr("ll_convert_dtype: unhandled dtype", dtype, ERR_Fatal);
719 return NULL;
720 }
721
722 /**
723 * \brief Convert any kind of dtype to an LLVM type.
724 */
725 LL_Type *
ll_convert_dtype(LL_Module * module,DTYPE dtype)726 ll_convert_dtype(LL_Module *module, DTYPE dtype)
727 {
728 return convert_dtype(module, dtype, 0);
729 }
730
731 /**
732 * \brief Convert any kind of dtype to an LLVM type with address space.
733 */
734 LL_Type *
ll_convert_dtype_with_addrspace(LL_Module * module,DTYPE dtype,int addrspace)735 ll_convert_dtype_with_addrspace(LL_Module *module, DTYPE dtype, int addrspace)
736 {
737 return convert_dtype(module, dtype, addrspace);
738 }
739
740 bool
llis_integral_kind(DTYPE dtype)741 llis_integral_kind(DTYPE dtype)
742 {
743 switch (DTY(dtype)) {
744 #if defined(PGC) || defined(PG0CL)
745 case TY_LONG:
746 case TY_ULONG:
747 case TY_SCHAR:
748 case TY_UCHAR:
749 case TY_ENUM:
750 case TY_BOOL:
751 #endif
752 case TY_WORD:
753 case TY_DWORD:
754 case TY_HOLL:
755 case TY_BINT:
756 case TY_UBINT:
757 case TY_INT128:
758 case TY_UINT128:
759 case TY_LOG:
760 case TY_SLOG:
761 case TY_BLOG:
762 case TY_LOG8:
763 case TY_INT:
764 case TY_UINT:
765 case TY_SINT:
766 case TY_USINT:
767 case TY_INT8:
768 case TY_UINT8:
769 return 1;
770 default:
771 break;
772 }
773 return 0;
774 }
775
776 bool
llis_pointer_kind(DTYPE dtype)777 llis_pointer_kind(DTYPE dtype)
778 {
779 return (DTY(dtype) == TY_PTR);
780 }
781
782 bool
llis_array_kind(DTYPE dtype)783 llis_array_kind(DTYPE dtype)
784 {
785 switch (DTY(dtype)) {
786 case TY_CHAR:
787 case TY_NCHAR:
788 case TY_ARRAY:
789 return true;
790 default:
791 break;
792 }
793 return false;
794 }
795
796 bool
llis_dummied_arg(SPTR sptr)797 llis_dummied_arg(SPTR sptr)
798 {
799 return sptr && (SCG(sptr) == SC_DUMMY) &&
800 (llis_pointer_kind(DTYPEG(sptr)) || llis_array_kind(DTYPEG(sptr)));
801 }
802
803 bool
llis_vector_kind(DTYPE dtype)804 llis_vector_kind(DTYPE dtype)
805 {
806 return (DTY(dtype) == TY_VECT);
807 }
808
809 bool
llis_struct_kind(DTYPE dtype)810 llis_struct_kind(DTYPE dtype)
811 {
812 switch (DTY(dtype)) {
813 case TY_CMPLX128:
814 case TY_CMPLX:
815 case TY_DCMPLX:
816 case TY_STRUCT:
817 case TY_UNION:
818 return true;
819 default:
820 break;
821 }
822 return false;
823 }
824
825 bool
llis_function_kind(DTYPE dtype)826 llis_function_kind(DTYPE dtype)
827 {
828 switch (DTY(dtype)) {
829 case TY_PROC:
830 return true;
831 default:
832 break;
833 }
834 return false;
835 }
836
837 int
is_struct_kind(DTYPE dtype,bool check_return,bool return_vector_as_struct)838 is_struct_kind(DTYPE dtype, bool check_return,
839 bool return_vector_as_struct)
840 {
841 switch (DTY(dtype)) {
842 case TY_STRUCT:
843 case TY_UNION:
844 return true;
845 case TY_VECT:
846 return return_vector_as_struct;
847 case TY_CMPLX:
848 return check_return;
849 case TY_DCMPLX:
850 case TY_CMPLX128:
851 return true;
852 }
853 return false;
854 }
855
856 LL_Type *
make_ptr_lltype(LL_Type * pts_to)857 make_ptr_lltype(LL_Type *pts_to)
858 {
859 return ll_get_pointer_type(pts_to);
860 }
861
862 LL_Type *
make_int_lltype(unsigned bits)863 make_int_lltype(unsigned bits)
864 {
865 return ll_create_int_type(llvm_get_current_module(), bits);
866 }
867
868 LL_Type *
make_void_lltype(void)869 make_void_lltype(void)
870 {
871 return ll_create_basic_type(llvm_get_current_module(), LL_VOID, LL_AddrSp_Default);
872 }
873
874 LL_Type *
make_vector_lltype(int size,LL_Type * pts_to)875 make_vector_lltype(int size, LL_Type *pts_to)
876 {
877 return ll_get_vector_type(pts_to, size);
878 }
879
880 LL_Type *
make_array_lltype(int size,LL_Type * pts_to)881 make_array_lltype(int size, LL_Type *pts_to)
882 {
883 return ll_get_array_type(pts_to, size, LL_AddrSp_Default);
884 }
885
886 int
get_dim_size(ADSC * ad,int dim)887 get_dim_size(ADSC *ad, int dim)
888 {
889 int dim_size = 0;
890 const int lower_bnd = AD_LWBD(ad, dim);
891 const int upper_bnd = AD_UPBD(ad, dim);
892
893 if (STYPEG(upper_bnd) == ST_CONST && STYPEG(lower_bnd) == ST_CONST)
894 dim_size = (int)(ad_val_of(upper_bnd) - ad_val_of(lower_bnd) + 1);
895 return dim_size;
896 }
897
898 static LL_Type *
lltype_from_dtype(DTYPE dtype,int addrspace)899 lltype_from_dtype(DTYPE dtype, int addrspace)
900 {
901 DTYPE sdtype;
902
903 sdtype = dtype;
904 return ll_convert_dtype_with_addrspace(llvm_get_current_module(), sdtype, addrspace);
905 }
906
907 LL_Type *
make_lltype_from_dtype(DTYPE dtype)908 make_lltype_from_dtype(DTYPE dtype)
909 {
910 return lltype_from_dtype(dtype, 0);
911 }
912
913 LL_Type *
make_lltype_from_dtype_with_addrspace(DTYPE dtype,int addrspace)914 make_lltype_from_dtype_with_addrspace(DTYPE dtype, int addrspace)
915 {
916 return lltype_from_dtype(dtype, addrspace);
917 }
918
919 DTYPE
generic_dummy_dtype(void)920 generic_dummy_dtype(void)
921 {
922 return TARGET_PTRSIZE == 8 ? DT_UINT8 : DT_UINT;
923 }
924
925 /* This was originally just i8*, but to avoid only loading 1 byte,
926 * we now represent dummys as i32* or i64* in fortran.
927 */
928 LL_Type *
make_generic_dummy_lltype(void)929 make_generic_dummy_lltype(void)
930 {
931 return make_ptr_lltype(make_lltype_from_dtype(generic_dummy_dtype()));
932 }
933
934 /* Until we have prototype available, we are making assumption here:
935 *
936 * 1) This function is called for module subroutine calling its own module
937 * subroutine
938 * 2) Sectional arguments may not be handled correctly.
939 * 3) Assumed-size/adjustable/defered char arguments if passing as arguments
940 * to another contained subroutine in the same module - will need to be
941 * the same type?
942 */
943
944 LL_Type *
make_lltype_from_arg(int arg)945 make_lltype_from_arg(int arg)
946 {
947 assert(0, "", 0, ERR_Fatal);
948 return 0;
949 } /* make_lltype_from_dtype */
950
951 /* create expected type from actual arguments - all arguments are char*(or i8*)
952 * else if pass by value - pass actual type.
953 */
954
955 LL_Type *
make_lltype_from_arg_noproto(int arg)956 make_lltype_from_arg_noproto(int arg)
957 {
958 DTYPE sdtype, atype;
959 int anum;
960 DTYPE dtype;
961 LL_Type *llt, *llt2;
962 int argili;
963
964 DBGTRACEIN2(" dtype %d = %s", sdtype, stb.tynames[DTY(sdtype)])
965
966 argili = ILI_OPND(arg, 1);
967 dtype = ILI_DTyOPND(arg, 3);
968 if (IL_RES(ILI_OPC(argili)) == ILIA_AR) { /* by reference */
969 if (DTY(dtype) != TY_ARRAY && DTY(dtype) != TY_PTR && DTY(dtype) != TY_ANY)
970 llt2 = make_lltype_from_dtype(dtype);
971 else
972 llt2 = make_lltype_from_dtype(DT_BINT);
973 llt = make_ptr_lltype(llt2);
974
975 } else {
976 llt = make_lltype_from_dtype(dtype);
977 }
978
979 DBGTRACEOUT2(" return type %p: %s\n", llt, llt->str);
980
981 return llt;
982 } /* make_lltype_from_dtype */
983
984 /**
985 \brief Get a function argument dtype from an IL_ARG* instruction opcode.
986 */
987 DTYPE
get_dtype_from_arg_opc(ILI_OP opc)988 get_dtype_from_arg_opc(ILI_OP opc)
989 {
990 switch (opc) {
991 case IL_ARGIR:
992 case IL_DAIR:
993 return DT_INT;
994 case IL_ARGSP:
995 case IL_DASP:
996 return DT_FLOAT;
997 case IL_ARGDP:
998 case IL_DADP:
999 return DT_DBLE;
1000 case IL_ARGAR:
1001 case IL_DAAR:
1002 return DT_CPTR;
1003 case IL_ARGKR:
1004 case IL_DAKR:
1005 return DT_INT8;
1006 #ifdef LONG_DOUBLE_FLOAT128
1007 case IL_FLOAT128ARG:
1008 return DT_FLOAT128;
1009 #endif
1010 default:
1011 return DT_NONE;
1012 }
1013 } /* get_dtype_from_arg_opc */
1014
1015 /**
1016 \brief Convert a <tt>TY_</tt><i>*</i> to a <tt>DT_</tt><i>*</i> value
1017
1018 If the TY type isn't a basic type, returns <tt>DT_NONE</tt>.
1019 */
1020 DTYPE
get_dtype_from_tytype(TY_KIND ty)1021 get_dtype_from_tytype(TY_KIND ty)
1022 {
1023 assert((ty >= TY_NONE) && (ty < TY_MAX), "DTY not in range", ty, ERR_Fatal);
1024 switch (ty) {
1025 case TY_WORD:
1026 return DT_WORD;
1027 case TY_DWORD:
1028 return DT_DWORD;
1029 case TY_HOLL:
1030 return DT_HOLL;
1031 case TY_BINT:
1032 return DT_BINT;
1033 case TY_INT:
1034 return DT_INT;
1035 case TY_UINT:
1036 return DT_UINT;
1037 case TY_SINT:
1038 return DT_SINT;
1039 case TY_USINT:
1040 return DT_USINT;
1041 #ifdef PGF
1042 case TY_CHAR:
1043 return DT_CHAR;
1044 #endif
1045 case TY_NCHAR:
1046 return DT_NCHAR;
1047 #ifdef PGF
1048 case TY_REAL:
1049 return DT_REAL;
1050 #endif
1051 case TY_DBLE:
1052 return DT_DBLE;
1053 case TY_QUAD:
1054 return DT_QUAD;
1055 case TY_CMPLX:
1056 return DT_CMPLX;
1057 case TY_DCMPLX:
1058 return DT_DCMPLX;
1059 case TY_INT8:
1060 return DT_INT8;
1061 case TY_UINT8:
1062 return DT_UINT8;
1063 case TY_128:
1064 return DT_128;
1065 case TY_256:
1066 return DT_256;
1067 case TY_512:
1068 return DT_512;
1069 case TY_INT128:
1070 return DT_INT128;
1071 case TY_UINT128:
1072 return DT_UINT128;
1073 case TY_FLOAT128:
1074 return DT_FLOAT128;
1075 case TY_CMPLX128:
1076 return DT_CMPLX128;
1077 case TY_PTR:
1078 return DT_CPTR;
1079 case TY_BLOG:
1080 return DT_BLOG;
1081 case TY_SLOG:
1082 return DT_SLOG;
1083 case TY_LOG:
1084 return DT_LOG;
1085 case TY_LOG8:
1086 return DT_LOG8;
1087 default:
1088 return DT_NONE;
1089 }
1090 }
1091
1092 /**
1093 \brief Get the function return type coprresponding to an IL_DFR* opcode.
1094 */
1095 DTYPE
dtype_from_return_type(ILI_OP ret_opc)1096 dtype_from_return_type(ILI_OP ret_opc)
1097 {
1098 switch (ret_opc) {
1099 case IL_DFRAR:
1100 return DT_CPTR;
1101 #ifdef IL_DFRSPX87
1102 case IL_DFRSPX87:
1103 #endif
1104 case IL_DFRSP:
1105 return DT_FLOAT;
1106 case IL_DFR128:
1107 return DT_128;
1108 case IL_DFR256:
1109 return DT_256;
1110 #ifdef IL_DFRDPX87
1111 case IL_DFRDPX87:
1112 #endif
1113 case IL_DFRDP:
1114 return DT_DBLE;
1115 case IL_DFRIR:
1116 return DT_INT;
1117 case IL_DFRKR:
1118 return DT_INT8;
1119 case IL_DFRCS:
1120 return DT_CMPLX;
1121 #ifdef LONG_DOUBLE_FLOAT128
1122 case IL_FLOAT128RESULT:
1123 return DT_FLOAT128;
1124 #endif
1125 default:
1126 interr("dtype_from_return_type(), bad return opc", ret_opc, ERR_Fatal);
1127 }
1128 return DT_NONE;
1129 }
1130
1131 LL_Type *
make_lltype_from_iface(SPTR sptr)1132 make_lltype_from_iface(SPTR sptr)
1133 {
1134 return ll_convert_iface_sptr(llvm_get_current_module(), sptr);
1135 }
1136
1137 /* Convenience macro (aids readability for is_function predicate) */
1138 #define IS_FTN_PROC_PTR(sptr) \
1139 ((DTY(DTYPEG(sptr)) == TY_PTR) && \
1140 (DTY(DTySeqTyElement(DTYPEG(sptr))) == TY_PROC))
1141
1142 bool
is_function(int sptr)1143 is_function(int sptr)
1144 {
1145 const int stype = STYPEG(sptr);
1146 return (stype == ST_ENTRY || stype == ST_PROC || IS_FTN_PROC_PTR(sptr));
1147 }
1148
1149 static void
add_def(LLDEF * new_def,LLDEF ** def_list)1150 add_def(LLDEF *new_def, LLDEF **def_list)
1151 {
1152 new_def->next = *def_list;
1153 *def_list = new_def;
1154 if ((new_def->ll_type == NULL) && (new_def->dtype > 0))
1155 new_def->ll_type = make_lltype_from_dtype(new_def->dtype);
1156 }
1157
1158 /**
1159 \brief Make an \c LL_Type from symbol \p sptr
1160 \param sptr a symbol
1161 */
1162 LL_Type *
make_lltype_from_sptr(SPTR sptr)1163 make_lltype_from_sptr(SPTR sptr)
1164 {
1165 DTYPE sdtype, atype;
1166 int anum, midtype;
1167 SPTR iface;
1168 int len;
1169 int stype = 0, sc = 0;
1170 LL_Type *llt, *llt2;
1171 int addrspace = LL_AddrSp_Default;
1172 ADSC *ad;
1173 INT d;
1174 int midnum = 0;
1175
1176 if (sptr) {
1177 sdtype = DTYPEG(sptr);
1178 stype = STYPEG(sptr);
1179 sc = SCG(sptr);
1180 }
1181 #if defined(HOLLG)
1182 if ((CUDAG(gbl.currsub) & (CUDA_GLOBAL | CUDA_DEVICE)) &&
1183 (SCG(sptr) == SC_DUMMY)) {
1184 /* do nothing */
1185 } else if (HOLLG(sptr) && STYPEG(sptr) == ST_CONST) {
1186 return make_ptr_lltype(get_ftn_hollerith_type(sptr));
1187 } else
1188 #endif
1189 if (SCG(sptr) == SC_CMBLK) {
1190 return make_ptr_lltype(get_ftn_cmblk_lltype(sptr));
1191 } else if (SCG(sptr) == SC_DUMMY) {
1192 return get_ftn_dummy_lltype(sptr);
1193 } else if (DESCARRAYG(sptr) && CLASSG(sptr)) {
1194 return make_ptr_lltype(get_ftn_typedesc_lltype(sptr));
1195 } else if (SCG(sptr) == SC_STATIC) {
1196 return make_ptr_lltype(get_ftn_static_lltype(sptr));
1197 } else if (CFUNCG(sptr) && SCG(sptr) == SC_EXTERN) {
1198 return make_ptr_lltype(get_ftn_cbind_lltype(sptr));
1199 } else if (SCG(sptr) == SC_LOCAL && SOCPTRG(sptr)) {
1200 return make_ptr_lltype(get_local_overlap_vartype());
1201 }
1202
1203 assert(sptr, "make_lltype_from_sptr(), no incoming arguments", 0, ERR_Fatal);
1204 DBGTRACEIN7(" sptr %d (%s), stype = %d (%s), dtype = %d (%s,%d)\n", sptr,
1205 SYMNAME(sptr), stype, stb.stypes[stype], sdtype,
1206 stb.tynames[DTY(sdtype)], (int)DTY(sdtype))
1207
1208 /* Labels */
1209 if (stype == ST_LABEL) {
1210 return ll_create_basic_type(llvm_get_current_module(), LL_LABEL, 0);
1211 }
1212
1213 /* Functions */
1214 if (is_function(sptr)) {
1215 LL_ABI_Info *abi;
1216 if (IS_FTN_PROC_PTR(sptr)) {
1217 if ((iface = get_iface_sptr(sptr)))
1218 return make_ptr_lltype(make_ptr_lltype(make_lltype_from_iface(iface)));
1219 return make_ptr_lltype(make_lltype_from_dtype(DT_CPTR));
1220 }
1221 abi = ll_abi_for_func_sptr(llvm_get_current_module(), sptr, DT_NONE);
1222 llt = ll_abi_function_type(abi);
1223 return make_ptr_lltype(llt);
1224 }
1225
1226 /* Volatiles */
1227 if (sptr && VOLG(sptr)) {
1228 // FIXME -- do nothing? -- should flag for metadata
1229 DBGTRACE1("#setting type for '%s' to VOLATILE", SYMNAME(sptr));
1230 }
1231 #ifdef OMP_OFFLOAD_LLVM
1232 addrspace = OMPACCSHMEMG(sptr) ? LL_AddrSp_NVVM_Shared : LL_AddrSp_NVVM_Generic;
1233 #endif
1234 /* Initialize llt information, and set initial type */
1235 llt = ll_convert_dtype_with_addrspace(llvm_get_current_module(), sdtype, addrspace);
1236
1237 if (llis_integral_kind(sdtype)) {
1238 /* do nothing */
1239 } else if (llis_pointer_kind(sdtype)) {
1240 /* make it i8* - use i32* or i64* */
1241 if (sc == SC_DUMMY)
1242 return make_generic_dummy_lltype();
1243 if (DTY(sdtype) == TY_PTR && sdtype != DT_ADDR)
1244 llt = ll_get_pointer_type(make_lltype_from_dtype(DTySeqTyElement(sdtype)));
1245 else if (sdtype == DT_ADDR)
1246 llt = ll_get_pointer_type(make_lltype_from_dtype(DT_BINT));
1247 else
1248 llt = ll_get_pointer_type(make_lltype_from_dtype(sdtype));
1249 if (llt->sub_types[0]->data_type == LL_VOID) {
1250 llt = ll_get_pointer_type(ll_create_int_type(llvm_get_current_module(), 8));
1251 }
1252 } else if (llis_array_kind(sdtype)) {
1253 /* all dummy argument are i32* or i64* */
1254 if (SCG(sptr) == SC_DUMMY)
1255 return make_generic_dummy_lltype();
1256 /* Make all arrays to be <type>* */
1257 if (DTY(sdtype) == TY_CHAR)
1258 atype = DT_BINT;
1259 else if (DTY(sdtype) == TY_NCHAR)
1260 atype = DT_SINT;
1261 else
1262 atype = DDTG(sdtype);
1263 llt = ll_get_pointer_type(make_lltype_from_dtype_with_addrspace(atype, addrspace));
1264 if (DTY(sdtype) != TY_CHAR && DTY(sdtype) != TY_NCHAR) {
1265 ad = AD_DPTR(sdtype);
1266 d = AD_NUMELM(ad);
1267 if (d == 0 || STYPEG(d) != ST_CONST) {
1268 if (XBIT(68, 0x1))
1269 d = AD_NUMELM(ad) = stb.k1;
1270 else
1271 d = AD_NUMELM(ad) = stb.i1;
1272 }
1273 anum = ad_val_of(d);
1274 } else {
1275 anum = DTySeqTyElement(sdtype);
1276 }
1277 if (anum > 0) {
1278 llt = ll_get_array_type(make_lltype_from_dtype(atype), anum,
1279 addrspace);
1280 }
1281 } else if (llis_vector_kind(sdtype)) {
1282 LL_Type *oldLlt = llt;
1283 DBGTRACE1("#setting dtype %d for vector type", sdtype)
1284
1285 #ifdef TARGET_LLVM_ARM
1286 if (sc == SC_DUMMY) {
1287 switch (ZSIZEOF(sdtype)) {
1288 case 1:
1289 llt = ll_create_int_type(llvm_get_current_module(), 8);
1290 break;
1291 case 2:
1292 llt = ll_create_int_type(llvm_get_current_module(), 16);
1293 break;
1294 case 3:
1295 // FIXME: why is this promoted to 32 bits?
1296 // llt = ll_create_int_type(module, 24);
1297 // break;
1298 case 4:
1299 llt = ll_create_int_type(llvm_get_current_module(), 32);
1300 break;
1301 default:
1302 assert(0, "", __LINE__, ERR_Fatal);
1303 }
1304 }
1305 #endif // TARGET_LLVM_ARM
1306 if (oldLlt == llt) {
1307 // LL_Type *t = make_lltype_from_dtype(DTY(sdtype + 1));
1308 // llt = ll_get_pointer_type(t);
1309 }
1310 } else if (llis_struct_kind(sdtype)) {
1311 process_dtype_struct(sdtype);
1312 } else if (llis_function_kind(sdtype)) {
1313 LL_ABI_Info *abi = ll_abi_for_func_sptr(llvm_get_current_module(), sptr, DT_NONE);
1314 llt = ll_abi_function_type(abi);
1315 DBGTRACE1("#setting dtype %d for function type", sdtype)
1316 }
1317
1318 /* in LLVM, all variables, except dummies, have memory address
1319 * by default (either on the stack in the case of locals, or
1320 * global addresses with global variables), and thus a pointer
1321 * needs to be prepended to the type.
1322 */
1323 if (need_ptr(sptr, sc, sdtype)) {
1324 llt = ll_get_pointer_type(llt);
1325 }
1326
1327 DBGDUMPLLTYPE("returned type is ", llt)
1328 DBGTRACEOUT1(" return type address %p", llt)
1329
1330 if ((llt->data_type == LL_ARRAY) || (llt->data_type == LL_PTR)) {
1331 LLDEF *def = (LLDEF *)llutil_alloc(sizeof(LLDEF));
1332 def->dtype = sdtype;
1333 def->sptr = sptr;
1334 def->ll_type = llt;
1335 def->addrspace = addrspace;
1336 add_def(def, &llarray_def_list);
1337 }
1338 return llt;
1339 } /* make_lltype_from_sptr */
1340
1341 /* Create an OT_CONSTSPTR operand for the constant sptr. */
1342 OPERAND *
make_constsptr_op(SPTR sptr)1343 make_constsptr_op(SPTR sptr)
1344 {
1345 OPERAND *op;
1346
1347 assert(STYPEG(sptr) == ST_CONST, "Constant sptr required", sptr, ERR_Fatal);
1348 op = make_operand();
1349 op->ot_type = OT_CONSTSPTR;
1350 op->ll_type = make_lltype_from_dtype(DTYPEG(sptr));
1351 op->val.sptr = sptr;
1352
1353 return op;
1354 }
1355
1356 static char *
ll_get_string_buf(int string_len,char * base,int skip_quotes)1357 ll_get_string_buf(int string_len, char *base, int skip_quotes)
1358 {
1359 char *name = "";
1360 char *from, *to;
1361 int c, len, newlen;
1362
1363 len = string_len;
1364 from = base;
1365 newlen = 3;
1366 while (len--) {
1367 c = *from++ & 0xff;
1368 if (c == '\"' || c == '\\') {
1369 newlen += 3;
1370 } else if (c >= ' ' && c <= '~') {
1371 newlen++;
1372 } else if (c == '\n' || c == '\r') {
1373 newlen += 3;
1374 } else {
1375 newlen += 3;
1376 }
1377 }
1378 name = (char *)llutil_alloc((newlen + 3) * sizeof(char));
1379 to = name;
1380 if (!skip_quotes) {
1381 *name = '\"';
1382 to++;
1383 }
1384
1385 from = base;
1386 len = string_len;
1387 while (len--) {
1388 c = *from++ & 0xff;
1389 if (c == '\"' || c == '\\') {
1390 *to++ = '\\';
1391 sprintf(to, "%02X", c);
1392 to += 2;
1393 } else if (c >= ' ' && c <= '~') {
1394 *to++ = c;
1395 } else if (c == '\n' || c == '\r') {
1396 *to++ = '\\';
1397 sprintf(to, "%02X", c);
1398 to += 2;
1399 } else {
1400 *to++ = '\\';
1401 sprintf(to, "%02X", c);
1402 to += 3;
1403 }
1404 }
1405
1406 if (!skip_quotes) {
1407 *to++ = '\"';
1408 }
1409 *to = '\0';
1410 return name;
1411 }
1412
1413 char *
ll_get_cstring_buf(int sptr,int skip_quotes)1414 ll_get_cstring_buf(int sptr, int skip_quotes)
1415 {
1416 char *name = "";
1417 char *to, *from;
1418 DTYPE dtype = DTYPEG(sptr);
1419 int c, len, newlen, index, pos;
1420 char buf[11];
1421
1422 dtype = DTYPEG(sptr);
1423 return name;
1424 }
1425
1426 /* Create an OT_CONSTSTRING operand for the constant sptr. */
1427 static OPERAND *
make_conststring_op(int sptr)1428 make_conststring_op(int sptr)
1429 {
1430 OPERAND *op = NULL;
1431 assert(STYPEG(sptr) == ST_CONST, "Constant sptr required", sptr, ERR_Fatal);
1432 op = make_operand();
1433 op->ot_type = OT_CONSTSTRING;
1434 op->ll_type = make_lltype_from_dtype(DTYPEG(sptr));
1435
1436 if (sptr && DTY(DTYPEG(sptr)) == TY_CHAR) {
1437 const int length = ll_type_bytes(op->ll_type);
1438 op->string = ll_get_string_buf(length, stb.n_base + CONVAL1G(sptr), 1);
1439 }
1440 return op;
1441 }
1442
1443 OPERAND *
make_constval_op(LL_Type * ll_type,INT conval0,INT conval1)1444 make_constval_op(LL_Type *ll_type, INT conval0, INT conval1)
1445 {
1446 OPERAND *op;
1447
1448 op = make_operand();
1449 op->ot_type = OT_CONSTVAL;
1450 op->ll_type = ll_type;
1451 op->val.conval[0] = conval0;
1452 op->val.conval[1] = conval1;
1453
1454 return op;
1455 }
1456
1457 OPERAND *
make_constval_opL(LL_Type * ll_type,INT conval0,INT conval1,INT conval2,INT conval3)1458 make_constval_opL(LL_Type *ll_type, INT conval0, INT conval1, INT conval2,
1459 INT conval3)
1460 {
1461 OPERAND *op;
1462
1463 op = make_operand();
1464 op->ot_type = OT_CONSTVAL;
1465 op->ll_type = ll_type;
1466 op->val.conval[0] = conval0;
1467 op->val.conval[1] = conval1;
1468 op->val.conval[2] = conval2;
1469 op->val.conval[3] = conval3;
1470
1471 return op;
1472 }
1473
1474 OPERAND *
make_constval32_op(int idx)1475 make_constval32_op(int idx)
1476 {
1477 return make_constval_op(make_lltype_from_dtype(DT_INT), idx, 0);
1478 }
1479
1480 static LL_Type *
set_vect3_to_size4(LL_Type * ll_type)1481 set_vect3_to_size4(LL_Type *ll_type)
1482 {
1483 switch (ll_type->data_type) {
1484 case LL_ARRAY:
1485 ll_type = ll_get_array_type(set_vect3_to_size4(ll_type->sub_types[0]),
1486 ll_type->sub_elements, ll_type->addrspace);
1487 break;
1488 case LL_VECTOR:
1489 if (ll_type->sub_elements == 3)
1490 ll_type = ll_get_vector_type(ll_type->sub_types[0], 4);
1491 break;
1492 case LL_PTR:
1493 ll_type = ll_get_pointer_type(set_vect3_to_size4(ll_type->sub_types[0]));
1494 break;
1495 default:
1496 break;
1497 }
1498 return ll_type;
1499 }
1500
1501 LL_Type *
make_lltype_sz4v3_from_sptr(SPTR sptr)1502 make_lltype_sz4v3_from_sptr(SPTR sptr)
1503 {
1504 LL_Type *llt = make_lltype_from_sptr(sptr);
1505 return set_vect3_to_size4(llt);
1506 }
1507
1508 LL_Type *
make_lltype_sz4v3_from_dtype(DTYPE dtype)1509 make_lltype_sz4v3_from_dtype(DTYPE dtype)
1510 {
1511 LL_Type *llt = make_lltype_from_dtype(dtype);
1512 return set_vect3_to_size4(llt);
1513 }
1514
1515 OPERAND *
make_var_op(SPTR sptr)1516 make_var_op(SPTR sptr)
1517 {
1518 OPERAND *op;
1519
1520 process_sptr(sptr);
1521 op = make_operand();
1522 op->ot_type = OT_VAR;
1523 op->ll_type = make_lltype_from_sptr(sptr);
1524 op->val.sptr = sptr;
1525 set_llvm_sptr_name(op);
1526
1527 return op;
1528 }
1529
1530 INLINE static OPERAND *
make_arg_op(SPTR sptr)1531 make_arg_op(SPTR sptr)
1532 {
1533 OPERAND *op;
1534 unsigned size;
1535 char *base_name;
1536 char *buffer;
1537
1538 process_sptr(sptr);
1539 op = make_operand();
1540 op->ot_type = OT_VAR;
1541 op->ll_type = make_lltype_from_sptr(sptr);
1542 op->val.sptr = sptr;
1543 base_name = get_llvm_name(sptr);
1544 size = strlen(base_name) + 6;
1545 buffer = (char *)llutil_alloc(size);
1546 snprintf(buffer, size, "%%%s.arg", base_name);
1547 op->string = buffer;
1548 return op;
1549 }
1550
1551 OPERAND *
make_def_op(char * str)1552 make_def_op(char *str)
1553 {
1554 OPERAND *op;
1555
1556 op = make_operand();
1557 op->ot_type = OT_DEF;
1558 op->string = str;
1559
1560 return op;
1561 }
1562
1563 static OPERAND *
make_member_op_with_lltype(int address,LL_Type * llTy)1564 make_member_op_with_lltype(int address, LL_Type *llTy)
1565 {
1566 OPERAND *op = make_operand();
1567 op->ot_type = OT_MEMBER;
1568 op->ll_type = llTy;
1569 op->next = NULL;
1570 return op;
1571 }
1572
1573 INLINE static OPERAND *
make_member_op(int address,DTYPE dtype)1574 make_member_op(int address, DTYPE dtype)
1575 {
1576 return make_member_op_with_lltype(address, make_lltype_from_dtype(dtype));
1577 }
1578
1579 OPERAND *
make_tmp_op(LL_Type * llt,TMPS * tmps)1580 make_tmp_op(LL_Type *llt, TMPS *tmps)
1581 {
1582 OPERAND *op;
1583
1584 op = make_operand();
1585 op->ot_type = OT_TMP;
1586 op->ll_type = llt;
1587 op->tmps = tmps;
1588 return op;
1589 }
1590
1591 OPERAND *
make_undef_op(LL_Type * llt)1592 make_undef_op(LL_Type *llt)
1593 {
1594 OPERAND *op;
1595
1596 op = make_operand();
1597 op->ot_type = OT_UNDEF;
1598 op->ll_type = llt;
1599 return op;
1600 }
1601
1602 OPERAND *
make_null_op(LL_Type * llt)1603 make_null_op(LL_Type *llt)
1604 {
1605 OPERAND *op;
1606
1607 assert(llt->data_type == LL_PTR, "make_null_op: Need pointer type", 0, ERR_Fatal);
1608 op = make_operand();
1609 op->ot_type = OT_CONSTVAL;
1610 op->ll_type = llt;
1611 op->flags |= OPF_NULL_TYPE;
1612
1613 return op;
1614 }
1615
1616 /* Create a metadata operand that references a numbered metadata node. */
1617 OPERAND *
make_mdref_op(LL_MDRef mdref)1618 make_mdref_op(LL_MDRef mdref)
1619 {
1620 OPERAND *op;
1621
1622 assert(LL_MDREF_kind(mdref) == MDRef_Node,
1623 "Can only reference metadata nodes", 0, ERR_Fatal);
1624 op = make_operand();
1625 op->ot_type = OT_MDNODE;
1626 op->tmps = make_tmps();
1627 op->tmps->id = LL_MDREF_value(mdref) + 1;
1628
1629 return op;
1630 }
1631
1632 OPERAND *
make_metadata_wrapper_op(SPTR sptr,LL_Type * llTy)1633 make_metadata_wrapper_op(SPTR sptr, LL_Type *llTy)
1634 {
1635 OPERAND *op;
1636
1637 if (sptr)
1638 process_sptr(sptr);
1639 op = make_operand();
1640 op->ot_type = OT_MDNODE;
1641 op->val.sptr = sptr;
1642 op->ll_type = llTy;
1643 return op;
1644 }
1645
1646 OPERAND *
make_target_op(SPTR sptr)1647 make_target_op(SPTR sptr)
1648 {
1649 OPERAND *op;
1650
1651 if (sptr)
1652 process_sptr(sptr);
1653 op = make_operand();
1654 op->ot_type = OT_TARGET;
1655 op->val.sptr = sptr;
1656 if (sptr)
1657 op->string = get_label_name(sptr);
1658 return op;
1659 }
1660
1661 OPERAND *
make_label_op(SPTR sptr)1662 make_label_op(SPTR sptr)
1663 {
1664 OPERAND *op;
1665
1666 if (sptr)
1667 process_sptr(sptr);
1668 op = make_operand();
1669 op->ot_type = OT_LABEL;
1670 op->val.sptr = sptr;
1671 if (sptr)
1672 op->string = get_label_name(sptr);
1673 return op;
1674 }
1675
1676 OPERAND *
make_operand(void)1677 make_operand(void)
1678 {
1679 OPERAND *op = (OPERAND *)llutil_alloc(sizeof(OPERAND));
1680 return op;
1681 }
1682
1683 static void
set_llasm_output_file(FILE * fd)1684 set_llasm_output_file(FILE *fd)
1685 {
1686 LLVMFIL = fd;
1687 }
1688
1689 void
init_output_file(void)1690 init_output_file(void)
1691 {
1692 if (FTN_HAS_INIT())
1693 return;
1694 FTN_HAS_INIT() = 1;
1695 set_llasm_output_file(gbl.asmfil);
1696 ll_write_module_header(gbl.asmfil, llvm_get_current_module());
1697 }
1698
1699 void
init_gpu_output_file(void)1700 init_gpu_output_file(void)
1701 {
1702 if (FTN_GPU_INIT())
1703 return;
1704 FTN_GPU_INIT() = 1;
1705 #ifdef OMP_OFFLOAD_LLVM
1706 if(flg.omptarget)
1707 ll_write_module_header(gbl.ompaccfile, gpu_llvm_module);
1708 #endif
1709 }
1710
1711 #ifdef OMP_OFFLOAD_LLVM
1712 void
use_gpu_output_file(void)1713 use_gpu_output_file(void)
1714 {
1715 set_llasm_output_file(gbl.ompaccfile);
1716 }
1717 void
use_cpu_output_file(void)1718 use_cpu_output_file(void)
1719 {
1720 set_llasm_output_file(gbl.asmfil);
1721 }
1722 #endif
1723 /**
1724 \brief Write size of \c LL_Type to llvm file
1725 */
1726 void
print_llsize(LL_Type * llt)1727 print_llsize(LL_Type *llt)
1728 {
1729 assert(llt, "print_llsize(): missing llt", 0, ERR_Fatal);
1730 fprintf(LLVMFIL, "%" BIGIPFSZ "d", ll_type_bytes(llt) * 8);
1731 }
1732
1733 void
print_llsize_tobuf(LL_Type * llt,char * buf)1734 print_llsize_tobuf(LL_Type *llt, char *buf)
1735 {
1736 assert(llt, "print_llsize(): missing llt", 0, ERR_Fatal);
1737 sprintf(buf, "%" BIGIPFSZ "d", ll_type_bytes(llt) * 8);
1738 }
1739
1740 /**
1741 \brief Write \p num spaces to llvm file
1742 \p num The number of spaces to write
1743 */
1744 void
print_space(int num)1745 print_space(int num)
1746 {
1747 int i;
1748
1749 for (i = 0; i < num; i++)
1750 fputc(' ', LLVMFIL);
1751 }
1752
1753 void
print_space_tobuf(int num,char * buf)1754 print_space_tobuf(int num, char *buf)
1755 {
1756 int i;
1757
1758 for (i = 0; i < num; i++)
1759 sprintf(buf, " ");
1760 }
1761
1762 /**
1763 \brief Write any line which does not need a tab
1764 */
1765 void
print_line(char * ln)1766 print_line(char *ln)
1767 {
1768 if (ln != NULL)
1769 fprintf(LLVMFIL, "%s\n", ln);
1770 else
1771 fprintf(LLVMFIL, "\n");
1772 }
1773
1774 /**
1775 \brief Print any line which does not need a tab
1776 */
1777 void
print_line_tobuf(char * ln,char * buf)1778 print_line_tobuf(char *ln, char *buf)
1779 {
1780 if (ln != NULL)
1781 sprintf(buf, "%s\n", ln);
1782 else
1783 sprintf(buf, "\n");
1784 }
1785
1786 FILE *
llvm_file(void)1787 llvm_file(void)
1788 {
1789 return LLVMFIL;
1790 }
1791
1792 /**
1793 \brief Write a token at the current location with no nl
1794 */
1795 void
print_token(const char * tk)1796 print_token(const char *tk)
1797 {
1798 assert(tk, "print_token(): missing token", 0, ERR_Fatal);
1799 fprintf(LLVMFIL, "%s", tk);
1800 }
1801
1802 /**
1803 \brief print a token at the current location with no nl
1804 */
1805 void
print_token_tobuf(char * tk,char * buf)1806 print_token_tobuf(char *tk, char *buf)
1807 {
1808 assert(tk, "print_token(): missing token", 0, ERR_Fatal);
1809 sprintf(buf, "%s", tk);
1810 }
1811
1812 /**
1813 \brief Write a new line in the output llvm file
1814 */
1815 void
print_nl(void)1816 print_nl(void)
1817 {
1818 fprintf(LLVMFIL, "\n");
1819 }
1820
1821 void
print_nl_tobuf(char * buf)1822 print_nl_tobuf(char *buf)
1823 {
1824 sprintf(buf, "\n");
1825 }
1826
1827 /**
1828 \brief Emit line info debug information.
1829
1830 Output the string " !dbg !<i>n</i>", where <i>n</i> is a metadata ref.
1831 */
1832 void
print_dbg_line_no_comma(LL_MDRef md)1833 print_dbg_line_no_comma(LL_MDRef md)
1834 {
1835 char buf[32];
1836 snprintf(buf, 32, " !dbg !%u", LL_MDREF_value(md));
1837 print_token(buf);
1838 }
1839
1840 void
print_dbg_line(LL_MDRef md)1841 print_dbg_line(LL_MDRef md)
1842 {
1843 print_token(",");
1844 print_dbg_line_no_comma(md);
1845 }
1846
1847 /**
1848 \brief Compare two types to make sure something isn't already sideways
1849
1850 This is for use in sanity assertions.
1851 FIXME: i32 and i64 types are conflated in many f90_correct tests.
1852 */
1853 static bool
LLTYPE_equiv(LL_Type * ty1,LL_Type * ty2)1854 LLTYPE_equiv(LL_Type *ty1, LL_Type *ty2)
1855 {
1856 return true;
1857 // FIXME - return (ty1 == ty2) || (ty1->data_type == ty2->data_type);
1858 return false;
1859 }
1860
1861 static void
write_vconstant_value(int sptr,LL_Type * type,unsigned long long undef_bitmask)1862 write_vconstant_value(int sptr, LL_Type *type, unsigned long long undef_bitmask)
1863 {
1864 LL_Type *vtype = type->sub_types[0];
1865 int vsize = type->sub_elements;
1866 int i;
1867 int edtype;
1868 char *vctype, *constant;
1869
1870 edtype = CONVAL1G(sptr);
1871
1872 fputc('<', LLVMFIL);
1873
1874 for (i = 0; i < vsize; i++) {
1875 if (i)
1876 fputs(", ", LLVMFIL);
1877 write_type(vtype);
1878 fputc(' ', LLVMFIL);
1879
1880 if (undef_bitmask & 1) {
1881 print_token("undef");
1882 undef_bitmask >>= 1;
1883 continue;
1884 }
1885 undef_bitmask >>= 1;
1886
1887 switch (vtype->data_type) {
1888 case LL_DOUBLE:
1889 write_constant_value(VCON_CONVAL(edtype + i), 0, 0, 0, false);
1890 break;
1891 case LL_I40:
1892 case LL_I48:
1893 case LL_I56:
1894 case LL_I64:
1895 case LL_I128:
1896 case LL_I256: {
1897 write_constant_value(VCON_CONVAL(edtype + i), 0, 0, 0, false);
1898 break;
1899 }
1900 /* Fall through. */
1901 default:
1902 write_constant_value(0, vtype, VCON_CONVAL(edtype + i), 0, false);
1903 }
1904 }
1905 fputc('>', LLVMFIL);
1906 }
1907
1908 /**
1909 \brief Write a constant value to the output llvm file
1910 */
1911 void
write_constant_value(int sptr,LL_Type * type,INT conval0,INT conval1,bool uns)1912 write_constant_value(int sptr, LL_Type *type, INT conval0, INT conval1,
1913 bool uns)
1914 {
1915 const char *ctype;
1916 INT num[2] = {0, 0};
1917 union xx_u xx;
1918 union {
1919 double d;
1920 INT tmp[2];
1921 } dtmp, dtmp2;
1922 char constant1[9], constant2[9];
1923
1924 static char d[256];
1925 static char b[100];
1926
1927 assert((sptr || type), "write_constant_value(): missing arguments", sptr, ERR_Fatal);
1928 if (sptr && !type)
1929 type = make_lltype_from_dtype(DTYPEG(sptr));
1930
1931 switch (type->data_type) {
1932 case LL_VECTOR:
1933 write_vconstant_value(sptr, type, 0);
1934 return;
1935
1936 case LL_ARRAY:
1937
1938 if (sptr && DTY(DTYPEG(sptr)) == TY_CHAR) {
1939 int len = type->sub_elements;
1940 char *p;
1941 fprintf(LLVMFIL, "c\"");
1942
1943 p = stb.n_base + CONVAL1G(sptr);
1944 ;
1945 while (len--)
1946 fprintf(LLVMFIL, "%c", *p++);
1947 fprintf(LLVMFIL, "\"");
1948 return;
1949 }
1950
1951 if (conval0 == 0 && conval1 == 0) {
1952 fprintf(LLVMFIL, "zeroinitializer");
1953 } else {
1954 unsigned elems = type->sub_elements;
1955
1956 if (sptr && DTY(DTYPEG(sptr)) == TY_NCHAR) {
1957 ctype = llvm_fc_type(DTYPEG(sptr));
1958 fprintf(LLVMFIL, "[");
1959 } else
1960 fprintf(LLVMFIL, "{");
1961 while (elems > 0) {
1962 if (sptr && DTY(DTYPEG(sptr)) == TY_NCHAR) {
1963 fprintf(LLVMFIL, "%s ", ctype);
1964 }
1965 write_constant_value(0, type->sub_types[0], conval0, conval1, uns);
1966 elems--;
1967 if (elems > 0)
1968 fprintf(LLVMFIL, ", ");
1969 }
1970 if (sptr && DTY(DTYPEG(sptr)) == TY_NCHAR) {
1971 fprintf(LLVMFIL, "]");
1972 } else
1973 fprintf(LLVMFIL, "}");
1974 }
1975 return;
1976
1977 case LL_STRUCT:
1978 /* Complex data types are represented as LLVM structs. */
1979 if (sptr && DT_ISCMPLX(DTYPEG(sptr))) {
1980 if (DTY(DTYPEG(sptr)) == TY_CMPLX) {
1981 LL_Type *float_type = make_lltype_from_dtype(DT_FLOAT);
1982 ctype = llvm_fc_type(DT_FLOAT);
1983 fprintf(LLVMFIL, "<{ %s ", ctype);
1984 write_constant_value(0, float_type, CONVAL1G(sptr), 0, uns);
1985 fprintf(LLVMFIL, ", %s ", ctype);
1986 write_constant_value(0, float_type, CONVAL2G(sptr), 0, uns);
1987 fprintf(LLVMFIL, "}>");
1988 } else {
1989 ctype = llvm_fc_type(DTYPEG(CONVAL1G(sptr)));
1990 fprintf(LLVMFIL, "<{ %s ", ctype);
1991 write_constant_value(CONVAL1G(sptr), 0, 0, 0, uns);
1992 fprintf(LLVMFIL, ", %s ", ctype);
1993 write_constant_value(CONVAL2G(sptr), 0, 0, 0, uns);
1994 fprintf(LLVMFIL, "}>");
1995 }
1996 } else {
1997 assert(conval0 == 0 && conval1 == 0,
1998 "write_constant_value(): non zero struct", 0, ERR_Fatal);
1999 fprintf(LLVMFIL, "zeroinitializer");
2000 }
2001 return;
2002
2003 case LL_I1:
2004 case LL_I8:
2005 case LL_I16:
2006 case LL_I24:
2007 case LL_I32:
2008 case LL_I40:
2009 case LL_I48:
2010 case LL_I56:
2011 case LL_I64:
2012 case LL_I128:
2013 case LL_I256:
2014 if (sptr) {
2015 num[1] = CONVAL2G(sptr);
2016 num[0] = CONVAL1G(sptr);
2017 } else {
2018 num[1] = conval0;
2019 num[0] = conval1;
2020 }
2021 if (ll_type_bytes(type) <= 4) {
2022 fprintf(LLVMFIL, uns ? "%lu" : "%ld", (long)num[1]);
2023 } else {
2024 ui64toax(num, b, 22, uns, 10);
2025 fprintf(LLVMFIL, "%s", b);
2026 }
2027 return;
2028
2029 case LL_DOUBLE:
2030 if (sptr) {
2031 num[0] = CONVAL1G(sptr);
2032 num[1] = CONVAL2G(sptr);
2033 } else {
2034 num[0] = conval0;
2035 num[1] = conval1;
2036 }
2037
2038 cprintf(d, "%.17le", num);
2039 /* Check for `+/-Infinity` and 'NaN' based on the IEEE bit patterns */
2040 if ((num[0] & 0x7ff00000) == 0x7ff00000) /* exponent == 2047 */
2041 sprintf(d, "0x%08x%08x", num[0], num[1]);
2042 /* also check for -0 */
2043 else if (num[0] == 0x80000000 && num[1] == 0x00000000)
2044 sprintf(d, "-0.00000000e+00");
2045 /* remember to make room for /0 */
2046 fprintf(LLVMFIL, "%s", d);
2047 return;
2048
2049 case LL_FLOAT:
2050 /* our internal representation of floats is in 8 digit hex form;
2051 * internal LLVM representation of floats in hex form is 16 digits;
2052 * thus we must make the conversion. Also need to decide when to
2053 * represent final float form in exponential or hexadecimal form.
2054 */
2055 if (sptr)
2056 xx.ww = CONVAL2G(sptr);
2057 else
2058 xx.ww = conval0;
2059 xdble(xx.ww, dtmp2.tmp);
2060 xdtomd(dtmp2.tmp, &dtmp.d);
2061 snprintf(d, 200, "%.8e", dtmp.d);
2062 if (dtmp.tmp[0] == -1) /* pick up the quiet nan */
2063 sprintf(constant1, "7FF80000");
2064 else if (!dtmp.tmp[1])
2065 sprintf(constant1, "00000000");
2066 else
2067 sprintf(constant1, "%X", dtmp.tmp[1]);
2068 if (!dtmp.tmp[0] || dtmp.tmp[0] == -1)
2069 sprintf(constant2, "00000000");
2070 else
2071 sprintf(constant2, "%X", dtmp.tmp[0]);
2072
2073 /* check for negative zero */
2074 if (dtmp.tmp[1] == 0x80000000 && !dtmp.tmp[0])
2075 fprintf(LLVMFIL, "-0.000000e+00");
2076 else
2077 fprintf(LLVMFIL, "0x%s%s", constant1, constant2);
2078
2079 break;
2080
2081 case LL_X86_FP80:
2082 assert(sptr, "write_constant_value(): x87 constant without sptr", 0, ERR_Fatal);
2083 fprintf(LLVMFIL, "0xK%08x%08x%04x", CONVAL1G(sptr), CONVAL2G(sptr),
2084 (unsigned short)(CONVAL3G(sptr) >> 16));
2085 return;
2086
2087 case LL_FP128:
2088 assert(sptr, "write_constant_value(): fp128 constant without sptr", 0, ERR_Fatal);
2089 fprintf(LLVMFIL, "0xL%08x%08x%08x%08x", CONVAL1G(sptr), CONVAL2G(sptr),
2090 CONVAL3G(sptr), CONVAL4G(sptr));
2091 return;
2092
2093 case LL_PPC_FP128:
2094 assert(sptr, "write_constant_value(): double-double constant without sptr",
2095 0, ERR_Fatal);
2096 fprintf(LLVMFIL, "0xM%08x%08x%08x%08x", CONVAL1G(CONVAL1G(sptr)),
2097 CONVAL2G(CONVAL1G(sptr)), CONVAL1G(CONVAL2G(sptr)),
2098 CONVAL2G(CONVAL2G(sptr)));
2099 return;
2100
2101 case LL_PTR:
2102 if (sptr) {
2103 num[1] = CONVAL2G(sptr);
2104 num[0] = CONVAL1G(sptr);
2105 } else {
2106 num[1] = conval0;
2107 num[0] = conval1;
2108 }
2109 if (num[0] == 0 && num[1] == 0) {
2110 fprintf(LLVMFIL, "null");
2111 } else {
2112 ui64toax(num, b, 22, uns, 10);
2113 fprintf(LLVMFIL, "%s", b);
2114 }
2115 return;
2116 default:
2117 assert(false, "write_constant_value(): unexpected constant ll_type",
2118 type->data_type, ERR_Fatal);
2119 }
2120 } /* write_constant_value */
2121
2122 /**
2123 \brief Write LL_Type to llvm file
2124 */
2125 void
write_type(LL_Type * ll_type)2126 write_type(LL_Type *ll_type)
2127 {
2128 print_token(ll_type->str);
2129 }
2130
2131 INLINE static bool
metadata_args_need_struct(void)2132 metadata_args_need_struct(void)
2133 {
2134 return ll_feature_metadata_args_struct(&llvm_get_current_module()->ir);
2135 }
2136
2137 /**
2138 \brief Write a single operand
2139 */
2140 void
write_operand(OPERAND * p,const char * punc_string,int flags)2141 write_operand(OPERAND *p, const char *punc_string, int flags)
2142 {
2143 int nme, dtype, ct;
2144 char cnst[MAXIDLEN];
2145 OPERAND *new_op;
2146 LL_Type *llt;
2147 LL_Type *pllt;
2148 char *name;
2149 const bool uns = (flags & FLG_AS_UNSIGNED) != 0;
2150 int sptr = p->val.sptr;
2151 if (p->flags & OPF_CONTAINS_UNDEF) {
2152 sptr = p->val.sptr_undef.sptr;
2153 }
2154
2155 DBGTRACEIN2(" operand %p (%s)", p, OTNAMEG(p))
2156 DBGDUMPLLTYPE(" with type ", p->ll_type)
2157
2158 switch (p->ot_type) {
2159 case OT_MEMBER:
2160 case OT_NONE:
2161 write_type(p->ll_type);
2162 break;
2163 case OT_CONSTVAL:
2164 if (p->flags & OPF_NULL_TYPE) {
2165 if (!(flags & FLG_OMIT_OP_TYPE))
2166 write_type(p->ll_type);
2167 print_token(" null");
2168 } else {
2169 assert(p->ll_type, "write_operand(): no type when expected", 0, ERR_Fatal);
2170 if (!(flags & FLG_OMIT_OP_TYPE)) {
2171 write_type(p->ll_type);
2172 print_space(1);
2173 }
2174 write_constant_value(0, p->ll_type, p->val.conval[0], p->val.conval[1],
2175 uns);
2176 }
2177 break;
2178 case OT_UNDEF:
2179 if (!(flags & FLG_OMIT_OP_TYPE)) {
2180 write_type(p->ll_type);
2181 print_space(1);
2182 }
2183 print_token("undef");
2184 break;
2185 case OT_CONSTSTRING:
2186 assert(p->string, "write_operand(): no string when expected", 0, ERR_Fatal);
2187 if (p->flags & OPF_NULL_TYPE)
2188 print_token("null");
2189 else {
2190 if (!(flags & FLG_OMIT_OP_TYPE)) {
2191 write_type(p->ll_type);
2192 print_space(1);
2193 }
2194 if (p->ll_type->sub_types[0]->data_type == LL_I16) {
2195 print_token(p->string);
2196 } else {
2197 print_token("c\"");
2198 print_token(p->string);
2199 print_token("\"");
2200 }
2201 }
2202 break;
2203 case OT_CONSTSPTR:
2204 assert(sptr, "write_operand(): no sptr when expected", 0, ERR_Fatal);
2205 if (p->flags & OPF_NULL_TYPE)
2206 print_token("null");
2207 else {
2208 LL_Type *sptrType = make_lltype_from_dtype(DTYPEG(sptr));
2209 assert(LLTYPE_equiv(sptrType, p->ll_type),
2210 "write_operand(): operand has incorrect type", sptr, ERR_Fatal);
2211 if (!(flags & FLG_OMIT_OP_TYPE)) {
2212 write_type(p->ll_type);
2213 print_space(1);
2214 }
2215 if (p->flags & OPF_CONTAINS_UNDEF) {
2216 write_vconstant_value(sptr, sptrType, p->val.sptr_undef.undef_mask);
2217 } else {
2218 write_constant_value(sptr, sptrType, 0, 0, uns);
2219 }
2220 }
2221 break;
2222 case OT_TARGET:
2223 assert(sptr, "write_operand(): no sptr when expected", 0, ERR_Fatal);
2224 print_token("label %L");
2225 print_token(p->string);
2226 break;
2227 case OT_VAR:
2228 assert(sptr, "write_operand(): no sptr when expected", 0, ERR_Fatal);
2229 name = p->string;
2230 pllt = p->ll_type;
2231 if (pllt->data_type == LL_FUNCTION)
2232 pllt = make_ptr_lltype(pllt);
2233 #if defined(TARGET_LLVM_X8664)
2234 if ((flags & FLG_FIXUP_RETURN_TYPE) && (pllt->data_type == LL_PTR))
2235 pllt = maybe_fixup_x86_abi_return(pllt);
2236 #endif
2237 if (!(flags & FLG_OMIT_OP_TYPE))
2238 write_type(pllt);
2239 if (p->flags & OPF_SRET_TYPE)
2240 print_token(" sret");
2241 if (p->flags & OPF_SRARG_TYPE)
2242 print_token(" byval");
2243 print_space(1);
2244 print_token(name);
2245 break;
2246 case OT_DEF:
2247 case OT_CALL: /* currently just used for llvm intrinsics */
2248 print_token(p->string);
2249 break;
2250 case OT_LABEL:
2251 print_token("L");
2252 print_token(p->string);
2253 print_token(":");
2254 break;
2255 case OT_TMP:
2256 if (!(flags & FLG_OMIT_OP_TYPE)) {
2257 assert(p->ll_type, "write_operand(): missing type information", 0, ERR_Fatal);
2258 write_type(p->ll_type);
2259 print_space(1);
2260 }
2261 if (p->flags & OPF_SRET_TYPE)
2262 print_token(" sret ");
2263 if (p->flags & OPF_SRARG_TYPE)
2264 print_token(" byval ");
2265 if (p->tmps)
2266 print_tmp_name(p->tmps);
2267 else
2268 assert(0, "write_operand(): missing temporary value", 0, ERR_Fatal);
2269 break;
2270 case OT_CC:
2271 assert(p->val.cc, "write_operand(): expecting condition code", 0, ERR_Fatal);
2272 assert(p->ll_type, "write_operand(): missing type", 0, ERR_Fatal);
2273 if (ll_type_int_bits(p->ll_type) || p->ll_type->data_type == LL_PTR)
2274 print_token(llvm_cc_names[p->val.cc]);
2275 else if (ll_type_is_fp(p->ll_type))
2276 print_token(llvm_ccfp_names[p->val.cc]);
2277 else if (p->ll_type->data_type == LL_VECTOR) {
2278 LL_Type *ty;
2279 assert(p->ll_type->data_type == LL_VECTOR, "expected vector",
2280 p->ll_type->data_type, ERR_Fatal);
2281 ty = p->ll_type->sub_types[0];
2282 if (ll_type_is_fp(ty)) {
2283 print_token(llvm_ccfp_names[p->val.cc]);
2284 } else if (ll_type_int_bits(ty)) {
2285 print_token(llvm_cc_names[p->val.cc]);
2286 } else {
2287 assert(0, "unexpected type", ty->data_type, ERR_Fatal);
2288 }
2289 } else {
2290 #if DEBUG
2291 assert(0, "write_operand(): bad LL type", p->ll_type->data_type, ERR_Fatal);
2292 #endif
2293 }
2294 break;
2295 case OT_MDNODE:
2296 if (p->tmps) {
2297 if (p->flags & OPF_WRAPPED_MD) {
2298 print_token("metadata ");
2299 print_token(p->ll_type->str);
2300 print_space(1);
2301 if (p->tmps->id)
2302 print_tmp_name(p->tmps);
2303 else
2304 print_token("undef");
2305 } else {
2306 if (!(flags & FLG_OMIT_OP_TYPE))
2307 print_token("metadata ");
2308 print_metadata_name(p->tmps);
2309 }
2310 } else if (p->val.sptr) {
2311 if (!(flags & FLG_OMIT_OP_TYPE))
2312 print_token("metadata ");
2313 if (metadata_args_need_struct())
2314 print_token("!{");
2315 if (p->flags & OPF_HIDDEN) {
2316 new_op = make_arg_op(p->val.sptr);
2317 if (p->ll_type)
2318 new_op->ll_type = p->ll_type;
2319 } else {
2320 new_op = make_var_op(p->val.sptr);
2321 if (p->ll_type)
2322 new_op->ll_type = ll_get_pointer_type(p->ll_type);
2323 }
2324 new_op->flags = p->flags;
2325 write_operand(new_op, "", 0);
2326 if (metadata_args_need_struct())
2327 print_token("}");
2328 } else {
2329 print_token("null");
2330 }
2331 break;
2332 default:
2333 DBGTRACE1("### write_operand(): unknown operand type: %s",
2334 ot_names[p->ot_type])
2335 assert(0, "write_operand(): unknown operand type", p->ot_type, ERR_Fatal);
2336 }
2337 /* check for commas and closing paren */
2338 if (punc_string != NULL)
2339 print_token(punc_string);
2340 DBGTRACEOUT("")
2341 }
2342
2343 /**
2344 \brief Write operand list
2345 \param operand The head of the list
2346 \param flags
2347
2348 Write out the operands in order. Not always possible, depends on instruction
2349 format. Assumes the separator is a comma.
2350 */
2351 void
write_operands(OPERAND * operand,int flags)2352 write_operands(OPERAND *operand, int flags)
2353 {
2354 OPERAND *p;
2355 int i_name, sptr;
2356
2357 DBGTRACEIN1(" starting at operand %p", operand)
2358
2359 /* write out the operands to the instructions */
2360 for (p = operand; p; p = p->next)
2361 write_operand(p, (p->next) ? ", " : "", flags);
2362
2363 DBGTRACEOUT("")
2364 }
2365
2366 static int metadata_id = 0;
2367
2368 /**
2369 \brief Set name for named metadata
2370 */
2371 void
set_metadata_string(TMPS * t,char * string)2372 set_metadata_string(TMPS *t, char *string)
2373 {
2374 DBGTRACEIN2(" TMPS* %p, string %s", t, string)
2375
2376 t->id = -1;
2377 t->info.string = string;
2378
2379 DBGTRACEOUT("")
2380 }
2381
2382 /**
2383 \brief Init metadata index, for anonymous metadata
2384 */
2385 void
init_metadata_index(TMPS * t)2386 init_metadata_index(TMPS *t)
2387 {
2388 DBGTRACEIN1(" TMPS* %p", t)
2389
2390 if (!t->id)
2391 t->id = ++metadata_id;
2392
2393 DBGTRACEOUT1(" %d", t->id)
2394 }
2395
2396 /**
2397 \brief Print metadata name
2398 */
2399 void
print_metadata_name(TMPS * t)2400 print_metadata_name(TMPS *t)
2401 {
2402 char tmp[50];
2403
2404 DBGTRACEIN1(" TMPS* %p", t)
2405
2406 if (!t->id)
2407 t->id = ++metadata_id;
2408 if (t->id < 0) {
2409 print_token(t->info.string);
2410 } else {
2411 sprintf(tmp, "!%d", t->id - 1);
2412 print_token(tmp);
2413 }
2414 DBGTRACEOUT("")
2415 } /* print_metadata_name */
2416
2417 #if DEBUG
2418 static int indentlev = 0;
2419 FILE *ll_dfile;
2420
2421 void
indent(int change)2422 indent(int change)
2423 {
2424 int i;
2425
2426 if (change < 0)
2427 indentlev += change;
2428 for (i = 1; i <= indentlev; i++)
2429 fprintf(ll_dfile, " ");
2430 if (change > 0)
2431 indentlev += change;
2432 }
2433 #endif
2434
2435 bool
small_aggr_return(DTYPE dtype)2436 small_aggr_return(DTYPE dtype)
2437 {
2438 #if defined(TARGET_LLVM_X8664)
2439 /* TO DO : to be revisited when needed */
2440 return false;
2441 #else
2442 return false;
2443 #endif
2444 return false;
2445 }
2446
2447 DTYPE
get_return_dtype(DTYPE dtype,unsigned * flags,unsigned new_flag)2448 get_return_dtype(DTYPE dtype, unsigned *flags, unsigned new_flag)
2449 {
2450 #ifdef TARGET_LLVM_ARM
2451 if (!small_aggr_return(dtype)) {
2452 if (is_struct_kind(dtype, !XBIT(121, 0x400000), true)) {
2453 if (flags)
2454 *flags |= new_flag;
2455 return DT_VOID_NONE;
2456 }
2457 } else {
2458 switch (ZSIZEOF(dtype)) {
2459 case 1:
2460 return DT_SBYTE;
2461 case 2:
2462 return DT_SINT;
2463 case 3:
2464 case 4:
2465 return DT_INT;
2466 default:
2467 assert(0, "get_return_dtype(): bad return dtype size for small struct",
2468 ZSIZEOF(dtype), ERR_Fatal);
2469 }
2470 }
2471 #else /* !TARGET_LLVM_ARM */
2472 if (is_struct_kind(dtype, !XBIT(121, 0x400000), true)) {
2473 if (flags)
2474 *flags |= new_flag;
2475 return DT_VOID_NONE;
2476 }
2477 #endif /* TARGET_LLVM_ARM */
2478 if (DT_ISCMPLX(dtype))
2479 return DT_NONE;
2480 if (XBIT(121, 0x400000) && DTY(dtype) == TY_CMPLX)
2481 return DT_INT8;
2482 return dtype;
2483 }
2484
2485 DTYPE
get_param_equiv_dtype(DTYPE dtype)2486 get_param_equiv_dtype(DTYPE dtype)
2487 {
2488 #ifdef TARGET_LLVM_ARM
2489 if (DTY(dtype) == TY_VECT) {
2490 switch (ZSIZEOF(dtype)) {
2491 case 1:
2492 return DT_BINT;
2493 case 2:
2494 return DT_SINT;
2495 case 3:
2496 case 4:
2497 return DT_INT;
2498 }
2499 }
2500 #endif
2501 return dtype;
2502 }
2503
2504 /**
2505 \brief return string for a first class type
2506 */
2507 char *
llvm_fc_type(DTYPE dtype)2508 llvm_fc_type(DTYPE dtype)
2509 {
2510 char *retc;
2511 ISZ_T sz;
2512
2513 switch (DTY(dtype)) {
2514 case TY_NONE:
2515 retc = "void"; /* TODO need to check where it is be used */
2516 break;
2517 case TY_INT:
2518 case TY_UINT:
2519 case TY_LOG:
2520 case TY_DWORD:
2521 sz = size_of(dtype);
2522 if (sz == 4)
2523 retc = "i32";
2524 else if (sz == 8)
2525 retc = "i64";
2526 else
2527 assert(0, "llvm_fc_type(): incompatible size", sz, ERR_Fatal);
2528 break;
2529
2530 case TY_CHAR:
2531 retc = "i8";
2532 break;
2533 case TY_NCHAR:
2534 retc = "i16";
2535 break;
2536 case TY_BINT:
2537 case TY_BLOG:
2538 retc = "i8";
2539 break;
2540 case TY_SINT:
2541 case TY_SLOG:
2542 case TY_WORD:
2543 retc = "i16";
2544 /* retc = "i16 signext"; */
2545 break;
2546 case TY_USINT:
2547 retc = "i16";
2548 /* retc = "i16 zeroext"; */
2549 break;
2550 case TY_FLOAT:
2551 retc = "float";
2552 break;
2553 case TY_DBLE:
2554 case TY_QUAD:
2555 retc = "double";
2556 break;
2557 case TY_FLOAT128:
2558 case TY_128:
2559 retc = "fp128";
2560 break;
2561 case TY_CMPLX128:
2562 retc = "{fp128, fp128}";
2563 break;
2564 case TY_INT8:
2565 case TY_UINT8:
2566 case TY_LOG8:
2567 retc = "i64";
2568 break;
2569 case TY_LOG128:
2570 case TY_INT128:
2571 retc = "i128";
2572 break;
2573 case TY_DCMPLX:
2574 retc = "{double, double}";
2575 break;
2576 case TY_CMPLX:
2577 retc = "{float, float}";
2578 break;
2579 case -TY_UNION:
2580 retc = "union";
2581 break;
2582 case -TY_STRUCT:
2583 retc = "struct";
2584 break;
2585 default:
2586 DBGTRACE2("###llvm_fc_type(): unhandled data type: %ld (%s), might not be "
2587 "first class ?",
2588 DTY(dtype), (stb.tynames[DTY(dtype)]))
2589 assert(0, "llvm_fc_type: unhandled data type", DTY(dtype), ERR_Fatal);
2590 break;
2591 }
2592 return retc;
2593 } /* llvm_fc_type */
2594
2595 OPERAND *
gen_copy_op(OPERAND * op)2596 gen_copy_op(OPERAND *op)
2597 {
2598 OPERAND *copy_operand;
2599
2600 copy_operand = make_operand();
2601 memmove(copy_operand, op, sizeof(OPERAND));
2602 copy_operand->next = NULL;
2603 return copy_operand;
2604 }
2605
2606 OPERAND *
gen_copy_list_op(OPERAND * operands)2607 gen_copy_list_op(OPERAND *operands)
2608 {
2609 OPERAND *list_op = NULL, *prev_op = NULL;
2610
2611 if (operands) {
2612 list_op = gen_copy_op(operands);
2613 prev_op = list_op;
2614 operands = operands->next;
2615 }
2616 while (operands) {
2617 prev_op->next = gen_copy_op(operands);
2618 prev_op = prev_op->next;
2619 operands = operands->next;
2620 }
2621 return list_op;
2622 }
2623
2624 static LLDEF *
make_def(DTYPE dtype,int sptr,int rank,char * name,int flags)2625 make_def(DTYPE dtype, int sptr, int rank, char *name, int flags)
2626 {
2627 LLDEF *new_def;
2628
2629 new_def = (LLDEF *)llutil_alloc(sizeof(LLDEF));
2630 new_def->dtype = dtype;
2631 new_def->ll_type = NULL;
2632 new_def->sptr = sptr;
2633 new_def->rank = rank;
2634 new_def->flags = flags;
2635 new_def->printed = 0;
2636 new_def->name = name;
2637 new_def->addrspace = 0;
2638 new_def->values = NULL;
2639 new_def->next = NULL;
2640 return new_def;
2641 }
2642
2643 static LLDEF *
get_def(DTYPE dtype,int sptr,int rank,LLDEF * def_list)2644 get_def(DTYPE dtype, int sptr, int rank, LLDEF *def_list)
2645 {
2646 LLDEF *p_def;
2647
2648 p_def = def_list;
2649 while (p_def != NULL) {
2650 if (p_def->dtype == dtype && p_def->sptr == sptr && p_def->rank == rank)
2651 break;
2652 p_def = p_def->next;
2653 }
2654 return p_def;
2655 }
2656
2657 #ifdef TARGET_LLVM_ARM
2658 void
write_alt_struct_def(LLDEF * def)2659 write_alt_struct_def(LLDEF *def)
2660 {
2661 char buf[80];
2662 DTYPE dtype = def->dtype;
2663 int struct_sz, field_count, field_sz;
2664
2665 print_token(def->name);
2666 print_token(".alt = type ");
2667 if (ZSIZEOF(def->dtype) == 0) {
2668 print_token("opaque");
2669 print_nl();
2670 return;
2671 }
2672 print_token("< { ");
2673 struct_sz = ZSIZEOF(dtype);
2674 if (DTyAlgTyAlign(dtype) > 3)
2675 field_sz = 8;
2676 else
2677 field_sz = 4;
2678 while (field_sz && struct_sz) {
2679 int field_count = struct_sz / field_sz;
2680 struct_sz = struct_sz & (field_sz - 1);
2681 if (field_count > 0) {
2682 sprintf(buf, "[%d x i%d]", field_count, field_sz * 8);
2683 print_token(buf);
2684 }
2685 field_sz >>= 1;
2686 if (field_count && struct_sz)
2687 print_token(", ");
2688 }
2689 print_token(" } >");
2690 print_nl();
2691 }
2692 #endif
2693
2694 /*
2695 * Write out an initializer of the given type, consuming as many operands from
2696 * the def_op chain as required.
2697 *
2698 * Return the first unused def_op operand.
2699 */
2700 static OPERAND *
write_def_values(OPERAND * def_op,LL_Type * type)2701 write_def_values(OPERAND *def_op, LL_Type *type)
2702 {
2703 int i;
2704
2705 if (def_op == NULL) {
2706 print_token(type->str);
2707 print_token(" undef");
2708 return NULL;
2709 }
2710
2711 switch (type->data_type) {
2712 case LL_I1:
2713 case LL_I8:
2714 case LL_I16:
2715 case LL_I24:
2716 case LL_I32:
2717 case LL_I40:
2718 case LL_I48:
2719 case LL_I56:
2720 case LL_I64:
2721 case LL_I128:
2722 case LL_I256:
2723 case LL_HALF:
2724 case LL_FLOAT:
2725 case LL_DOUBLE:
2726 case LL_FP128:
2727 case LL_X86_FP80:
2728 case LL_PPC_FP128:
2729 case LL_PTR:
2730 print_token(type->str);
2731 print_token(" ");
2732 write_operand(def_op, "", FLG_OMIT_OP_TYPE);
2733 return def_op->next;
2734
2735 case LL_ARRAY:
2736 print_token(type->str);
2737 if (def_op->ot_type == OT_CONSTSTRING && type->data_type == LL_ARRAY &&
2738 (type->sub_types[0]->data_type == LL_I8 ||
2739 type->sub_types[0]->data_type == LL_I16)) {
2740 print_token(" ");
2741 write_operand(def_op, "", FLG_OMIT_OP_TYPE);
2742 def_op = def_op->next;
2743 return def_op;
2744 }
2745 print_token(" [ ");
2746 for (i = 0; i < type->sub_elements; i++) {
2747 if (i)
2748 print_token(", ");
2749 def_op = write_def_values(def_op, type->sub_types[0]);
2750 }
2751 print_token(" ] ");
2752 return def_op;
2753
2754 case LL_VECTOR:
2755 print_token(type->str);
2756 print_token(" < ");
2757 for (i = 0; i < type->sub_elements; i++) {
2758 if (i)
2759 print_token(", ");
2760 assert(def_op, "write_def_values(): missing def for type", 0, ERR_Fatal);
2761 def_op = write_def_values(def_op, type->sub_types[0]);
2762 }
2763 print_token(" > ");
2764 return def_op;
2765
2766 case LL_STRUCT:
2767 print_token(type->str);
2768 if (type->flags & LL_TYPE_IS_PACKED_STRUCT)
2769 print_token(" <{ ");
2770 else
2771 print_token(" { ");
2772 for (i = 0; i < type->sub_elements; i++) {
2773 if (i)
2774 print_token(", ");
2775 def_op = write_def_values(def_op, type->sub_types[i]);
2776 }
2777 if (type->flags & LL_TYPE_IS_PACKED_STRUCT)
2778 print_token(" }>");
2779 else
2780 print_token(" }");
2781 return def_op;
2782
2783 default:
2784 interr("write_def_values(): unknown datatype", type->data_type, ERR_Fatal);
2785 }
2786 return NULL;
2787 }
2788
2789 static void
write_alt_field_types(LL_Type * llty)2790 write_alt_field_types(LL_Type *llty)
2791 {
2792 if (llty->sub_elements > 0) {
2793 int i;
2794 int I = llty->sub_elements - 1;
2795
2796 for (i = 0; i < I; ++i) {
2797 print_token(llty->sub_types[i]->str);
2798 print_token(", ");
2799 }
2800 print_token(llty->sub_types[I]->str);
2801 }
2802 }
2803
2804 static void
write_def(LLDEF * def,int check_type_in_struct_def_type)2805 write_def(LLDEF *def, int check_type_in_struct_def_type)
2806 {
2807 char buf[80];
2808 DTYPE dtype = def->dtype;
2809 LLDEF *lltypedef = NULL;
2810
2811 print_token(def->name);
2812 print_token(" = ");
2813 if (check_type_in_struct_def_type && def->dtype) {
2814 lltypedef = get_def(def->dtype, 0, 0, struct_def_list);
2815 }
2816 if (def->flags & LLDEF_IS_TYPE) {
2817 print_token("type ");
2818 if (def->flags & LLDEF_IS_EMPTY) {
2819 print_token("<{ }>");
2820 print_nl();
2821 return;
2822 }
2823 if(def->flags & LLDEF_IS_UNPACKED_STRUCT)
2824 print_token("{ ");
2825 else
2826 print_token("<{ ");
2827 write_alt_field_types(def->ll_type);
2828 if(def->flags & LLDEF_IS_UNPACKED_STRUCT)
2829 print_token("} ");
2830 else
2831 print_token("}> ");
2832 } else {
2833 char buf[50];
2834 if (def->flags & LLDEF_IS_EXTERNAL)
2835 sprintf(buf, "external addrspace(%d) global ", def->addrspace);
2836 else if ((def->flags & LLDEF_IS_INITIALIZED) && (def->values != NULL) &&
2837 (def->flags & LLDEF_IS_ACCSTRING))
2838 sprintf(buf, "private addrspace(%d) constant ", def->addrspace);
2839 else if (def->flags & LLDEF_IS_STATIC)
2840 sprintf(buf, "internal addrspace(%d) global ", def->addrspace);
2841 else if ((def->flags & LLDEF_IS_INITIALIZED) && (def->values != NULL))
2842 sprintf(buf, "addrspace(%d) global ", def->addrspace);
2843 else if (def->flags & LLDEF_IS_CONST)
2844 sprintf(buf, "addrspace(%d) global ", def->addrspace);
2845 else
2846 sprintf(buf, "common addrspace(%d) global ", def->addrspace);
2847
2848 print_token(buf);
2849
2850 if ((def->flags & (LLDEF_IS_INITIALIZED | LLDEF_IS_EXTERNAL)) ==
2851 LLDEF_IS_INITIALIZED) {
2852 if (def->values != NULL) {
2853 write_def_values(def->values, def->ll_type);
2854 } else {
2855 write_type(def->ll_type);
2856 print_token(" zeroinitializer");
2857 }
2858 } else {
2859 if (lltypedef)
2860 print_token(lltypedef->name);
2861 else if (def->ll_type)
2862 write_type(def->ll_type);
2863 else
2864 write_type(make_lltype_from_dtype(def->dtype));
2865 if (def->flags & LLDEF_IS_STATIC)
2866 print_token(" zeroinitializer");
2867 }
2868 print_token(", align 16");
2869 }
2870
2871 print_nl();
2872 #ifdef TARGET_LLVM_ARM
2873 if (def->flags & LLDEF_IS_TYPE)
2874 write_alt_struct_def(def);
2875 #endif
2876 }
2877
2878 static void
write_defs(LLDEF * def_list,int check_type_in_struct_def_type)2879 write_defs(LLDEF *def_list, int check_type_in_struct_def_type)
2880 {
2881 LLDEF *cur_def;
2882
2883 cur_def = def_list;
2884 print_nl();
2885 while (cur_def) {
2886 if (!cur_def->printed) {
2887 write_def(cur_def, check_type_in_struct_def_type);
2888 cur_def->printed = 1;
2889 }
2890 cur_def = cur_def->next;
2891 }
2892 print_nl();
2893 }
2894
2895 /* Check whethere there are any definitons to write
2896 * @param def_list -- definition list
2897 * @return true if there is any entry with printed==0, false if all are printed
2898 * or the list is empty
2899 */
2900 static bool
defs_to_write(LLDEF * def_list)2901 defs_to_write(LLDEF *def_list)
2902 {
2903 LLDEF *cur_def;
2904 if (!def_list)
2905 return false;
2906
2907 cur_def = def_list;
2908 while (cur_def) {
2909 if (!cur_def->printed) {
2910 return true;
2911 }
2912 cur_def = cur_def->next;
2913 }
2914 return false;
2915 }
2916
2917 /* Write structure definitions to the output LLVM file */
2918 void
write_struct_defs(void)2919 write_struct_defs(void)
2920 {
2921 write_defs(struct_def_list, 0);
2922 /* Keep on processing list of structure defs until it stops changing
2923 */
2924 while (defs_to_write(struct_def_list)) {
2925 write_defs(struct_def_list, 0);
2926 }
2927 }
2928
2929 void
write_ftn_typedefs(void)2930 write_ftn_typedefs(void)
2931 {
2932 LLDEF *cur_def;
2933 int gblsym;
2934
2935 cur_def = struct_def_list;
2936 while (cur_def) {
2937 if (!cur_def->printed && cur_def->name && cur_def->dtype) {
2938 gblsym = get_typedef_ag(cur_def->name,
2939 process_dtype_struct(cur_def->dtype));
2940 if (gblsym == 0) {
2941 write_def(cur_def, 0);
2942 }
2943 cur_def->printed = 1;
2944 }
2945 cur_def = cur_def->next;
2946 }
2947 }
2948
2949 DTYPE
get_int_dtype_from_size(int size)2950 get_int_dtype_from_size(int size)
2951 {
2952 switch (size) {
2953 case 1:
2954 return DT_BINT;
2955 break;
2956 case 2:
2957 return DT_SINT;
2958 case 4:
2959 return DT_INT;
2960 case 8:
2961 return DT_INT8;
2962 }
2963 return DT_NONE;
2964 }
2965
2966 static int
struct_typedef_name(DTYPE dtype)2967 struct_typedef_name(DTYPE dtype)
2968 {
2969 int sptr;
2970
2971 for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) {
2972 if (STYPEG(sptr) == ST_TYPEDEF && DTYPEG(sptr) == dtype)
2973 return sptr;
2974 }
2975 return 0;
2976 } /* struct_typedef_name */
2977
2978 static char *
def_name(DTYPE dtype,int tag)2979 def_name(DTYPE dtype, int tag)
2980 {
2981 char *tag_name;
2982 char *d_name;
2983 char buf[200];
2984 char idbuf[MAXIDLEN];
2985 static int count = 0;
2986 int tag_len = 0;
2987
2988 if (tag) {
2989 tag_name = getprint(tag);
2990 } else {
2991 tag = struct_typedef_name(dtype);
2992 if (tag) {
2993 tag_name = getprint(tag);
2994 } else {
2995 sprintf(buf, "_anon%d", count++);
2996 tag_name = buf;
2997 }
2998 }
2999 if (tag) {
3000 sprintf(idbuf, "%d_%d", dtype, tag);
3001 tag_len = strlen(idbuf) + 1;
3002 }
3003 tag_len += strlen(tag_name) + 10;
3004 d_name = (char *)llutil_alloc(tag_len * sizeof(char));
3005 if (tag)
3006 sprintf(d_name, "%%struct.%s.%s", tag_name, idbuf);
3007 else
3008 sprintf(d_name, "%%struct.%s", tag_name);
3009 return d_name;
3010 }
3011
3012 OPERAND *
process_symlinked_sptr(int sptr,int total_init_sz,int is_union,int max_field_sz)3013 process_symlinked_sptr(int sptr, int total_init_sz, int is_union,
3014 int max_field_sz)
3015 {
3016 OPERAND *cur_op;
3017 OPERAND head;
3018 int pad, field_sz, sptr_sz, max_sz, update_union;
3019 int cur_addr, prev_addr, base_addr;
3020 OPERAND *union_from = NULL, *union_to = NULL;
3021 int total_field_sz;
3022
3023 if (sptr > NOSYM)
3024 prev_addr = ADDRESSG(sptr);
3025 field_sz = 0;
3026 max_sz = 0;
3027 update_union = 0;
3028 pad = 0;
3029 head.next = 0;
3030 cur_op = &head;
3031 while (sptr > NOSYM) {
3032 if (POINTERG(sptr)) {
3033 sptr = SYMLKG(sptr);
3034 continue;
3035 }
3036 cur_addr = ADDRESSG(sptr);
3037 if (cur_addr > prev_addr) {
3038 while (prev_addr < cur_addr) {
3039 cur_op->next = make_member_op(prev_addr, get_int_dtype_from_size(1));
3040 cur_op = cur_op->next;
3041 prev_addr++;
3042 pad++;
3043 }
3044 }
3045 {
3046 if (DDTG(DTYPEG(sptr)) == DT_ASSCHAR ||
3047 DDTG(DTYPEG(sptr)) == DT_DEFERCHAR)
3048 sptr_sz = ZSIZEOF(DT_ADDR);
3049 else
3050 sptr_sz = ZSIZEOF(DTYPEG(sptr));
3051 pad += sptr_sz;
3052 cur_op->next = make_member_op(prev_addr, DTYPEG(sptr));
3053 if (sptr_sz > max_sz) {
3054 max_sz = sptr_sz;
3055 union_from = union_to = cur_op->next;
3056 }
3057 cur_op = cur_op->next;
3058 if (DDTG(DTYPEG(sptr)) == DT_ASSCHAR ||
3059 DDTG(DTYPEG(sptr)) == DT_DEFERCHAR)
3060 prev_addr = cur_addr + ZSIZEOF(DT_ADDR);
3061 else
3062 prev_addr = cur_addr + ZSIZEOF(DTYPEG(sptr));
3063 sptr = SYMLKG(sptr);
3064 }
3065 }
3066 if (is_union && max_sz) {
3067 cur_op = union_to;
3068 union_to->next = NULL;
3069 head.next = union_from;
3070 pad = total_init_sz - max_sz;
3071 } else {
3072 pad = total_init_sz - pad;
3073 }
3074 if (pad > 8) {
3075 LL_Type *i8 = ll_create_int_type(llvm_get_current_module(), 8);
3076 LL_Type *arr = ll_get_array_type(i8, pad, 0);
3077 cur_op->next = make_member_op_with_lltype(prev_addr, arr);
3078 } else {
3079 while (pad > 0) {
3080 cur_op->next = make_member_op(prev_addr, get_int_dtype_from_size(1));
3081 cur_op = cur_op->next;
3082 prev_addr++;
3083 pad--;
3084 }
3085 }
3086 return head.next;
3087 }
3088
3089 char *
process_dtype_struct(DTYPE dtype)3090 process_dtype_struct(DTYPE dtype)
3091 {
3092 char *d_name;
3093 SPTR tag;
3094 TY_KIND dty;
3095 LLDEF *def;
3096 #ifdef OMP_OFFLOAD_LLVM
3097 //bool is_omptarget_type = (bool)OMPACCSTRUCTG(DTY((DTYPE)(dtype + 3)));
3098 bool is_omptarget_type = DTyArgNext(dtype);
3099 #endif
3100 dty = DTY(dtype);
3101 def = get_def(dtype, 0, 0, struct_def_list);
3102 if (dty != TY_UNION && dty != TY_STRUCT && def == NULL)
3103 return NULL;
3104 tag = DTyAlgTyTag(dtype);
3105
3106 DBGTRACEIN1(" called with dtype %d\n", dtype)
3107
3108 /* if already computed, just return */
3109 if (def != NULL) {
3110 DBGTRACEOUT1(" returns %s", def->name)
3111 return def->name;
3112 }
3113 /* Use consistent struct type names. */
3114 d_name = (char *)ll_convert_struct_dtype(llvm_get_current_module(), dtype)->str;
3115 if (ZSIZEOF(dtype) == 0 && DTyAlgTyMember(dtype) == 0)
3116 def = make_def(dtype, 0, 0, d_name,
3117 LLDEF_IS_TYPE | LLDEF_IS_EMPTY | LLDEF_IS_STRUCT);
3118 #ifdef OMP_OFFLOAD_LLVM
3119 else if(is_omptarget_type)
3120 def = make_def(dtype, 0, 0, d_name, LLDEF_IS_TYPE | LLDEF_IS_UNPACKED_STRUCT);
3121 #endif
3122 else
3123 def = make_def(dtype, 0, 0, d_name, LLDEF_IS_TYPE | LLDEF_IS_STRUCT);
3124 add_def(def, &struct_def_list);
3125 /* if empty (extended) type - don't call process_symlinked_sptr -> oop508 */
3126 if (is_empty_typedef(dtype))
3127 def->values = 0;
3128 def->values = process_symlinked_sptr(
3129 DTyAlgTyMember(dtype), ZSIZEOF(dtype), (dty == TY_UNION),
3130 (DTyAlgTyAlign(dtype) + 1) * 8);
3131 DBGTRACEOUT1(" returns %s", def->name);
3132
3133 return def->name;
3134 }
3135
3136 /**
3137 \brief Make a fake struct for static/common block
3138
3139 This differs from process_dtype_struct and that it overrides the unique name
3140 generated by ll_convert_struct_dtype().
3141
3142 The printed flag tells write_ftn_typedefs that this type has already been
3143 printed out to the .ll output file. If true, write_ftn_typedefs() will not
3144 print the type out (assuming that it has already been 'printed').
3145 */
3146 char *
process_ftn_dtype_struct(DTYPE dtype,char * tname,bool printed)3147 process_ftn_dtype_struct(DTYPE dtype, char *tname, bool printed)
3148 {
3149 int tag;
3150 TY_KIND dty;
3151 char *d_name;
3152 LLDEF *def;
3153
3154 dty = DTY(dtype);
3155 def = get_def(dtype, 0, 0, struct_def_list);
3156 if (dty != TY_UNION && dty != TY_STRUCT && def == NULL)
3157 return NULL;
3158 tag = DTyAlgTyTag(dtype);
3159
3160 DBGTRACEIN1(" called with dtype %d\n", dtype)
3161
3162 d_name = (char *)llutil_alloc(strlen(tname) + 2);
3163 sprintf(d_name, "%%%s", tname);
3164
3165 /* if already computed, just return */
3166 if (def != NULL) {
3167 DBGTRACEOUT1(" returns %s", def->name)
3168 return def->name;
3169 }
3170
3171 if (ZSIZEOF(dtype) == 0)
3172 def = make_def(dtype, 0, 0, d_name,
3173 LLDEF_IS_TYPE | LLDEF_IS_EMPTY | LLDEF_IS_STRUCT);
3174 else
3175 def = make_def(dtype, 0, 0, d_name, LLDEF_IS_TYPE | LLDEF_IS_STRUCT);
3176 add_def(def, &struct_def_list);
3177 def->values = process_symlinked_sptr(
3178 DTyAlgTyMember(dtype), ZSIZEOF(dtype), (dty == TY_UNION),
3179 (DTyAlgTyAlign(dtype) + 1) * 8);
3180 def->printed = printed;
3181 ll_override_type_string(def->ll_type, d_name);
3182 DBGTRACEOUT1(" returns %s", def->name)
3183 return def->name;
3184 }
3185
3186 static OPERAND *
add_init_zero_const_op(int sptr,OPERAND * cur_op,ISZ_T * offset,ISZ_T * lastoffset)3187 add_init_zero_const_op(int sptr, OPERAND *cur_op, ISZ_T *offset,
3188 ISZ_T *lastoffset)
3189 {
3190 DTYPE dtype;
3191 ISZ_T address;
3192
3193 dtype = DTYPEG(sptr);
3194 address = ADDRESSG(sptr);
3195 cur_op->next = make_constval_op(make_lltype_from_dtype(dtype), 0, 0);
3196 if (lastoffset)
3197 *lastoffset = address + ZSIZEOF(dtype);
3198 *offset = address;
3199 return cur_op->next;
3200 }
3201
3202 static OPERAND *
add_init_const_op(DTYPE dtype,OPERAND * cur_op,ISZ_T conval,ISZ_T * repeat_cnt,ISZ_T * offset)3203 add_init_const_op(DTYPE dtype, OPERAND *cur_op, ISZ_T conval, ISZ_T *repeat_cnt,
3204 ISZ_T *offset)
3205 {
3206 ISZ_T address;
3207 const SPTR convalSptr = (SPTR)conval;
3208
3209 address = *offset;
3210 switch (dtype) {
3211 case 0:
3212 /* alignment record? */
3213 interr("cf_data_init: unexpected alignment", 0, ERR_Fatal);
3214 break;
3215 case DINIT_ZEROES:
3216 /* output zeroes */
3217 interr("cf_data_init: unexpected zeroes", 0, ERR_Fatal);
3218 break;
3219 case DINIT_LABEL:
3220 /* initialize to address */
3221 cur_op->next = make_var_op(convalSptr);
3222 cur_op = cur_op->next;
3223 address += size_of(DT_CPTR);
3224 break;
3225 #ifdef DINIT_OFFSET
3226 case DINIT_OFFSET:
3227 interr("cf_data_init: unexpected offset", 0, ERR_Fatal);
3228 break;
3229 #endif
3230 #ifdef DINIT_REPEAT
3231 case DINIT_REPEAT:
3232 *repeat_cnt = conval;
3233 break;
3234 #endif
3235 #ifdef DINIT_STRING
3236 case DINIT_STRING:
3237 interr("cf_data_init: unexpected string", 0, ERR_Fatal);
3238 break;
3239 #endif
3240 default:
3241 if (!DTyValidRange(dtype))
3242 interr("cf_data_init: unknown datatype", dtype, ERR_Fatal);
3243 do {
3244 switch (DTY(dtype)) {
3245 case TY_INT8:
3246 case TY_LOG8:
3247 cur_op->next = make_constval_op(make_lltype_from_dtype(dtype),
3248 CONVAL2G(conval), CONVAL1G(conval));
3249 cur_op = cur_op->next;
3250 address += 8;
3251 break;
3252 case TY_INT:
3253 case TY_UINT:
3254 case TY_LOG:
3255 case TY_SINT:
3256 case TY_SLOG:
3257 case TY_BINT:
3258 case TY_BLOG:
3259 case TY_FLOAT:
3260 cur_op->next =
3261 make_constval_op(make_lltype_from_dtype(dtype), conval, 0);
3262 cur_op = cur_op->next;
3263 address += size_of(dtype);
3264 break;
3265 case TY_128:
3266 break;
3267 case TY_DBLE:
3268 cur_op->next = make_constval_op(make_lltype_from_dtype(dtype),
3269 CONVAL1G(conval), CONVAL2G(conval));
3270 cur_op = cur_op->next;
3271 address += 8;
3272 break;
3273 case TY_CMPLX:
3274 cur_op->next = make_constval_op(make_lltype_from_dtype(DT_FLOAT),
3275 CONVAL1G(conval), 0);
3276 cur_op->next->next = make_constval_op(make_lltype_from_dtype(DT_FLOAT),
3277 CONVAL2G(conval), 0);
3278 cur_op = cur_op->next->next;
3279 address += 8;
3280 break;
3281 #ifdef LONG_DOUBLE_FLOAT128
3282 case TY_FLOAT128:
3283 cur_op->next->next = make_constval_opL(
3284 make_lltype_from_dtype(DT_FLOAT128), CONVAL1G(conval),
3285 CONVAL2G(conval), CONVAL3G(conval), CONVAL4G(conval));
3286 cur_op = cur_op->next->next;
3287 address += 16;
3288 break;
3289 #endif
3290 case TY_DCMPLX:
3291 cur_op->next = make_constval_op(make_lltype_from_dtype(DT_DBLE),
3292 CONVAL2G(CONVAL1G(conval)),
3293 CONVAL1G(CONVAL1G(conval)));
3294 cur_op->next->next = make_constval_op(make_lltype_from_dtype(DT_DBLE),
3295 CONVAL2G(CONVAL2G(conval)),
3296 CONVAL1G(CONVAL2G(conval)));
3297 cur_op = cur_op->next->next;
3298 address += 16;
3299 break;
3300 case TY_CHAR:
3301 address += DTyCharLength(DTYPEG(conval));
3302 if (STYPEG(conval) == ST_CONST)
3303 cur_op->next = make_conststring_op(conval);
3304 else
3305 cur_op->next = make_constsptr_op(convalSptr);
3306 cur_op = cur_op->next;
3307 break;
3308 case TY_NCHAR:
3309 address += DTyCharLength(DTYPEG(conval));
3310 if (STYPEG(conval) == ST_CONST)
3311 cur_op->next = make_conststring_op(conval);
3312 else
3313 cur_op->next = make_constsptr_op(convalSptr);
3314 cur_op = cur_op->next;
3315 break;
3316 case TY_PTR:
3317 /* almost always a null pointer */
3318 if (DT_ISINT(DTYPEG(conval))) {
3319 cur_op->next = make_constval_op(make_lltype_from_dtype(dtype),
3320 CONVAL2G(conval), CONVAL1G(conval));
3321 cur_op = cur_op->next;
3322 address += size_of(dtype);
3323 } else {
3324 interr("process_acc_put_dinit: unexpected datatype", dtype, ERR_Fatal);
3325 }
3326 break;
3327 default:
3328 interr("process_acc_put_dinit: unexpected datatype", dtype, ERR_Fatal);
3329 break;
3330 }
3331 } while (--*repeat_cnt);
3332 *repeat_cnt = 1;
3333 break;
3334 }
3335 *offset = address;
3336 return cur_op;
3337 }
3338
3339 static OPERAND *
add_init_pad(OPERAND * cur_op,ISZ_T sz)3340 add_init_pad(OPERAND *cur_op, ISZ_T sz)
3341 {
3342 while (sz > 0) {
3343 cur_op->next = make_constval_op(
3344 make_lltype_from_dtype(get_int_dtype_from_size(1)), 0, 0);
3345 cur_op = cur_op->next;
3346 sz--;
3347 }
3348 return cur_op;
3349 }
3350
3351 static OPERAND *
add_init_subzero_consts(DTYPE dtype,OPERAND * cur_op,ISZ_T * offset,ISZ_T lastoffset)3352 add_init_subzero_consts(DTYPE dtype, OPERAND *cur_op, ISZ_T *offset,
3353 ISZ_T lastoffset)
3354 {
3355 ISZ_T sz;
3356 DTYPE ddtype;
3357 int mem;
3358 DTYPE memdtype;
3359 ISZ_T address;
3360 LL_Type* llddtype;
3361
3362 address = *offset;
3363 switch (DTY(dtype)) {
3364 case TY_ARRAY:
3365 sz = ZSIZEOF(dtype);
3366 if (lastoffset - address >= sz) {
3367 cur_op->next = make_constval_op(make_lltype_from_dtype(dtype), 0, 0);
3368 *offset = address + sz;
3369 return cur_op->next;
3370 }
3371 /* only part of the array */
3372 ddtype = DTySeqTyElement(dtype);
3373 sz = size_of(ddtype);
3374 if (lastoffset - address < sz) {
3375 /* Less than size of one element, we are partially initializing an element
3376 * of array of struct */
3377 return add_init_subzero_consts(ddtype, cur_op, offset, lastoffset);
3378 }
3379 while (address < lastoffset) {
3380 cur_op->next = make_constval_op(make_lltype_from_dtype(ddtype), 0, 0);
3381 cur_op = cur_op->next;
3382 address += sz;
3383 }
3384 *offset = address;
3385 return cur_op;
3386 case TY_CHAR:
3387 sz = DTyCharLength(dtype);
3388 llddtype = make_lltype_from_dtype(DT_BINT);
3389 while (address < lastoffset) {
3390 cur_op->next = make_constval_op(llddtype, 0, 0);
3391 cur_op = cur_op->next;
3392 address += 1;
3393 }
3394 *offset = address;
3395 return cur_op;
3396 case TY_STRUCT:
3397 mem = DTyAlgTyMember(dtype);
3398 while (ADDRESSG(mem) < address && mem > NOSYM)
3399 mem = SYMLKG(mem);
3400 if (mem > NOSYM) {
3401 if (address > ADDRESSG(mem)) {
3402 memdtype = DTYPEG(mem);
3403 sz = size_of(memdtype);
3404 address = 0;
3405 cur_op = add_init_subzero_consts(DTYPEG(mem), cur_op, &address,
3406 lastoffset - ADDRESSG(mem));
3407 if (address == lastoffset) {
3408 *offset = address;
3409 return cur_op;
3410 }
3411 if (address >= ADDRESSG(mem) + sz)
3412 mem = SYMLKG(mem);
3413 } else if (address < ADDRESSG(mem)) {
3414 if (lastoffset <= ADDRESSG(mem)) {
3415 cur_op = add_init_pad(cur_op, lastoffset - address);
3416 *offset = lastoffset;
3417 return cur_op;
3418 } else {
3419 cur_op = add_init_pad(cur_op, ADDRESSG(mem) - address);
3420 address = ADDRESSG(mem);
3421 }
3422 }
3423 }
3424 if (mem > NOSYM) {
3425 memdtype = DTYPEG(mem);
3426 sz = size_of(memdtype);
3427 while (mem > NOSYM && ADDRESSG(mem) + sz <= lastoffset) {
3428 cur_op = add_init_subzero_consts(DTYPEG(mem), cur_op, &address,
3429 lastoffset - ADDRESSG(mem));
3430 mem = SYMLKG(mem);
3431 memdtype = DTYPEG(mem);
3432 sz = size_of(memdtype);
3433 }
3434 }
3435 if (address < lastoffset) {
3436 if (mem == NOSYM || ADDRESSG(mem) == lastoffset) {
3437 cur_op = add_init_pad(cur_op, lastoffset - address);
3438 address = lastoffset;
3439 } else {
3440 address = 0;
3441 cur_op = add_init_subzero_consts(DTYPEG(mem), cur_op, &address,
3442 lastoffset - ADDRESSG(mem));
3443 }
3444 }
3445 *offset = address;
3446 return cur_op;
3447 default:
3448 sz = size_of(dtype);
3449 cur_op->next = make_constval_op(make_lltype_from_dtype(dtype), 0, 0);
3450 cur_op = cur_op->next;
3451 *offset = address + sz;
3452 }
3453 return cur_op;
3454 }
3455
3456 /* Allocate an LL_ABI_Info object with room for nargs arguments. */
3457 LL_ABI_Info *
ll_abi_alloc(LL_Module * module,unsigned nargs)3458 ll_abi_alloc(LL_Module *module, unsigned nargs)
3459 {
3460 LL_ABI_Info *abi = (LL_ABI_Info*)calloc(
3461 1, sizeof(LL_ABI_Info) + nargs * sizeof(LL_ABI_ArgInfo));
3462 abi->module = module;
3463 abi->nargs = nargs;
3464 return abi;
3465 }
3466
3467 /* Reclaim: Returns NULL, just to discourage dangling pointers */
3468 LL_ABI_Info *
ll_abi_free(LL_ABI_Info * abi)3469 ll_abi_free(LL_ABI_Info *abi)
3470 {
3471 #if DEBUG
3472 assert(abi, "No abi to free", 0, ERR_Fatal);
3473 memset(abi, 0, sizeof(LL_ABI_Info) + (abi->nargs * sizeof(LL_ABI_ArgInfo)));
3474 #endif
3475 free(abi);
3476 return NULL;
3477 }
3478
3479 LL_Type *
ll_abi_return_type(LL_ABI_Info * abi)3480 ll_abi_return_type(LL_ABI_Info *abi)
3481 {
3482 if (LL_ABI_HAS_SRET(abi))
3483 return ll_create_basic_type(abi->module, LL_VOID, 0);
3484 else
3485 return abi->arg[0].type;
3486 }
3487
3488 bool
ll_abi_use_llvm_varargs(LL_ABI_Info * abi)3489 ll_abi_use_llvm_varargs(LL_ABI_Info *abi)
3490 {
3491 if (abi->is_varargs)
3492 return true;
3493
3494 if (abi->missing_prototype)
3495 return abi->call_as_varargs;
3496
3497 return false;
3498 }
3499
3500 LL_Type *
ll_abi_function_type(LL_ABI_Info * abi)3501 ll_abi_function_type(LL_ABI_Info *abi)
3502 {
3503 unsigned i;
3504 LL_Type **types, **argtypes;
3505 LL_Type *func_type;
3506
3507 /* Return type + optional sret + arguments. */
3508 types = (LL_Type **)calloc(abi->nargs + 2, sizeof(LL_Type *));
3509 argtypes = types;
3510
3511 /* Prepend a void return and make the return type in arg[0] an argument. */
3512 if (LL_ABI_HAS_SRET(abi))
3513 *argtypes++ = ll_create_basic_type(abi->module, LL_VOID, 0);
3514
3515 for (i = 0; i <= abi->nargs; i++)
3516 argtypes[i] = abi->arg[i].type;
3517
3518 func_type = ll_create_function_type(
3519 abi->module, types, LL_ABI_HAS_SRET(abi) ? abi->nargs + 1 : abi->nargs,
3520 ll_abi_use_llvm_varargs(abi));
3521
3522 free(types);
3523
3524 return func_type;
3525 }
3526
3527 void
ll_abi_complete_arg_info(LL_ABI_Info * abi,LL_ABI_ArgInfo * arg,DTYPE dtype)3528 ll_abi_complete_arg_info(LL_ABI_Info *abi, LL_ABI_ArgInfo *arg, DTYPE dtype)
3529 {
3530 LL_Type *type;
3531 enum LL_ABI_ArgKind kind = arg->kind;
3532
3533 if (arg->type)
3534 return;
3535
3536 assert(kind != LL_ARG_COERCE, "Missing coercion type", 0, ERR_Fatal);
3537
3538 type = ll_convert_dtype(abi->module, dtype);
3539 if (kind == LL_ARG_INDIRECT || kind == LL_ARG_BYVAL) {
3540 assert(type->data_type != LL_VOID,
3541 "ll_abi_complete_arg_info: void function argument", dtype,
3542 ERR_Fatal);
3543 type = ll_get_pointer_type(type);
3544 }
3545
3546 arg->type = type;
3547 }
3548
3549 /**
3550 \brief Process the return type and arguments for func_sptr
3551 \param mod
3552 \param func_sptr
3553 \param update flag for special handling
3554
3555 If the update flag is \c true, then the ABI is reconstructed from the AG
3556 table, taking into account any changes added to the AG table. Update also
3557 will set the sptrs which means that this routine should only be called with
3558 \c true when the sptrs are valid: (i.e., if this routine exists in the
3559 current module).
3560
3561 TODO: Rename this function since process_sptr is not called in here.
3562 */
3563 LL_ABI_Info *
process_ll_abi_func_ftn_mod(LL_Module * mod,SPTR func_sptr,bool update)3564 process_ll_abi_func_ftn_mod(LL_Module *mod, SPTR func_sptr, bool update)
3565 {
3566 int i, ty;
3567 DTYPE ret_dtype;
3568 char *param;
3569 LL_ABI_Info *abi;
3570 LL_Type *llt;
3571 int gblsym = 0;
3572 int iface = 0;
3573 unsigned nargs = 0;
3574 const int stype = STYPEG(func_sptr);
3575
3576 /* Find the number of arguments, if not found, check if this is an iface */
3577 if (stype == ST_ENTRY && (gblsym = find_ag(get_llvm_name(func_sptr)))) {
3578 nargs = get_ag_argdtlist_length(gblsym);
3579 } else if ((gblsym = find_ag(get_llvm_ifacenm(func_sptr)))) {
3580 iface = get_llvm_funcptr_ag(func_sptr, get_llvm_ifacenm(func_sptr));
3581 nargs = get_ag_argdtlist_length(iface);
3582 } else if ((gblsym = find_ag(get_llvm_name(func_sptr)))) {
3583 nargs = get_ag_argdtlist_length(gblsym);
3584 }
3585
3586 /* If we have already added this, and don't want to update, then return */
3587 abi = ll_proto_get_abi(ll_proto_key(func_sptr));
3588 if (!update && gblsym && abi) {
3589 return abi;
3590 } else if (!update && abi && stype == ST_PROC && !INMODULEG(func_sptr)) {
3591 return abi; /* We already have an abi */
3592 } else if (update && abi) {
3593 abi = ll_abi_free(abi);
3594 }
3595
3596 abi = ll_abi_alloc(mod, nargs);
3597 abi->is_fortran = true;
3598
3599 /* If fortran is calling an iso-c function */
3600 abi->is_iso_c = CFUNCG(func_sptr);
3601
3602 ll_abi_compute_call_conv(abi, func_sptr, 0);
3603
3604 /* Update the gblsym abi pointer */
3605 if (update)
3606 ll_proto_set_abi(ll_proto_key(func_sptr), abi);
3607
3608 /* External and never discovered arguments, then we will declare this as a
3609 * varargs function. When a call to this function is made, the callsite
3610 * args from the JSR/GJSR will be used and we will cast away the varargs.
3611 */
3612 /*
3613 * IS_INTERFACE check allows abstract interfaces which have INMODULE
3614 * bit set to pass through this check.
3615 */
3616 if (!nargs && (!INMODULEG(func_sptr) || IS_INTERFACEG(func_sptr)) &&
3617 (IS_FTN_PROC_PTR(func_sptr) || stype == ST_PROC)) {
3618 assert(IS_FTN_PROC_PTR(func_sptr) || SCG(func_sptr) == SC_EXTERN ||
3619 SCG(func_sptr) == SC_NONE || SCG(func_sptr) == SC_DUMMY ||
3620 STYPEG(func_sptr) == ST_PROC || STYPEG(func_sptr) == ST_ENTRY,
3621 "process_ll_abi_func_ftn: "
3622 "Unknown function prototype",
3623 func_sptr, ERR_Fatal);
3624 abi->missing_prototype = true;
3625 #if defined(TARGET_ARM)
3626 abi->call_as_varargs = false;
3627 #else
3628 abi->call_as_varargs = true;
3629 #endif
3630 }
3631
3632 /* Obtain, classify, and create an arg for the return value */
3633 ret_dtype = get_return_type(func_sptr);
3634 ty = DTY(ret_dtype);
3635 if (ty == TY_CHAR || ty == TY_NCHAR ||
3636 (TY_ISCMPLX(ty) && !CFUNCG(func_sptr) && !CMPLXFUNC_C))
3637 ret_dtype = DT_NONE;
3638
3639 #if defined(TARGET_LLVM_X8664)
3640 /* Workaround the X86 ABI */
3641 switch (ty) {
3642 case TY_SINT:
3643 case TY_USINT:
3644 case TY_SLOG:
3645 abi->extend_abi_return = !XBIT(183, 0x400000);
3646 break;
3647 default:
3648 break;
3649 }
3650 #endif
3651 ll_abi_classify_return_dtype(abi, ret_dtype);
3652 ll_abi_complete_arg_info(abi, &abi->arg[0], ret_dtype);
3653
3654 /* Override with a more correct type, to avoid using the
3655 * fortran-default float if that was specified in ret_dtype.
3656 * ll_process_routine_parameters() decides to override
3657 * (See ll_process_routine_parameters() where it calls
3658 * set_ag_return_lltype()).
3659 */
3660 if (gblsym && (llt = get_ag_return_lltype(gblsym)))
3661 abi->arg[0].type = llt;
3662
3663 /* Determine how each arg should be handled */
3664 if (!abi->missing_prototype) {
3665 for (i = 1, param = get_argdtlist(gblsym); param;
3666 ++i, param = get_next_argdtlist(param)) {
3667 LL_Type *llt = get_lltype_from_argdtlist(param);
3668 const bool byval = get_byval_from_argdtlist(param);
3669 abi->arg[i].type = llt; /* HACK FIXME */
3670 abi->arg[i].kind = byval ? LL_ARG_DIRECT : LL_ARG_INDIRECT;
3671 abi->arg[i].ftn_pass_by_val = byval;
3672
3673 /* Only for process_formal_arguments(), and for the current
3674 * function being compiled (this function).
3675 *
3676 * sptr is only valid if it was created in the same translation
3677 * object that this abi instance is being created in.
3678 */
3679 if (update || gbl.currsub == func_sptr ||
3680 get_master_sptr() == func_sptr || gbl.entries == func_sptr) {
3681 const SPTR sptr = get_sptr_from_argdtlist(param);
3682 DTYPE dtype = DTYPEG(sptr);
3683 abi->arg[i].sptr = sptr;
3684 if (!dtype || is_iso_cptr(dtype))
3685 dtype = DT_ADDR;
3686 else if (byval)
3687 ll_abi_classify_arg_dtype(abi, &abi->arg[i], dtype);
3688 if (abi->arg[i].kind == LL_ARG_SIGNEXT) /* Get rid of this */
3689 abi->arg[i].kind = LL_ARG_DIRECT;
3690 }
3691 }
3692 }
3693
3694 return abi;
3695 }
3696
3697 /**
3698 \brief Wrapper to process_ll_abi_func_ftn_mod() passing the default module
3699 */
3700 LL_ABI_Info *
process_ll_abi_func_ftn(SPTR func_sptr,bool use_sptrs)3701 process_ll_abi_func_ftn(SPTR func_sptr, bool use_sptrs)
3702 {
3703 return process_ll_abi_func_ftn_mod(llvm_get_current_module(), func_sptr, use_sptrs);
3704 }
3705
3706 /* Generate LL_ABI_Info for a function without a prototype. The return type
3707 * must be known. */
3708 static LL_ABI_Info *
ll_abi_for_missing_prototype(LL_Module * module,DTYPE return_dtype,int func_sptr,int jsra_flags)3709 ll_abi_for_missing_prototype(LL_Module *module, DTYPE return_dtype,
3710 int func_sptr, int jsra_flags)
3711 {
3712 LL_ABI_Info *abi = ll_abi_alloc(module, 0);
3713 abi->is_varargs = false;
3714 abi->missing_prototype = true;
3715
3716 ll_abi_compute_call_conv(abi, func_sptr, jsra_flags);
3717
3718 ll_abi_classify_return_dtype(abi, return_dtype);
3719 assert(abi->arg[0].kind, "ll_abi_for_missing_prototype: Unknown return type",
3720 return_dtype, ERR_Fatal);
3721 assert(abi->arg[0].kind != LL_ARG_BYVAL, "Return value can't be byval",
3722 return_dtype, ERR_Fatal);
3723 ll_abi_complete_arg_info(abi, &abi->arg[0], return_dtype);
3724
3725 abi->is_fortran = true;
3726
3727 return abi;
3728 }
3729
3730 LL_ABI_Info *
ll_abi_for_func_sptr(LL_Module * module,SPTR func_sptr,DTYPE dtype)3731 ll_abi_for_func_sptr(LL_Module *module, SPTR func_sptr, DTYPE dtype)
3732 {
3733 return process_ll_abi_func_ftn_mod(module, func_sptr, false);
3734 }
3735
3736 LL_ABI_Info *
ll_abi_from_call_site(LL_Module * module,int ilix,DTYPE ret_dtype)3737 ll_abi_from_call_site(LL_Module *module, int ilix, DTYPE ret_dtype)
3738 {
3739 DTYPE return_dtype = DT_NONE;
3740 int jsra_flags = 0;
3741
3742 switch (ILI_OPC(ilix)) {
3743 case IL_GJSR:
3744 case IL_JSR:
3745 case IL_QJSR:
3746 /* Direct call: JSR sym arg-lnk */
3747 return ll_abi_for_func_sptr(module, ILI_SymOPND(ilix, 1), DT_NONE);
3748
3749 case IL_GJSRA: {
3750 /* Indirect call: Look for a GARGRET return type indicator.
3751 * GARGRET value next-lnk dtype
3752 * GJSRA addr arg-lnk attr-flags
3753 */
3754 const SPTR iface = ILI_SymOPND(ilix, 4);
3755 const int gargret = ILI_OPND(ilix, 2);
3756 jsra_flags = ILI_OPND(ilix, 3);
3757 if (iface == 0)
3758 return ll_abi_for_missing_prototype(module, ret_dtype, 0, 0);
3759 if (find_ag(get_llvm_ifacenm(iface)))
3760 return ll_abi_for_func_sptr(module, iface, DT_NONE);
3761 get_llvm_funcptr_ag(iface, get_llvm_name(iface));
3762 if (ILI_OPC(gargret) == IL_GARGRET)
3763 return_dtype = ILI_DTyOPND(gargret, 3);
3764 } break;
3765
3766 case IL_JSRA:
3767 /* Indirect call: JSRA addr arg-lnk attr-flags */
3768 jsra_flags = ILI_OPND(ilix, 3);
3769 break;
3770 default:
3771 interr("ll_abi_from_call_site: Unknown call ILI", ilix, ERR_Fatal);
3772 }
3773
3774 /* No prototype found, just analyze the return value. */
3775 if (!return_dtype && ret_dtype)
3776 return_dtype = ret_dtype;
3777 /* return_dtype = dtype_from_return_type(ILI_OPC(ret_ili)); */
3778
3779 if (!return_dtype)
3780 return_dtype = DT_NONE;
3781
3782 return ll_abi_for_missing_prototype(module, return_dtype, 0, jsra_flags);
3783 }
3784
3785 /* Create an LL_Type wrapper for an argument type. */
3786 LL_Type *
make_lltype_from_abi_arg(LL_ABI_ArgInfo * arg)3787 make_lltype_from_abi_arg(LL_ABI_ArgInfo *arg)
3788 {
3789 return arg->type;
3790 }
3791
3792 int
visit_flattened_dtype(dtype_visitor visitor,void * context,DTYPE dtype,unsigned address,unsigned member_sptr)3793 visit_flattened_dtype(dtype_visitor visitor, void *context, DTYPE dtype,
3794 unsigned address, unsigned member_sptr)
3795 {
3796 int retval = 0;
3797 SPTR sptr;
3798 unsigned dim, i, size;
3799
3800 if (DTY(dtype) == TY_STRUCT || DTY(dtype) == TY_UNION) {
3801 /* TY_STRUCT sptr tag size align. */
3802 for (sptr = DTyAlgTyMember(dtype); sptr > NOSYM && retval == 0;
3803 sptr = SYMLKG(sptr)) {
3804 assert(STYPEG(sptr) == ST_MEMBER, "Non-member in struct", sptr,
3805 ERR_Fatal);
3806 if (DTYPEG(sptr) == dtype) {
3807 return -1; /* next pointer */
3808 }
3809 retval = visit_flattened_dtype(visitor, context, DTYPEG(sptr),
3810 address + ADDRESSG(sptr), sptr);
3811 }
3812 return retval;
3813 }
3814
3815 return visitor(context, dtype, address, member_sptr);
3816 }
3817
3818 /* HACK, FIXME: This is only to support Fortran.
3819 * Structs in fortran are stroed in the AG table and searched for in the AG
3820 * table by our own fortran nameing scheme: struct<struct name>. This does
3821 * not mix well with the newer, more unique naming scheme used by our llvm
3822 * backend... mainly that generates unique struct names via unique_name().
3823 * Eventually we will want to use the latter functionality everywhere.
3824 * This casts-away constness.
3825 */
3826 void
ll_override_type_string(LL_Type * llt,const char * str)3827 ll_override_type_string(LL_Type *llt, const char *str)
3828 {
3829 char *clone = llutil_alloc(strlen(str) + 1);
3830 strcpy(clone, str);
3831
3832 /* Cast away constness *eww gross*, gcc hates me */
3833 // FIXME -- this is wrong headed
3834 ((struct LL_Type_ *)llt)->str = clone;
3835 }
3836
3837 /**
3838 \brief Scan the list of struct types and find the corresponding LLDEF
3839 \arg dtype The dtype to search for
3840 \return null iff the struct type is not found
3841
3842 This is an <i>O(n)</i> operation, where <i>n</i> is the number of struct
3843 types.
3844 */
3845 static LLDEF *
LLABI_find_su_type_def(DTYPE dtype)3846 LLABI_find_su_type_def(DTYPE dtype)
3847 {
3848 LLDEF *p;
3849 for (p = struct_def_list; p; p = p->next) {
3850 if (p->dtype == dtype)
3851 return p;
3852 }
3853 return NULL;
3854 }
3855
3856 /**
3857 \brief Scan the list of array types and find the corresponding LLDEF
3858 \arg dtype The dtype to search for
3859 \return null iff the array type is not found
3860
3861 This is an <i>O(n)</i> operation, where <i>n</i> is the number of array
3862 types.
3863 */
3864 static LLDEF *
LLABI_find_array_type_def(DTYPE dtype)3865 LLABI_find_array_type_def(DTYPE dtype)
3866 {
3867 LLDEF *p;
3868 for (p = llarray_def_list; p; p = p->next) {
3869 if (p->dtype == dtype)
3870 return p;
3871 }
3872 return NULL;
3873 }
3874
3875 LL_Type *
llfind_su_type_def(DTYPE dtype)3876 llfind_su_type_def(DTYPE dtype)
3877 {
3878 LLDEF *def = LLABI_find_su_type_def(dtype);
3879 return (def && def->ll_type) ? def->ll_type : NULL;
3880 }
3881
3882 LL_Type *
llfind_array_type_def(DTYPE dtype)3883 llfind_array_type_def(DTYPE dtype)
3884 {
3885 LLDEF *def = LLABI_find_array_type_def(dtype);
3886 return (def && def->ll_type) ? def->ll_type : NULL;
3887 }
3888
3889
3890 LL_Type *
get_ftn_static_lltype(SPTR sptr)3891 get_ftn_static_lltype(SPTR sptr)
3892 {
3893 /* 3 kinds of static
3894 1) constant
3895 2) dinited static
3896 3) uninited static
3897 we process 2) and 3) the same way.
3898 */
3899 LL_Type *llt = NULL;
3900 char *name;
3901 char tname[MXIDLN];
3902 int gblsym;
3903 DTYPE dtype;
3904
3905 assert(SCG(sptr) == SC_STATIC, "Expected SC_STATIC storage class", sptr, ERR_Fatal);
3906
3907 dtype = DTYPEG(sptr);
3908 if (is_function(sptr))
3909 return get_ftn_func_lltype(sptr);
3910 if (STYPEG(sptr) == ST_CONST)
3911 return make_lltype_from_dtype(dtype);
3912 if (DESCARRAYG(sptr) && CLASSG(sptr))
3913 return make_ptr_lltype(get_ftn_typedesc_lltype(sptr));
3914
3915 name = get_llvm_name(sptr);
3916 sprintf(tname, "struct%s", name);
3917
3918 /* get_typedef_ag will return 0 if lltype does not exist and will create a new
3919 ag entry with tname as a side effect. dinit processing should fill struct
3920 layout later. */
3921 gblsym = get_typedef_ag(tname, NULL);
3922 if (!gblsym)
3923 gblsym = get_typedef_ag(tname, NULL); /* now get an ag entry */
3924
3925 if (AG_LLTYPE(gblsym))
3926 return get_ag_lltype(gblsym);
3927
3928 if (ACCINITDATAG(sptr) && (CFUNCG(sptr) || CUDAG(gbl.currsub))) {
3929 if (DDTG(dtype) != TY_CHAR) {
3930 dtype = mk_struct_for_llvm_init(getsname(sptr), 0);
3931 llt = make_lltype_from_dtype(dtype);
3932 gblsym = get_typedef_ag(getsname(sptr), 0);
3933 /* the next line is NOT a typo, it is needed for correctness */
3934 gblsym = get_typedef_ag(getsname(sptr), 0);
3935 set_ag_lltype(gblsym, llt);
3936 DTYPEP(sptr, dtype);
3937 AG_STYPE(gblsym) = STYPEG(sptr);
3938 return llt;
3939 }
3940 return make_lltype_from_dtype(dtype);
3941 }
3942 llt = make_lltype_from_dtype(dtype);
3943 set_ag_lltype(gblsym, llt);
3944 return llt;
3945 }
3946
3947 LL_Type *
get_ftn_cmblk_lltype(SPTR sptr)3948 get_ftn_cmblk_lltype(SPTR sptr)
3949 {
3950 char *name;
3951 char tname[MXIDLN];
3952 int midnum;
3953 LL_Type *llt;
3954 int gblsym;
3955
3956 assert(SCG(sptr) == SC_CMBLK, "Expected SC_CMBLK storage class", sptr, ERR_Fatal);
3957
3958 /* For all SC_CMBLK. We should delay filling out the common block layout until
3959 * the end of the file or until processing dinit. If it is dinit'd, then
3960 * don't change its layout as dinit will fill its layout and cannot be
3961 * changed. Otherwise use SIZE field to define the layout - which will be in
3962 * the form of [i8 x SIZE]. SIZE includes the alignment of common block
3963 * member, i.e, common /myc/ myint, mychar, myint2 integer myint character
3964 * mychar integer myint2
3965 *
3966 * SIZE of myc will be 12
3967 */
3968 name = get_llvm_name(sptr);
3969 sprintf(tname, "struct%s", name);
3970 gblsym = find_ag(tname);
3971 if (!gblsym) {
3972 get_typedef_ag(tname, NULL);
3973 gblsym = find_ag(tname);
3974 llt = make_lltype_from_dtype(DTYPEG(sptr));
3975 set_ag_lltype(gblsym, llt);
3976 return llt;
3977 }
3978 llt = get_ag_lltype(gblsym);
3979
3980 midnum = MIDNUMG(sptr);
3981
3982 if (midnum) {
3983 LLTYPE(midnum) = llt;
3984 if (SNAME(midnum) == NULL)
3985 SNAME(midnum) = SNAME(sptr);
3986 LLTYPE(midnum) = llt;
3987 }
3988 return llt;
3989 }
3990
3991 LL_Type *
get_ftn_typedesc_lltype(SPTR sptr)3992 get_ftn_typedesc_lltype(SPTR sptr)
3993 {
3994 LL_Type *llt = NULL;
3995 char *name;
3996 char tname[MXIDLN];
3997 int gblsym;
3998 DTYPE dtype;
3999
4000 assert(DESCARRAYG(sptr) && CLASSG(sptr), "Expected DESCARRAY && CLASS symbol",
4001 sptr, ERR_Fatal);
4002
4003 name = getsname(sptr);
4004 gblsym = find_ag(name);
4005 if (!gblsym) /* create an entry for tihs symbol which will set ag_global */
4006 gblsym = get_ag(sptr);
4007 if (SCG(sptr) == SC_STATIC)
4008 AG_DEFD(gblsym) = 1;
4009
4010 sprintf(tname, "struct%s", name); /* search for its type */
4011 gblsym = find_ag(tname);
4012 if (!gblsym) {
4013 dtype = get_ftn_typedesc_dtype(sptr);
4014 llt = make_lltype_from_dtype(dtype);
4015 gblsym = get_typedef_ag(tname, NULL);
4016 if (!gblsym)
4017 gblsym = get_typedef_ag(tname, NULL);
4018 set_ag_lltype(gblsym, llt);
4019 }
4020 llt = get_ag_lltype(gblsym);
4021 return llt;
4022 }
4023
4024 LL_Type *
get_ftn_extern_lltype(SPTR sptr)4025 get_ftn_extern_lltype(SPTR sptr)
4026 {
4027 assert(SCG(sptr) == SC_EXTERN, "Expected SC_EXTERN storage class", sptr, ERR_Fatal);
4028
4029 if (is_function(sptr))
4030 return get_ftn_func_lltype(sptr);
4031 if (CFUNCG(sptr))
4032 return get_ftn_cbind_lltype(sptr);
4033 if (CLASSG(sptr) && DESCARRAYG(sptr))
4034 return get_ftn_typedesc_lltype(sptr);
4035 return make_lltype_from_dtype(DTYPEG(sptr));
4036 }
4037
4038 LL_Type *
get_ftn_cbind_lltype(SPTR sptr)4039 get_ftn_cbind_lltype(SPTR sptr)
4040 {
4041 DTYPE dtype = DTYPEG(sptr);
4042 DTYPE sdtype;
4043 int tag, numdim, gblsym, d, iface, gs;
4044 ISZ_T anum;
4045 LL_Type *llt = NULL;
4046 char *typed, *name;
4047 char tname[MXIDLN];
4048 ADSC *ad;
4049
4050 assert(CFUNCG(sptr), "Expected CBIND type", sptr, ERR_Fatal);
4051
4052 /* currently BIND(C) type is only allowed on module. If that were to change,
4053 * we will need to handle here
4054 */
4055
4056 if (is_function(sptr))
4057 return get_ftn_func_lltype(sptr);
4058
4059 if (SCG(sptr) == SC_STATIC) /* internal procedure bind(c) */
4060 return get_ftn_static_lltype(sptr);
4061
4062 if (SCG(sptr) == SC_EXTERN) {
4063 sdtype = dtype;
4064 if (DTY(dtype) == TY_ARRAY)
4065 sdtype = DTySeqTyElement(dtype);
4066 if (DTY(sdtype) == TY_STRUCT) {
4067 tag = DTyAlgTyTag(sdtype);
4068 name = SYMNAME(tag);
4069 sprintf(tname, "struct%s", name);
4070 gblsym = find_ag(tname);
4071 if (!gblsym) {
4072 llt = make_lltype_from_dtype(sdtype);
4073 gblsym = get_typedef_ag(tname, NULL);
4074 typed = process_dtype_struct(sdtype);
4075 gblsym = get_typedef_ag(tname, typed);
4076 set_ag_lltype(gblsym, llt);
4077 }
4078 llt = get_ag_lltype(gblsym);
4079
4080 /* We chose to flatten Fortran array into single dimension array because
4081 * how the dinit processing was done and how we access to its address in
4082 * the ili, which is linearized. Not really sure how it dwarf generation
4083 * should be done - wait until then ...
4084 */
4085 if (DTY(dtype) == TY_ARRAY) {
4086 ad = AD_DPTR(dtype);
4087 numdim = AD_NUMDIM(ad);
4088 d = AD_NUMELM(ad);
4089 if (numdim >= 1 && numdim <= 7) {
4090 if (d == 0 || STYPEG(d) != ST_CONST) {
4091 if (XBIT(68, 0x1))
4092 d = AD_NUMELM(ad) = stb.k1;
4093 else
4094 d = AD_NUMELM(ad) = stb.i1;
4095 }
4096 anum = ad_val_of(d);
4097 }
4098 llt = make_array_lltype(anum, llt);
4099 }
4100 return llt;
4101 }
4102 }
4103 return make_lltype_from_dtype(DTYPEG(sptr));
4104 }
4105
4106 LL_Type *
get_ftn_func_lltype(SPTR sptr)4107 get_ftn_func_lltype(SPTR sptr)
4108 {
4109 if (is_function(sptr)) {
4110 LL_ABI_Info *abi;
4111 if (IS_FTN_PROC_PTR(sptr)) {
4112 const SPTR iface = get_iface_sptr(sptr);
4113 if (iface)
4114 return make_lltype_from_iface(iface);
4115 return make_lltype_from_dtype(DT_CPTR);
4116 }
4117 abi = ll_abi_for_func_sptr(llvm_get_current_module(), sptr, DT_NONE);
4118 return ll_abi_function_type(abi);
4119 }
4120 assert(0, "Expected function type", sptr, ERR_Fatal);
4121 return NULL;
4122 }
4123
4124 LL_Type *
get_ftn_dummy_lltype(int sptr)4125 get_ftn_dummy_lltype(int sptr)
4126 {
4127 if (!PASSBYVALG(sptr)) {
4128 const int func_sptr = gbl.currsub;
4129 const int midnum = MIDNUMG(sptr);
4130 LL_Type *llt = make_generic_dummy_lltype();
4131 #ifdef OMP_OFFLOAD_LLVM
4132 const bool is_nvvm = gbl.ompaccel_isdevice && PASSBYVALG(midnum);
4133 #else
4134 const bool is_nvvm = false;
4135 #endif
4136 if (is_nvvm || gbl.outlined || ISTASKDUPG(GBL_CURRFUNC)) {
4137 const DTYPE dtype = DTYPEG(midnum ? midnum : sptr);
4138 llt = make_ptr_lltype(make_lltype_from_dtype(dtype));
4139 }
4140 if (CFUNCG(func_sptr) && currsub_is_sret()) {
4141 const int fval = FVALG(func_sptr);
4142 const DTYPE dtype = DTYPEG(func_sptr);
4143 if ((sptr == fval) || (midnum == fval))
4144 llt = make_ptr_lltype(make_lltype_from_dtype(dtype));
4145 if (midnum == fval)
4146 LLTYPE(midnum) = llt;
4147 } else if (DTYPEG(sptr) == DT_ADDR && midnum) {
4148 LLTYPE(midnum) = llt;
4149 }
4150 LLTYPE(sptr) = llt;
4151 return llt;
4152 }
4153 return make_ptr_lltype(make_lltype_from_dtype(DTYPEG(sptr)));
4154 }
4155
4156 LL_Type *
get_ftn_hollerith_type(int sptr)4157 get_ftn_hollerith_type(int sptr)
4158 {
4159 /* we need to cheat for hollerith type if we need to print out the space after
4160 * the dtype For example, for 'a', we may need to put 3 empty space after the
4161 * 'a' to keep it the memory after 'a' clean. This is needed when we pass 'a'
4162 * to function and it expects integer.
4163 */
4164 LL_Type *llt = NULL;
4165 DTYPE dtype = DTYPEG(sptr);
4166
4167 if (DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) {
4168 if (HOLLG(sptr) && STYPEG(sptr) == ST_CONST) {
4169 int len = get_hollerith_size(sptr);
4170 len = len + DTyCharLength(dtype);
4171 /* need to create a char of this size */
4172 dtype = get_type(2, DTY(dtype), len);
4173 llt = make_lltype_from_dtype(dtype);
4174 LLTYPE(sptr) = llt;
4175 return llt;
4176 }
4177 }
4178 return make_lltype_from_dtype(dtype);
4179 }
4180
4181 LL_InstrListFlags
ll_instr_flags_from_aop(ATOMIC_RMW_OP aop)4182 ll_instr_flags_from_aop(ATOMIC_RMW_OP aop)
4183 {
4184 switch (aop) {
4185 default:
4186 assert(false, "gen_llvm_atomicrmw_expr: unimplemented op", aop, ERR_Fatal);
4187 case AOP_XCHG:
4188 return ATOMIC_XCHG_FLAG;
4189 case AOP_ADD:
4190 return ATOMIC_ADD_FLAG;
4191 case AOP_SUB:
4192 return ATOMIC_SUB_FLAG;
4193 case AOP_AND:
4194 return ATOMIC_AND_FLAG;
4195 case AOP_OR:
4196 return ATOMIC_OR_FLAG;
4197 case AOP_XOR:
4198 return ATOMIC_XOR_FLAG;
4199 case AOP_MIN:
4200 return ATOMIC_MIN_FLAG;
4201 case AOP_MAX:
4202 return ATOMIC_MAX_FLAG;
4203 }
4204 }
4205