1 /*
2 * Copyright (c) 1996-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 rte.c
20
21 This file contains functions that handle Fortran descriptors including
22 array descriptors and type descriptors.
23 */
24
25 #include "gbldefs.h"
26 #include "global.h"
27 #include "error.h"
28 #include "symtab.h"
29 #include "symutl.h"
30 #include "dtypeutl.h"
31 #include "machar.h"
32 #include "ast.h"
33 #include "semant.h"
34
35 #include <stdio.h>
36
37 #undef RTE_C
38 #define RTE_C
39 #include "rte.h"
40
41 static int get_per_dim_member(int, int, int);
42 static int get_header_member(int sdsc, int info);
43 static int divmod(LOGICAL bIsDiv, int astNum, int astDen, int astRecip,
44 int astShift, int std);
45 static char* mangleUnderscores(char* str);
46 static int lenWithUnderscores(char* str);
47
48 static int rte_sc = SC_LOCAL;
49 static int rte_class = 0;
50 static int rte_rank = 0;
51 static int rte_preserve_desc = 0;
52 static int rte_final_desc = 0;
53
54 void
set_descriptor_class(int class)55 set_descriptor_class(int class)
56 {
57 /* We set rte_class when we want to create a type descriptor in
58 * sym_get_sdescr().
59 */
60 rte_class = class;
61 }
62
63 void
set_descriptor_rank(int r)64 set_descriptor_rank(int r)
65 {
66 /* We set rte_rank when we want to create a descriptor for a pointer or
67 * allocatable with room for its dynamic type. Used in sym_get_sdescr().
68 */
69 rte_rank = r;
70 }
71
72 void
set_preserve_descriptor(int d)73 set_preserve_descriptor(int d)
74 {
75 /* We set rte_preserve_desc when we do not want to override an
76 * existing descriptor for a particular symbol in sym_get_sdescr().
77 * This typically occurs with descriptors associated with polymorphic
78 * objects.
79 */
80 rte_preserve_desc = d;
81 }
82
83 void
set_final_descriptor(int d)84 set_final_descriptor(int d)
85 {
86 /* We set this when we want to general a final procedure descriptor */
87 rte_final_desc = d;
88 }
89
90 void
set_descriptor_sc(int sc)91 set_descriptor_sc(int sc)
92 {
93 rte_sc = sc;
94 set_symutl_sc(sc);
95 }
96
97 int
get_descriptor_sc(void)98 get_descriptor_sc(void)
99 {
100 return rte_sc;
101 }
102
103 /* \brief Returns a length of a string in which we add 1 to length for each
104 * underscore in the string.
105 *
106 * This function is used in sym_get_sdescr() to mangle a type descriptor
107 * name. See also mangleUnderscores() below.
108 *
109 * \param str is the string we're processing.
110 *
111 * \returns length of str plus number of underscores.
112 */
113 static int
lenWithUnderscores(char * str)114 lenWithUnderscores(char* str)
115 {
116 int len;
117
118 if (str == NULL)
119 return 0;
120
121 for(len=0; *str != '\0'; ++len, ++str) {
122 if (*str == '_') {
123 ++len;
124 }
125 }
126 return len;
127 }
128
129 /* \brief If a string has underscores, then we append an equal number of $
130 * to the string.
131 *
132 * This function is called by sym_get_sdescr(). It is used in the
133 * construction of type descriptor and final descriptor symbol names.
134 *
135 * Internally, $ is used as part of a suffix to a symbol name. Distinguishing
136 * between the prefix and suffix is required later, so we need to use $ and
137 * not underscores here. The $ are changed to underscores just before the
138 * symbol is written out in the backend.
139 *
140 * Appending extra $ prevents name conflicts between type descriptor
141 * objects that have an underscore in their type name, host module name,
142 * and/or subprogram name.
143 *
144 * \param str is the string we are processing.
145 *
146 * \returns str if NULL or if no underscores are present. Otherwise, returns a
147 * mangled name.
148 */
149 static char*
mangleUnderscores(char * str)150 mangleUnderscores(char* str)
151 {
152 char * newStr;
153 int i, len, lenscores;
154
155 if (str == NULL || strchr(str, '_') == 0)
156 return str;
157
158 lenscores = lenWithUnderscores(str);
159 newStr = getitem(0, lenscores+1);
160 len = strlen(str);
161 strcpy(newStr, str);
162 for(i=len; i < lenscores; ++i) {
163 newStr[i] = '$';
164 }
165 newStr[i] = '\0';
166 return newStr;
167 }
168
169 /* \brief Generate an array section descriptor, type descriptor, or final
170 * descriptor.
171 *
172 * \param sptr is the symbol table pointer receiving the descriptor
173 *
174 * \param is the rank for an array section descriptor.
175 *
176 * \returns the descriptor symbol table pointer.
177 */
178 int
sym_get_sdescr(int sptr,int rank)179 sym_get_sdescr(int sptr, int rank)
180 {
181 int dtype;
182 int ub;
183 int sdsc, sdsc_mem;
184 LOGICAL addit = FALSE;
185
186 if (SDSCG(sptr) > NOSYM && rte_preserve_desc) {
187 /* We must preserve descriptors associated with polymorphic objects */
188 return SDSCG(sptr);
189 }
190 if (rank < 0) {
191 dtype = DTYPEG(sptr);
192 if (DTY(dtype) != TY_ARRAY) {
193 rank = 0;
194 } else {
195 rank = ADD_NUMDIM(dtype);
196 if (STYPEG(sptr) == ST_MEMBER &&
197 (ALIGNG(sptr) || DISTG(sptr) || POINTERG(sptr) || ADD_DEFER(dtype) ||
198 ADD_ADJARR(dtype) || ADD_NOBOUNDS(dtype))) {
199 /* section descriptor must be added to derived type */
200 addit = TRUE;
201 }
202 }
203 }
204 if ((CLASSG(sptr) || FINALIZEDG(sptr) /*|| ALLOCDESCG(sptr)*/) &&
205 STYPEG(sptr) == ST_MEMBER && rte_rank) {
206 addit = TRUE;
207 }
208 if (rank || rte_rank) {
209 ub = DESC_HDR_LEN + rank * DESC_DIM_LEN;
210 } else if (rank == 0 &&
211 (DTY(DTYPEG(sptr)) == TY_CHAR || DTY(DTYPEG(sptr)) == TY_NCHAR)) {
212 /* Do we really need 18 of them or just F90_Desc? */
213 ub = DESC_HDR_LEN + 1 * DESC_DIM_LEN;
214 if (STYPEG(sptr) == ST_MEMBER)
215 addit = TRUE;
216 } else if (DTY(DTYPEG(sptr)) == TY_PTR || IS_PROC_DUMMYG(sptr)) {
217 /* special descriptor for procedure pointer */
218 ub = DESC_HDR_LEN;
219 if (STYPEG(sptr) == ST_MEMBER)
220 addit = TRUE;
221 } else {
222 ub = 1;
223 }
224
225 dtype = get_array_dtype(1, astb.bnd.dtype);
226 ADD_LWBD(dtype, 0) = 0;
227 ADD_LWAST(dtype, 0) = astb.bnd.one;
228 ADD_NUMELM(dtype) = ADD_UPBD(dtype, 0) = ADD_UPAST(dtype, 0) =
229 mk_isz_cval(ub, astb.bnd.dtype);
230 if (rte_class) {
231 /* create type descriptor */
232 int tag;
233 int sc;
234
235 assert(DTY(DTYPEG(sptr)) == TY_DERIVED,
236 "sym_get_sdescr: making type descriptor for non-derived type", sptr,
237 3);
238 tag = DTY(DTYPEG(sptr) + 3);
239
240 if (SDSCG(tag) && !rte_final_desc) {
241 sdsc = SDSCG(tag);
242 sc = SCG(sdsc);
243 } else {
244 char *desc_sym;
245 int len = lenWithUnderscores(SYMNAME(gbl.currmod)) +
246 lenWithUnderscores(SYMNAME(SCOPEG(tag))) +
247 lenWithUnderscores(SYMNAME(SCOPEG(gbl.currsub))) +
248 lenWithUnderscores(SYMNAME(tag)) + 3 /* 3 for "$$\0" */;
249 desc_sym = getitem(0, len);
250 if (strcmp(SYMNAME(gbl.currmod), SYMNAME(SCOPEG(tag))) == 0) {
251 sprintf(desc_sym, "%s$%s",mangleUnderscores(SYMNAME(gbl.currmod)),
252 mangleUnderscores(SYMNAME(tag)));
253 sc = SC_EXTERN;
254 } else {
255 if (gbl.currmod) {
256 sprintf(desc_sym, "%s$%s$%s", mangleUnderscores(SYMNAME(gbl.currmod)),
257 mangleUnderscores(SYMNAME(SCOPEG(tag))),
258 mangleUnderscores(SYMNAME(tag)));
259 sc = SC_EXTERN;
260 } else if (gbl.currsub) {
261 sprintf(desc_sym, "%s$%s", mangleUnderscores(SYMNAME(gbl.currsub)),
262 mangleUnderscores(SYMNAME(tag)));
263 sc = SC_STATIC;
264 } else {
265 sprintf(desc_sym, "%s$%s", mangleUnderscores(SYMNAME(SCOPEG(tag))),
266 mangleUnderscores(SYMNAME(tag)));
267 sc = SC_STATIC;
268 }
269 }
270 if (rte_final_desc) {
271 /* create a special "final" descriptor used to store
272 * final procedures of a type.
273 */
274 assert((strlen(desc_sym)+7) <= (MAXIDLEN+1),
275 "sym_get_sdescr: final desc name buffer overflow", MAXIDLEN, 4);
276 sdsc = getsymf("%s$td$ft", desc_sym);
277 HCCSYMP(sdsc, 1);
278 HIDDENP(sdsc, 1); /* can't see this, if in the parser */
279 SCOPEP(sdsc, stb.curr_scope);
280 if (gbl.internal > 1)
281 INTERNALP(sdsc, 1);
282 FINALP(sdsc, 1);
283 PARENTP(sdsc, DTYPEG(sptr));
284 } else {
285 assert((strlen(desc_sym)+3) <= (MAXIDLEN+1),
286 "sym_get_sdescr: type desc name buffer overflow", MAXIDLEN, 4);
287 sdsc = get_next_sym(desc_sym, "td");
288 SDSCP(tag, sdsc);
289 if (get_struct_initialization_tree(DTYPEG(sptr))) {
290 /* Ensure existence of template object if there's initializers. */
291 (void) get_dtype_init_template(DTYPEG(sptr));
292 }
293 }
294 }
295
296 CLASSP(sdsc, 1);
297
298 UNLPOLYP(sdsc, UNLPOLYG(tag));
299 DTYPEP(sdsc, dtype);
300 STYPEP(sdsc, ST_DESCRIPTOR);
301 DCLDP(sdsc, 1);
302
303 SCP(sdsc, sc);
304
305 NODESCP(sdsc, 1);
306 DESCARRAYP(sdsc, 1); /* used in detect.c */
307 if (INTERNALG(sptr))
308 INTERNALP(sdsc, 1);
309 return sdsc;
310 }
311 sdsc_mem = 0;
312 if (rte_rank && SDSCG(sptr)) {
313 /* This occurs when we're passing in a non-polymorphic alloc/ptr object
314 * to a polymorphic dummy argument. We want to preserve the descriptor
315 * of the actual since it may contain associate, etc. info but we also
316 * need to enlarge it to store its type in it. See the call to
317 * get_static_descriptor() in check_alloc_ptr_type().
318 */
319 sdsc = SDSCG(sptr);
320 } else {
321 if (addit && !rte_rank) {
322 sdsc = get_next_sym_dt(SYMNAME(sptr), "sd", ENCLDTYPEG(sptr));
323 } else {
324 sdsc = get_next_sym(SYMNAME(sptr), "sd");
325 }
326 }
327 if (addit && rte_rank) {
328 /* Create a type descriptor that will be added to derived type */
329 sdsc_mem = get_next_sym_dt(SYMNAME(sptr), "td", ENCLDTYPEG(sptr));
330 DTYPEP(sdsc_mem, dtype);
331 STYPEP(sdsc_mem, ST_DESCRIPTOR);
332 DCLDP(sdsc_mem, 1);
333 SCP(sdsc_mem, rte_sc);
334 NODESCP(sdsc_mem, 1);
335 DESCARRAYP(sdsc_mem, 1); /* used in detect.c */
336 CLASSP(sdsc_mem, 1);
337 if (INTERNALG(sptr))
338 INTERNALP(sdsc_mem, 1);
339 if (rte_sc == SC_PRIVATE && ALLOCATTRG(sptr) && MIDNUMG(sptr) &&
340 !SDSCG(sptr)) {
341 if (SCG(MIDNUMG(sptr)) != SC_PRIVATE) {
342 SCP(sdsc_mem, SC_LOCAL);
343 }
344 }
345 }
346 DTYPEP(sdsc, dtype);
347 STYPEP(sdsc, ST_DESCRIPTOR);
348 DCLDP(sdsc, 1);
349 SCP(sdsc, rte_sc);
350 NODESCP(sdsc, 1);
351 DESCARRAYP(sdsc, 1); /* used in detect.c */
352 if (DTY(DTYPEG(sptr)) == TY_PTR || IS_PROC_DUMMYG(sptr)) {
353 IS_PROC_DESCRP(sdsc, 1);
354 }
355 if (INTERNALG(sptr))
356 INTERNALP(sdsc, 1);
357 if (rte_sc == SC_PRIVATE && ALLOCATTRG(sptr) && MIDNUMG(sptr) &&
358 !SDSCG(sptr)) {
359 if (SCG(MIDNUMG(sptr)) != SC_PRIVATE) {
360 SCP(sdsc, SC_LOCAL);
361 }
362 }
363 #ifdef DEVICEG
364 if (CUDAG(gbl.currsub) & (CUDA_DEVICE | CUDA_GLOBAL)) {
365 /* copy the device bit to the descriptor */
366 if (DEVICEG(sptr))
367 DEVICEP(sdsc, 1);
368 }
369 #endif
370
371 if (sdsc_mem || addit) {
372 /* Need to add type or static descriptor to data type after sptr */
373 int dtype = ENCLDTYPEG(sptr);
374 assert(STYPEG(sptr) == ST_MEMBER, "sym_get_sdescr: sptr must be member",
375 sptr, 3);
376 assert(dtype && DTY(dtype) == TY_DERIVED,
377 "sym_get_sdescr: sptr is member without enclosing dtype", sptr, 3);
378 if (dtype && DTY(dtype) == TY_DERIVED) {
379 int mem;
380 for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) {
381 if (mem == sptr) {
382 /* add descriptor to the datatype just after 'sptr' */
383 int next = SYMLKG(sptr);
384 int new_mem = sdsc_mem ? sdsc_mem : sdsc;
385 STYPEP(new_mem, ST_MEMBER);
386 ENCLDTYPEP(new_mem, dtype);
387 SYMLKP(new_mem, SYMLKG(sptr));
388 if (SYMLKG(sptr) > NOSYM)
389 VARIANTP(SYMLKG(sptr), sdsc_mem); /* previous link */
390 SYMLKP(sptr, new_mem);
391 VARIANTP(new_mem, sptr);
392 SCP(new_mem, SC_NONE);
393 break;
394 }
395 }
396 assert(mem == sptr,
397 "sym_get_sdescr: sptr not member of its enclosing derived type",
398 sptr, 3);
399 }
400 }
401 return sdsc;
402 } /* sym_get_sdescr */
403
404 int
sym_get_place_holder(char * basename,int dtype)405 sym_get_place_holder(char *basename, int dtype)
406 {
407 int sptr;
408
409 sptr = sym_get_scalar(basename, "pholder", dtype);
410 return sptr;
411 }
412
413 void
get_static_descriptor(int sptr)414 get_static_descriptor(int sptr)
415 {
416 int sdsc;
417
418 sdsc = sym_get_sdescr(sptr, -1);
419 SDSCP(sptr, sdsc);
420
421 if (!is_procedure_ptr(sptr) && !IS_PROC_DUMMYG(sptr)) {
422 NOMDCOMP(sdsc, 1);
423 LNRZDP(sptr, 1);
424 }
425 }
426
427 /* sptr - base array
428 * MIDNUMG(sptr) - pointer to base array
429 * PTROFFG(sptr) - offset to base array (optional)
430 * SECDSCG(DESCRG(sptr)) - base descriptor (desc)
431 * [ desc = SECDSCG(DESCRG(sptr)) ]
432 * MIDNUMG(desc) - pointer to descriptor
433 * PTROFFG(desc) - offset to descriptor
434 */
435 void
get_all_descriptors(int sptr)436 get_all_descriptors(int sptr)
437 {
438 int pvar;
439 int ovar;
440 int arrdsc;
441 int desc;
442 int ndim;
443 int dtype, ast;
444 int i;
445 int s;
446 ADSC *ad;
447
448 /*
449 * All associated variables created for the pointer object cannot appear
450 * in the module common if the object is in the specification part of a
451 * module. A pointer common block will be created for the object.
452 * If in a module, this common block is created by the module processing
453 * and its member list contains these variables. For a local object,
454 * the pointer common block is created by astout by just emitting the
455 * appropriate common statement. To prevent the variables from appearing
456 * in the module common, set their NOMDCOM ('not in module common') flags.
457 */
458
459 /* create pointer or use one already created if F77OUTPUT */
460 pvar = MIDNUMG(sptr);
461 if (pvar == 0 || pvar == NOSYM || CCSYMG(pvar)) {
462 pvar = sym_get_ptr(sptr);
463 MIDNUMP(sptr, pvar);
464 }
465 NOMDCOMP(pvar, 1);
466
467 /* create offset */
468 ovar = sym_get_offset(sptr);
469 PTROFFP(sptr, ovar);
470 NOMDCOMP(ovar, 1);
471
472 ndim = rank_of_sym(sptr);
473
474 if (STYPEG(sptr) == ST_MEMBER && SYMLKG(sptr) != pvar) {
475 int dtype;
476 dtype = ENCLDTYPEG(sptr);
477 if (dtype) {
478 int mem;
479 for (mem = DTY(dtype + 1); mem > NOSYM && mem != sptr; mem = SYMLKG(mem))
480 ;
481 if (mem == sptr) {
482 /* add 'pointer' to the derived type just after 'sptr' */
483 int next = SYMLKG(sptr);
484 SYMLKP(sptr, pvar);
485 STYPEP(pvar, ST_MEMBER);
486 ENCLDTYPEP(pvar, dtype);
487 SYMLKP(pvar, next);
488 VARIANTP(pvar, sptr);
489 SCP(pvar, SC_NONE);
490 if (next > NOSYM)
491 VARIANTP(next, pvar);
492 if (DTY(DTYPEG(sptr)) == TY_ARRAY) {
493 /* for arrays, put 'offset' there too */
494 SYMLKP(pvar, ovar);
495 STYPEP(ovar, ST_MEMBER);
496 ENCLDTYPEP(ovar, dtype);
497 SYMLKP(ovar, next);
498 VARIANTP(ovar, pvar);
499 SCP(ovar, SC_NONE);
500 if (next > NOSYM)
501 VARIANTP(next, ovar);
502 }
503 }
504 }
505 }
506 if (DTY(DTYPEG(sptr)) != TY_ARRAY)
507 return;
508
509 /* create descriptor and pointer */
510 trans_mkdescr(sptr);
511 arrdsc = DESCRG(sptr);
512 assert(SDSCG(sptr), "get_all_descriptors, need static descriptor", sptr, 2);
513 SECDSCP(arrdsc, SDSCG(sptr));
514
515 if (STYPEG(sptr) == ST_MEMBER) {
516 /* don't change bounds of distributed member arrays unless
517 * allocatable or pointer */
518 if (!POINTERG(sptr) && !ALLOCG(sptr)) {
519 return;
520 }
521 }
522
523 /*
524 * for the descriptor (whose storage class is SC_BASED), set its
525 * 'not in module common' flag so that the module and interf processing
526 * will ignore this 'based' symbol. The module processing creates the
527 * pointer common block early, but if pointers aren't allowed in the output,
528 * the descriptor needs to be added to the beginning of the common. The
529 * descriptor cannot be added to the common by the module processing, since
530 * its storage class is SC_BASED; astout will need to write the necessary
531 * common statement.
532 */
533
534 /* change the bounds of the array and its descriptor */
535 ad = AD_DPTR(DTYPEG(sptr));
536 DESCUSEDP(sptr, 1);
537 ast_visit(1, 1);
538 for (i = 0; i < ndim; i++) {
539 /* TBD it would be nice to zap the z_b... variables so their decls
540 * do not appear in the output.
541 */
542 int oldast, a;
543
544 oldast = AD_LWAST(ad, i);
545 AD_LWAST(ad, i) = get_global_lower(SDSCG(sptr), i);
546 if (oldast)
547 ast_replace(oldast, AD_LWAST(ad, i));
548
549 oldast = AD_UPAST(ad, i);
550 a = get_extent(SDSCG(sptr), i);
551 a = mk_binop(OP_SUB, a, mk_isz_cval(1, astb.bnd.dtype), astb.bnd.dtype);
552 a = mk_binop(OP_ADD, AD_LWAST(ad, i), a, astb.bnd.dtype);
553 AD_UPAST(ad, i) = a;
554 if (oldast)
555 ast_replace(oldast, AD_UPAST(ad, i));
556
557 oldast = AD_EXTNTAST(ad, i);
558 AD_EXTNTAST(ad, i) = get_extent(SDSCG(sptr), i);
559 if (oldast)
560 ast_replace(oldast, AD_EXTNTAST(ad, i));
561
562 {
563 AD_LWBD(ad, i) = AD_LWAST(ad, i);
564 AD_UPBD(ad, i) = AD_UPAST(ad, i);
565 }
566 }
567 for (i = 0; i < ndim; ++i) {
568 AD_MLPYR(ad, i) = get_local_multiplier(SDSCG(sptr), i);
569 }
570 AD_NUMELM(ad) = get_desc_gsize(SDSCG(sptr));
571 AD_ZBASE(ad) = get_xbase(SDSCG(sptr));
572 ast = AD_ZBASE(ad);
573 if (ast)
574 AD_ZBASE(ad) = ast_rewrite(ast);
575 ast_unvisit();
576 }
577
578 int
get_multiplier_index(int dim)579 get_multiplier_index(int dim)
580 {
581 return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_LMULT;
582 }
583
584 int
get_global_lower_index(int dim)585 get_global_lower_index(int dim)
586 {
587 return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_LOWER;
588 }
589
590 int
get_global_upper_index(int dim)591 get_global_upper_index(int dim)
592 {
593 return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_UPPER;
594 }
595
596 int
get_global_extent_index(int dim)597 get_global_extent_index(int dim)
598 {
599 return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_EXTENT;
600 }
601
602 int
get_section_stride_index(int dim)603 get_section_stride_index(int dim)
604 {
605 return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_SSTRIDE;
606 }
607
608 int
get_section_offset_index(int dim)609 get_section_offset_index(int dim)
610 {
611 return DESC_HDR_LEN + dim * DESC_DIM_LEN + DESC_DIM_SOFFSET;
612 }
613
614 int
get_xbase_index(void)615 get_xbase_index(void)
616 {
617 return DESC_HDR_LBASE;
618 }
619
620 int
get_xbase(int sdsc)621 get_xbase(int sdsc)
622 {
623 return get_header_member(sdsc, DESC_HDR_LBASE);
624 }
625
626 int
get_gbase(int sdsc)627 get_gbase(int sdsc)
628 {
629 return get_header_member(sdsc, DESC_HDR_GBASE);
630 }
631
632 int
get_gbase2(int sdsc)633 get_gbase2(int sdsc)
634 {
635 return get_header_member(sdsc, DESC_HDR_GBASE + 1);
636 }
637
638 int
get_kind(int sdsc)639 get_kind(int sdsc)
640 {
641 return get_header_member(sdsc, DESC_HDR_KIND);
642 }
643
644 int
get_byte_len(int sdsc)645 get_byte_len(int sdsc)
646 {
647 return get_header_member(sdsc, DESC_HDR_BYTE_LEN);
648 }
649
650 int
get_byte_len_indx(void)651 get_byte_len_indx(void)
652 {
653 return DESC_HDR_BYTE_LEN;
654 }
655
656 int
get_local_multiplier(int sdsc,int dim)657 get_local_multiplier(int sdsc, int dim)
658 {
659 return get_per_dim_member(sdsc, dim, DESC_DIM_LMULT);
660 }
661
662 int
get_global_lower(int sdsc,int dim)663 get_global_lower(int sdsc, int dim)
664 {
665 return get_per_dim_member(sdsc, dim, DESC_DIM_LOWER);
666 }
667
668 int
get_global_upper(int sdsc,int dim)669 get_global_upper(int sdsc, int dim)
670 {
671 return get_per_dim_member(sdsc, dim, DESC_DIM_UPPER);
672 }
673
674 int
get_extent(int sdsc,int dim)675 get_extent(int sdsc, int dim)
676 {
677 return get_per_dim_member(sdsc, dim, DESC_DIM_EXTENT);
678 }
679
680 int
get_section_stride(int sym,int dim)681 get_section_stride(int sym, int dim)
682 {
683 return get_per_dim_member(sym, dim, DESC_DIM_SSTRIDE);
684 }
685
686 int
get_section_offset(int sym,int dim)687 get_section_offset(int sym, int dim)
688 {
689 return get_per_dim_member(sym, dim, DESC_DIM_SOFFSET);
690 }
691
692 int
get_local_lower(int sdsc,int dim)693 get_local_lower(int sdsc, int dim)
694 {
695 return get_global_lower(sdsc, dim);
696 }
697
698 int
get_local_upper(int sdsc,int dim)699 get_local_upper(int sdsc, int dim)
700 {
701 return get_global_upper(sdsc, dim);
702 }
703
704 int
get_owner_lower(int sdsc,int dim)705 get_owner_lower(int sdsc, int dim)
706 {
707 return get_global_lower(sdsc, dim);
708 }
709
710 int
get_owner_upper(int sdsc,int dim)711 get_owner_upper(int sdsc, int dim)
712 {
713 return get_global_upper(sdsc, dim);
714 }
715
716 int
get_heap_block(int sdsc)717 get_heap_block(int sdsc)
718 {
719 return astb.i0;
720 }
721
722 int
get_desc_rank(int sdsc)723 get_desc_rank(int sdsc)
724 {
725 return get_header_member(sdsc, DESC_HDR_RANK);
726 }
727
728 int
get_desc_tag(int sdsc)729 get_desc_tag(int sdsc)
730 {
731 return get_header_member(sdsc, DESC_HDR_TAG);
732 }
733
734 int
get_desc_flags(int sdsc)735 get_desc_flags(int sdsc)
736 {
737 return get_header_member(sdsc, DESC_HDR_FLAGS);
738 }
739
740 int
get_desc_gsize_index(void)741 get_desc_gsize_index(void)
742 {
743 return DESC_HDR_GSIZE;
744 }
745
746 int
get_desc_gsize(int sdsc)747 get_desc_gsize(int sdsc)
748 {
749 return get_header_member(sdsc, DESC_HDR_GSIZE);
750 }
751
752 int
get_desc_lsize(int sdsc)753 get_desc_lsize(int sdsc)
754 {
755 return get_header_member(sdsc, DESC_HDR_LSIZE);
756 }
757
758 int
get_lsize_index(void)759 get_lsize_index(void)
760 {
761 return DESC_HDR_LSIZE;
762 }
763
764 int
get_proc_base(int sdsc)765 get_proc_base(int sdsc)
766 {
767 return astb.i0;
768 }
769
770 int
get_proc_shape(int sdsc,int dim)771 get_proc_shape(int sdsc, int dim)
772 {
773 return astb.i1;
774 }
775
776 int
get_proc_stride(int sdsc,int dim)777 get_proc_stride(int sdsc, int dim)
778 {
779 return get_section_stride(sdsc, dim);
780 }
781
782 int
get_block_size(int sdsc,int dim)783 get_block_size(int sdsc, int dim)
784 {
785 return astb.i0;
786 }
787
788 int
get_neg_ovlp(int sdsc,int dim)789 get_neg_ovlp(int sdsc, int dim)
790 {
791 return astb.i0;
792 }
793
794 int
get_pos_ovlp(int sdsc,int dim)795 get_pos_ovlp(int sdsc, int dim)
796 {
797 return astb.i0;
798 }
799
800 int
get_template_offset(int sdsc,int dim)801 get_template_offset(int sdsc, int dim)
802 {
803 return get_section_offset(sdsc, dim);
804 }
805
806 int
get_descriptor_len(int rank)807 get_descriptor_len(int rank)
808 {
809 return DESC_HDR_LEN + rank * DESC_DIM_LEN;
810 }
811
812 static int
get_header_member(int sdsc,int info)813 get_header_member(int sdsc, int info)
814 {
815 int ast;
816 int subs[1];
817
818 #if DEBUG
819 if (!sdsc)
820 interr("get_header_member, blank static descriptor", 0, 3);
821 else if (STYPEG(sdsc) != ST_ARRDSC && STYPEG(sdsc) != ST_DESCRIPTOR &&
822 DTY(DTYPEG(sdsc)) != TY_ARRAY)
823 interr("get_header_member, bad static descriptor", sdsc, 3);
824 #endif
825 subs[0] = mk_isz_cval(info, astb.bnd.dtype);
826 ast = mk_subscr(mk_id(sdsc), subs, 1, astb.bnd.dtype);
827 return ast;
828 }
829
830
831 /** \brief Generate an AST for accessing a particular field in a descriptor
832 * header.
833 *
834 * Note: This is similar to get_header_member() above except it also
835 * operates on descriptors that are embedded in derived type objects.
836 *
837 * \param parent is the ast of the expression with the descriptor that
838 * we want to access. This is needed if the descriptor is embedded
839 * in a derived type object.
840 * \param sdsc is the symbol table pointer of the descriptor we want to
841 * access.
842 * \param info is the field we want to access in the descriptor.
843 *
844 * \return an ast expression of the descriptor access.
845 */
846 int
get_header_member_with_parent(int parent,int sdsc,int info)847 get_header_member_with_parent(int parent, int sdsc, int info)
848 {
849 int ast;
850 int subs[1];
851
852 #if DEBUG
853 if (!sdsc)
854 interr("get_header_member, blank static descriptor", 0, 3);
855 else if (STYPEG(sdsc) != ST_ARRDSC && STYPEG(sdsc) != ST_DESCRIPTOR &&
856 DTY(DTYPEG(sdsc)) != TY_ARRAY)
857 interr("get_header_member, bad static descriptor", sdsc, 3);
858 #endif
859 subs[0] = mk_isz_cval(info, astb.bnd.dtype);
860 ast = mk_subscr(check_member(parent, mk_id(sdsc)), subs, 1, astb.bnd.dtype);
861 return ast;
862 }
863
864
865 static int
get_array_rank(int sdsc)866 get_array_rank(int sdsc)
867 {
868 int rank = 0;
869
870 if (STYPEG(sdsc) == ST_ARRDSC) {
871 rank = rank_of_sym(ARRAYG(sdsc));
872 } else if (STYPEG(sdsc) == ST_DESCRIPTOR || STYPEG(sdsc) == ST_MEMBER) {
873 int dtype = DTYPEG(sdsc);
874 int ubast = AD_UPAST(AD_DPTR(dtype), 0);
875 int ub;
876 assert(DTY(dtype) == TY_ARRAY && A_TYPEG(ubast) == A_CNST,
877 "get_array_rank: Invalid ST_DESCRIPTOR|ST_MEMBER dtype", DTY(dtype),
878 0);
879 ub = CONVAL2G(A_SPTRG(ubast));
880
881 rank = (ub - (DESC_HDR_LEN + HPF_DESC_HDR_LEN)) /
882 (DESC_DIM_LEN + HPF_DESC_DIM_LEN);
883 } else {
884 assert(0, "get_array_rank: Invalid descriptor type", STYPEG(sdsc), 0);
885 }
886
887 return rank;
888 }
889
890 static int
get_per_dim_member(int sdsc,int dim,int info)891 get_per_dim_member(int sdsc, int dim, int info)
892 {
893 int ast;
894 int subs[1];
895
896 #if DEBUG
897 assert(sdsc && (STYPEG(sdsc) == ST_DESCRIPTOR || STYPEG(sdsc) == ST_ARRDSC ||
898 STYPEG(sdsc) == ST_MEMBER),
899 "get_per_dim_member-illegal stat.desc", sdsc, 0);
900 #endif
901 subs[0] =
902 mk_isz_cval(DESC_HDR_LEN + dim * DESC_DIM_LEN + info, astb.bnd.dtype);
903 ast = mk_subscr(mk_id(sdsc), subs, 1, astb.bnd.dtype);
904 return ast;
905 }
906
907 /* If bIsDiv is TRUE, add statements to compute astNum/astDen before std.
908 * If bIsDiv is FALSE, add statements to compute astNum%astDen before std.
909 * astRecip is the reciprocal of astDen. If astShift is nonzero,
910 * 2**astShift = astDen, and can be used to shift astNum.
911 * Return an AST representing the result. */
912 static int
divmod(LOGICAL bIsDiv,int astNum,int astDen,int astRecip,int astShift,int std)913 divmod(LOGICAL bIsDiv, int astNum, int astDen, int astRecip, int astShift,
914 int std)
915 {
916 int sptr;
917 int astRes;
918 int ast, ast1, astStmt;
919
920 if (astDen == astb.i1)
921 return astNum;
922 if (astNum == astb.i0)
923 return astNum;
924
925 sptr = sym_get_scalar("r", "rte", DT_INT);
926 astRes = mk_id(sptr);
927
928 if (!XBIT(49, 0x01000000)) {
929 /* ...not T3D/T3E target. */
930 astStmt = mk_stmt(A_IFTHEN, 0);
931 ast = mk_binop(OP_LT, astShift, astb.i0, DT_LOG);
932 A_IFEXPRP(astStmt, ast);
933 add_stmt_before(astStmt, std);
934
935 ast = mk_binop(OP_DIV, astNum, astDen, DT_INT);
936 if (!bIsDiv) {
937 ast = mk_binop(OP_MUL, astDen, ast, DT_INT);
938 ast = mk_binop(OP_SUB, astNum, ast, DT_INT);
939 }
940 astStmt = mk_assn_stmt(astRes, ast, DT_INT);
941 add_stmt_before(astStmt, std);
942
943 astStmt = mk_stmt(A_ELSE, 0);
944 add_stmt_before(astStmt, std);
945
946 ast1 = mk_unop(OP_SUB, astShift, DT_INT);
947 ast = ast_intr(I_ISHFT, DT_INT, 2, astNum, ast1);
948 if (!bIsDiv) {
949 ast = ast_intr(I_ISHFT, DT_INT, 2, ast, astShift);
950 ast = ast_intr(I_IEOR, DT_INT, 2, astNum, ast);
951 }
952 astStmt = mk_assn_stmt(astRes, ast, DT_INT);
953 add_stmt_before(astStmt, std);
954
955 astStmt = mk_stmt(A_ENDIF, 0);
956 add_stmt_before(astStmt, std);
957 return astRes;
958 }
959 astStmt = mk_stmt(A_IFTHEN, 0);
960 ast = mk_binop(OP_EQ, astRecip, astb.i0, DT_LOG);
961 A_IFEXPRP(astStmt, ast);
962 add_stmt_before(astStmt, std);
963
964 /* Denominator is 1. */
965 if (bIsDiv)
966 astStmt = mk_assn_stmt(astRes, astNum, DT_INT);
967 else
968 astStmt = mk_assn_stmt(astRes, astb.i0, DT_INT);
969 add_stmt_before(astStmt, std);
970
971 astStmt = mk_stmt(A_ELSE, 0);
972 add_stmt_before(astStmt, std);
973
974 sptr = sym_mkfunc_nodesc("int_mult_upper", DT_INT);
975 ast = begin_call(A_FUNC, sptr, 2);
976 add_arg(mk_default_int(astNum));
977 add_arg(mk_default_int(astRecip));
978
979 if (!bIsDiv) {
980 ast = mk_binop(OP_MUL, astDen, ast, DT_INT);
981 ast = mk_binop(OP_SUB, astNum, ast, DT_INT);
982 }
983 astStmt = mk_assn_stmt(astRes, ast, DT_INT);
984 add_stmt_before(astStmt, std);
985
986 astStmt = mk_stmt(A_ENDIF, 0);
987 add_stmt_before(astStmt, std);
988
989 return astRes;
990 }
991