1 /*
2 * Copyright (c) 1994-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 /** \file
19 * \brief Routines for descriptor optimizatons and forall transformations
20 */
21
22 #include "gbldefs.h"
23 #include "global.h"
24 #include "error.h"
25 #include "symtab.h"
26 #include "symutl.h"
27 #include "dtypeutl.h"
28 #include "soc.h"
29 #include "semant.h"
30 #include "ast.h"
31 #include "pragma.h"
32 #include "gramtk.h"
33 #include "extern.h"
34 #include "commopt.h"
35 #include "dpm_out.h"
36 #include "nme.h"
37 #include "optimize.h"
38 #include "pd.h"
39 #include "ccffinfo.h"
40 #define RTE_C
41 #include "rte.h"
42 #undef RTE_C
43 #include "comm.h"
44 #include "direct.h"
45 #include "rtlRtns.h"
46
47 static void convert_statements(void);
48 static void convert_simple(void);
49 static int conv_allocate(int std);
50 static int conv_deallocate(int std);
51 static LOGICAL is_same_mask(int expr, int expr1);
52 static LOGICAL no_effect_forall(int std);
53 static void init_collapse(void);
54 static void collapse_arrays(void);
55 static void end_collapse(void);
56 static void find_collapse_allocs(void);
57 static void find_collapse_defs(void);
58 static void delete_collapse(int ci);
59 static void find_collapse_uses(void);
60 static LOGICAL is_parent_loop(int lpParent, int lp);
61 static void collapse_loops(void);
62 static void find_descrs(void);
63 static void collapse_allocates(LOGICAL bDescr);
64 static void report_collapse(int lp);
65 #if DEBUG
66 static void dump_collapse(void);
67 #endif
68 static int position_finder(int forall, int ast);
69 static void find_calls_pos(int std, int forall, int must_pos);
70 static void find_mask_calls_pos(int forall);
71 static void find_stmt_calls_pos(int forall, int mask_pos);
72 static int find_max_of_mask_calls_pos(int forall);
73 static void add_mask_calls(int pos, int forall, int stdnext);
74 static void add_stmt_calls(int pos, int forall, int stdnext);
75 static void forall_dependency(int std);
76 static void put_calls(int pos, int std, int stdnext);
77 static void search_pure_function(int stdfirst, int stdlast);
78 static int transform_pure_function(int expr, int std);
79 static void eliminate_barrier(void);
80 static void remove_mask_calls(int forall);
81 static void remove_stmt_calls(int forall);
82 static void move_mask_calls(int forall);
83 static LOGICAL is_stmt_call_dependent(int forall, int lhs);
84 static LOGICAL is_mask_call_dependent(int forall, int lhs);
85 static LOGICAL is_call_dependent(int std, int forall, int lhs);
86 static void convert_omp_workshare(void);
87 static void insert_assign(int lhs, int rhs, int beforestd);
88
89 static void convert_template_instance(void);
90 #define NO_PTR XBIT(49, 0x8000)
91 #define NO_CHARPTR XBIT(58, 0x1)
92 #define NO_DERIVEDPTR XBIT(58, 0x40000)
93
94 #undef MKASSN
95 #define MKASSN(d, s) mk_assn_stmt(d, s, 0)
96
97 void
convert_output(void)98 convert_output(void)
99 {
100 if (XBIT(49, 1))
101 return;
102
103 if (flg.opt >= 2 && !XBIT(47, 0x10)) {
104 init_collapse();
105 collapse_arrays();
106 }
107 convert_statements();
108 FREE(ftb.base);
109 comm_fini();
110 freearea(FORALL_AREA);
111 if (flg.opt >= 2 && !XBIT(47, 0x10)) {
112 collapse_allocates(TRUE);
113 end_collapse();
114 }
115 eliminate_barrier();
116 free_brtbl();
117 transform_wrapup();
118 convert_simple();
119 if (XBIT(58, 0x10000000))
120 convert_template_instance();
121 }
122
123 /*
124 * keep track of forall temp arrays
125 *
126 */
127 #define TEMP_AREA 6
128
129 typedef struct T_LIST {
130 struct T_LIST *next;
131 int temp, asd, dtype, cvlen, sc, std, astd, dstd;
132 } T_LIST;
133
134 #define GET_T_LIST(q) q = (T_LIST *)getitem(TEMP_AREA, sizeof(T_LIST))
135 static T_LIST *templist;
136 static int beforestd;
137 static int newsymnum;
138
139 static void
early_flow_init(void)140 early_flow_init(void)
141 {
142 optshrd_init();
143 flowgraph();
144 findloop(0);
145 flow();
146 }
147
148 static void
early_flow_fini(void)149 early_flow_fini(void)
150 {
151 optshrd_fend();
152 optshrd_end();
153 }
154
155 void
forall_dependency_analyze(void)156 forall_dependency_analyze(void)
157 {
158 int std;
159 int ast;
160 int parallel_depth;
161 int task_depth;
162
163 templist = NULL;
164 parallel_depth = 0;
165 task_depth = 0;
166 for (std = STD_NEXT(0); std;) {
167 ast = STD_AST(std);
168 switch (A_TYPEG(ast)) {
169 case A_MP_PARALLEL:
170 ++parallel_depth;
171 set_descriptor_sc(SC_PRIVATE);
172 break;
173 case A_MP_ENDPARALLEL:
174 --parallel_depth;
175 if (parallel_depth == 0 && task_depth == 0) {
176 set_descriptor_sc(SC_LOCAL);
177 }
178 break;
179 case A_MP_TASK:
180 case A_MP_TASKLOOP:
181 ++task_depth;
182 set_descriptor_sc(SC_PRIVATE);
183 break;
184 case A_MP_ENDTASK:
185 case A_MP_ETASKLOOP:
186 --task_depth;
187 if (parallel_depth == 0 && task_depth == 0) {
188 set_descriptor_sc(SC_LOCAL);
189 }
190 break;
191 case A_FORALL:
192 if (STD_DELETE(std)) {
193 ast_to_comment(ast);
194 std = STD_NEXT(std);
195 continue;
196 }
197 forall_dependency(std);
198 break;
199 }
200 std = STD_NEXT(std);
201 }
202 freearea(TEMP_AREA);
203 templist = NULL;
204 }
205
206 void
convert_forall(void)207 convert_forall(void)
208 {
209 int std;
210 int ast;
211
212 if (XBIT(49, 2))
213 return;
214
215 if (flg.opt >= 2 && XBIT(53, 2)) {
216 points_to();
217 }
218 /*
219 * need to do early flow analysis to determine if lhs really need temp.
220 * NOTE: -Hx,4,0x200000 is not useful at all; eventually a crash could
221 * occur in nmeutil because a NME table is not created (nmeb.stg_base is
222 * null).
223 */
224 if (flg.opt >= 2 && !XBIT(4, 0x200000)) {
225 early_flow_init();
226 }
227
228 if (!XBIT(4, 0x100000))
229 forall_dependency_analyze();
230 /* we need to redo the flow graph forall_dependency_analyze can add more node
231 * into the flow */
232 init_region();
233 for (std = STD_NEXT(0); std;) {
234 arg_gbl.inforall = FALSE;
235 ast = STD_AST(std);
236 check_region(std);
237 switch (A_TYPEG(ast)) {
238 case A_FORALL:
239 arg_gbl.inforall = TRUE;
240 std = conv_forall(std);
241 break;
242 default:
243 std = STD_NEXT(std);
244 break;
245 }
246 }
247 if (flg.smp) {
248 convert_omp_workshare();
249 }
250 if (flg.opt >= 2 && !XBIT(4, 0x200000)) {
251 early_flow_fini();
252 }
253 if (flg.opt >= 2 && XBIT(53, 2)) {
254 f90_fini_pointsto();
255 }
256 }
257
258 #define NO_WRKSHR 0
259 #define IN_WRKSHR 1
260 #define IN_PDO 2
261 #define IN_SINGLE 3
262 #define IN_PARALLEL 4
263 #define IN_CRITICAL 5
264
265 static int
gen_pdo(int do_ast)266 gen_pdo(int do_ast)
267 {
268 int ast, plast;
269
270 ast = mk_stmt(A_MP_PDO, 0);
271 A_DOVARP(ast, A_DOVARG(do_ast));
272 A_LASTVALP(ast, A_LASTVALG(do_ast));
273 A_M1P(ast, A_M1G(do_ast));
274 A_M2P(ast, A_M2G(do_ast));
275 A_M3P(ast, A_M3G(do_ast));
276 A_CHUNKP(ast, 0);
277 A_SCHED_TYPEP(ast, 0); /* STATIC */
278 A_ORDEREDP(ast, 0);
279 A_LASTVALP(ast, 0);
280 A_DISTRIBUTEP(ast, 0);
281 A_DISTPARDOP(ast, 0);
282 A_ENDLABP(ast, 0);
283 A_DISTCHUNKP(ast, 0);
284 A_TASKLOOPP(ast, 0);
285
286 return ast;
287 }
288
289 static void
gen_endsingle(int std,int single,int presinglebarrier)290 gen_endsingle(int std, int single, int presinglebarrier)
291 {
292 int ompast;
293 int ompstd;
294 int singlestd = A_STDG(single);
295
296 if (presinglebarrier &&
297 A_TYPEG(STD_AST(STD_PREV(singlestd))) != A_MP_BARRIER) {
298 add_stmt_before(mk_stmt(A_MP_BARRIER, 0), singlestd);
299 }
300
301 ompast = mk_stmt(A_MP_ENDSINGLE, 0);
302 A_LOPP(single, ompast);
303 A_LOPP(ompast, single);
304 ompstd = add_stmt_before(ompast, std);
305 add_stmt_after(mk_stmt(A_MP_BARRIER, 0), ompstd);
306 }
307
308 static void
convert_omp_workshare(void)309 convert_omp_workshare(void)
310 {
311 int std;
312 int newstd = 0;
313 int ast;
314 int lsptr;
315 int prevast;
316 int state = NO_WRKSHR;
317 int dolevel = 0;
318 int parpar = 0;
319 int parallellevel = 0;
320 int wherelevel = 0;
321 int ompast;
322 int ompstd;
323 int single;
324 int presinglebarrier = 0;
325 int parallel_depth = 0;
326
327 for (std = STD_NEXT(0); std; std = STD_NEXT(std)) {
328 ast = STD_AST(std);
329 switch (A_TYPEG(ast)) {
330 case A_MP_PARALLEL:
331 ++parallel_depth;
332 break;
333 case A_MP_ENDPARALLEL:
334 --parallel_depth;
335 break;
336 case A_MP_WORKSHARE:
337 case A_MP_ENDWORKSHARE:
338 if (parallel_depth > 1) {
339 ast_to_comment(ast);
340 ast = STD_AST(std);
341 }
342 break;
343 }
344
345 if (state != NO_WRKSHR && A_TYPEG(ast) == A_ALLOC &&
346 A_TKNG(ast) == TK_DEALLOCATE) {
347 int sptr = sym_of_ast(A_SRCG(ast));
348 if (CCSYMG(sptr) || HCCSYMG(sptr)) {
349 /* dealloc of a compiler generated temp, make sure
350 * any OMP SINGLEs are preceded by a barrier */
351 presinglebarrier++;
352 }
353 }
354
355 switch (state) {
356 case NO_WRKSHR:
357 if (A_TYPEG(ast) == A_MP_WORKSHARE) {
358 state = IN_WRKSHR;
359 }
360 break;
361 case IN_WRKSHR:
362 switch (A_TYPEG(ast)) {
363 case A_MP_ENDWORKSHARE:
364 state = NO_WRKSHR;
365 break;
366 case A_DO:
367 prevast = STD_AST(STD_PREV(std));
368 if (A_TYPEG(prevast) == A_COMMENT &&
369 A_TYPEG(A_LOPG(prevast)) == A_FORALL) {
370 ompast = gen_pdo(ast);
371 newstd = add_stmt_before(ompast, std);
372 if (parallel_depth > 1)
373 STD_PAR(newstd) = 1;
374 dolevel++;
375 state = IN_PDO;
376 ast_to_comment(ast);
377 } else {
378 /* probably an elemental intrinsic */
379 single = mk_stmt(A_MP_SINGLE, 0);
380 add_stmt_before(single, std);
381 dolevel++;
382 state = IN_SINGLE;
383 }
384 break;
385 case A_MP_PARALLEL:
386 single = mk_stmt(A_MP_SINGLE, 0);
387 add_stmt_before(single, std);
388 parallellevel++;
389 state = IN_PARALLEL;
390 break;
391 case A_MP_CRITICAL:
392 single = mk_stmt(A_MP_SINGLE, 0);
393 add_stmt_before(single, std);
394 state = IN_CRITICAL;
395 break;
396 case A_COMMENT:
397 switch (A_TYPEG(A_LOPG(ast))) {
398 case A_WHERE:
399 wherelevel++;
400 break;
401 case A_ENDWHERE:
402 wherelevel--;
403 break;
404 }
405 break;
406 case A_ALLOC:
407 break;
408 case A_ASN:
409 lsptr = sym_of_ast(A_DESTG(ast));
410 if (wherelevel) {
411 if (HCCSYMG(lsptr)) {
412 THREADP(lsptr, 1);
413 break;
414 }
415 } else if (HCCSYMG(lsptr) && SCG(lsptr) == SC_PRIVATE) {
416 break;
417 }
418 /* FALL THRU */
419 default:
420 single = mk_stmt(A_MP_SINGLE, 0);
421 add_stmt_before(single, std);
422 state = IN_SINGLE;
423 break;
424 }
425 break;
426 case IN_PDO:
427 switch (A_TYPEG(ast)) {
428 case A_DO:
429 dolevel++;
430 break;
431 case A_ENDDO:
432 if (--dolevel == 0) {
433 ompast = mk_stmt(A_MP_ENDPDO, 0);
434 ompstd = add_stmt_after(ompast, std);
435 add_stmt_after(mk_stmt(A_MP_BARRIER, 0), ompstd);
436 std = STD_NEXT(ompstd);
437 state = IN_WRKSHR;
438 ast_to_comment(ast);
439 }
440 break;
441 case A_COMMENT:
442 /* This case (WHERE or ENDWHERE in a DO) may never happen,
443 * but the comment STDs can sometimes get shuffled and may
444 * be out of order. Just to be safe */
445 switch (A_TYPEG(A_LOPG(ast))) {
446 case A_WHERE:
447 wherelevel++;
448 break;
449 case A_ENDWHERE:
450 wherelevel--;
451 break;
452 }
453 break;
454 }
455 break;
456 case IN_SINGLE:
457 switch (A_TYPEG(ast)) {
458 case A_MP_ENDWORKSHARE:
459 gen_endsingle(std, single, presinglebarrier);
460 presinglebarrier = 0;
461 state = NO_WRKSHR;
462 break;
463 case A_DO:
464 prevast = STD_AST(STD_PREV(std));
465 if (A_TYPEG(prevast) == A_COMMENT &&
466 A_TYPEG(A_LOPG(prevast)) == A_FORALL) {
467 gen_endsingle(STD_PREV(std), single, presinglebarrier);
468 presinglebarrier = 0;
469 ompast = gen_pdo(ast);
470 newstd = add_stmt_before(ompast, std);
471 if (parallel_depth > 1)
472 STD_PAR(newstd) = 1;
473 dolevel++;
474 state = IN_PDO;
475 ast_to_comment(ast);
476 } else {
477 dolevel++;
478 }
479 break;
480 case A_ENDDO:
481 dolevel--;
482 break;
483 case A_COMMENT:
484 switch (A_TYPEG(A_LOPG(ast))) {
485 case A_FORALL:
486 gen_endsingle(std, single, presinglebarrier);
487 presinglebarrier = 0;
488 state = IN_WRKSHR;
489 break;
490 }
491 break;
492 case A_MP_PARALLEL:
493 state = IN_PARALLEL;
494 parallellevel++;
495 break;
496 case A_MP_CRITICAL:
497 state = IN_CRITICAL;
498 break;
499 }
500 break;
501 case IN_PARALLEL:
502 switch (A_TYPEG(ast)) {
503 case A_MP_PARALLEL:
504 parallellevel++;
505 break;
506 case A_MP_ENDPARALLEL:
507 if (--parallellevel == 0) {
508 state = IN_SINGLE;
509 }
510 break;
511 }
512 if (newstd)
513 STD_PAR(newstd) = 1;
514
515 break;
516 case IN_CRITICAL:
517 if (A_TYPEG(ast) == A_MP_ENDCRITICAL) {
518 state = IN_SINGLE;
519 }
520 break;
521 }
522 }
523 }
524
525 static LOGICAL
no_effect_forall(int std)526 no_effect_forall(int std)
527 {
528 int forall;
529 int asn;
530 int count;
531 int fusedstd;
532 int nd;
533 int i;
534
535 count = 0;
536 forall = STD_AST(std);
537 asn = A_IFSTMTG(forall);
538 if (A_SRCG(asn) == A_DESTG(asn))
539 count++;
540 nd = A_OPT1G(forall);
541 for (i = 0; i < FT_NFUSE(nd, 0); i++) {
542 fusedstd = FT_FUSEDSTD(nd, 0, i);
543 forall = STD_AST(fusedstd);
544 asn = A_IFSTMTG(forall);
545 if (A_SRCG(asn) == A_DESTG(asn))
546 count++;
547 }
548
549 if (count == FT_NFUSE(nd, 0) + 1) {
550 delete_stmt(std);
551 return TRUE;
552 }
553 return FALSE;
554 }
555
556 /*
557 * replace pghpf_lbound/pghpf_ubound(dim,descriptor)
558 */
559 static int
_pghpf_bound(int lbound,int ast)560 _pghpf_bound(int lbound, int ast)
561 {
562 int argt, arg0, arg1, dim, ss[1], dtype, newast, offset;
563 newast = ast;
564 argt = A_ARGSG(ast);
565 arg0 = ARGT_ARG(argt, 0);
566 arg1 = ARGT_ARG(argt, 1);
567 if ((A_TYPEG(arg1) == A_ID && DESCARRAYG(A_SPTRG(arg1))) ||
568 (A_TYPEG(arg1) == A_MEM && DESCARRAYG(A_SPTRG(A_MEMG(arg1))))) {
569 /* arg1 is a section descriptor */
570 dtype = A_DTYPEG(arg1);
571 if (A_ALIASG(arg0)) {
572 arg0 = A_ALIASG(arg0);
573 /* get constant value */
574 dim = get_int_cval(A_SPTRG(arg0));
575 offset = get_global_lower_index(dim - 1);
576 ss[0] = mk_cval((INT)offset, DT_INT);
577 newast = mk_subscr(arg1, ss, 1, DDTG(dtype));
578 if (!lbound) {
579 int a, b;
580 offset = get_global_extent_index(dim - 1);
581 ss[0] = mk_cval((INT)offset, DT_INT);
582 b = mk_subscr(arg1, ss, 1, DDTG(dtype));
583 a = mk_cval(1, astb.bnd.dtype);
584 b = mk_binop(OP_SUB, b, a, astb.bnd.dtype);
585 newast = mk_binop(OP_ADD, b, newast, astb.bnd.dtype);
586 }
587 } else {
588 /* dimension is not constant, compute offset */
589 int base;
590 int arg0decr = mk_binop(OP_SUB, arg0, astb.i1, DT_INT);
591 base = get_global_lower_index(0);
592 offset = get_global_lower_index(1);
593 offset = offset - base;
594 ss[0] = mk_cval((INT)(offset), DT_INT);
595 ss[0] = mk_binop(OP_MUL, arg0decr, ss[0], DT_INT);
596 ss[0] = mk_binop(OP_ADD, mk_cval((INT)base, DT_INT), ss[0], DT_INT);
597 newast = mk_subscr(arg1, ss, 1, DDTG(dtype));
598 if (!lbound) {
599 int a, b;
600 base = get_global_extent_index(0);
601 ss[0] = mk_cval((INT)(offset), DT_INT);
602 ss[0] = mk_binop(OP_MUL, arg0decr, ss[0], DT_INT);
603 ss[0] = mk_binop(OP_ADD, mk_cval((INT)base, DT_INT), ss[0], DT_INT);
604 b = mk_subscr(arg1, ss, 1, DDTG(dtype));
605 a = mk_cval(1, astb.bnd.dtype);
606 b = mk_binop(OP_SUB, b, a, astb.bnd.dtype);
607 newast = mk_binop(OP_ADD, b, newast, astb.bnd.dtype);
608 }
609 }
610 }
611 return newast;
612 } /* _pghpf_bound */
613
614 /*
615 * replace pghpf_size(dim,descriptor)/pghpf_extent(descriptor,dim)
616 */
617 static int
_pghpf_size(int size,int ast)618 _pghpf_size(int size, int ast)
619 {
620 int argt, arg0, arg1, dim, ss[1], dtype, newast, offset;
621 newast = ast;
622 argt = A_ARGSG(ast);
623 if (size) {
624 arg0 = ARGT_ARG(argt, 0); /* dim */
625 arg1 = ARGT_ARG(argt, 1); /* section descriptor */
626 } else {
627 arg0 = ARGT_ARG(argt, 1); /* dim */
628 arg1 = ARGT_ARG(argt, 0); /* section descriptor */
629 }
630 if ((A_TYPEG(arg1) == A_ID && DESCARRAYG(A_SPTRG(arg1))) ||
631 (A_TYPEG(arg1) == A_MEM && DESCARRAYG(A_SPTRG(A_MEMG(arg1))))) {
632 /* arg1 is a section descriptor */
633 dtype = A_DTYPEG(arg1);
634 if (arg0 == astb.ptr0) {
635 /* global size */
636 ss[0] = mk_cval(get_desc_gsize_index(), DT_INT);
637 newast = mk_subscr(arg1, ss, 1, DDTG(dtype));
638 } else if (A_ALIASG(arg0)) {
639 arg0 = A_ALIASG(arg0);
640 /* get constant value */
641 dim = get_int_cval(A_SPTRG(arg0));
642 offset = get_global_extent_index(dim - 1);
643 ss[0] = mk_cval((INT)offset, DT_INT);
644 newast = mk_subscr(arg1, ss, 1, DDTG(dtype));
645 } else {
646 /* dimension is not constant, compute offset */
647 int base;
648 int arg0decr = mk_binop(OP_SUB, arg0, astb.i1, DT_INT);
649 base = get_global_extent_index(0);
650 offset = get_global_extent_index(1);
651 ss[0] = mk_cval((INT)(offset - base), DT_INT);
652 ss[0] = mk_binop(OP_MUL, arg0decr, ss[0], DT_INT);
653 ss[0] = mk_binop(OP_ADD, mk_cval((INT)base, DT_INT), ss[0], DT_INT);
654 newast = mk_subscr(arg1, ss, 1, DDTG(dtype));
655 }
656 }
657 return newast;
658 } /* _pghpf_size */
659
660 /*
661 * replace RTE_size(rank,dim,l1,u1,s1,l2,u2,s2,...)
662 */
663 static int
_RTE_size(int ast)664 _RTE_size(int ast)
665 {
666 int argt, arg0, arg1, argl, argu, args, rank, dim, newast, i;
667 newast = ast;
668 argt = A_ARGSG(ast);
669 arg0 = ARGT_ARG(argt, 0); /* rank */
670 arg1 = ARGT_ARG(argt, 1); /* dim */
671 if (A_ALIASG(arg0)) {
672 arg0 = A_ALIASG(arg0);
673 rank = get_int_cval(A_SPTRG(arg0));
674 if (A_ARGCNTG(ast) == rank * 3 + 2) {
675 if (arg1 == astb.ptr0) {
676 newast = 0;
677 for (i = 0; i < rank; ++i) {
678 int a;
679 argl = ARGT_ARG(argt, i * 3 + 2);
680 argu = ARGT_ARG(argt, i * 3 + 3);
681 args = ARGT_ARG(argt, i * 3 + 4);
682 a = mk_binop(OP_SUB, argu, argl, A_DTYPEG(argl));
683 a = mk_binop(OP_ADD, a, args, A_DTYPEG(argl));
684 if (args != astb.i1 && args != astb.bnd.one) {
685 a = mk_binop(OP_DIV, a, args, A_DTYPEG(argl));
686 }
687 if (!newast) {
688 newast = a;
689 } else {
690 newast = mk_binop(OP_MUL, newast, a, A_DTYPEG(a));
691 }
692 }
693 } else if (A_ALIASG(arg1)) {
694 arg1 = A_ALIASG(arg1);
695 dim = get_int_cval(A_SPTRG(arg1));
696 if (dim >= 1 && dim <= rank) {
697 int a;
698 argl = ARGT_ARG(argt, (dim - 1) * 3 + 2);
699 argu = ARGT_ARG(argt, (dim - 1) * 3 + 3);
700 args = ARGT_ARG(argt, (dim - 1) * 3 + 4);
701 a = mk_binop(OP_SUB, argu, argl, A_DTYPEG(argl));
702 a = mk_binop(OP_ADD, a, args, A_DTYPEG(argl));
703 if (args != astb.i1 && args != astb.bnd.one) {
704 a = mk_binop(OP_DIV, a, args, A_DTYPEG(argl));
705 }
706 newast = a;
707 }
708 }
709 }
710 }
711 return newast;
712 } /* _RTE_size */
713
714 /*
715 * replace pgi_element_size( array )
716 */
717 static int
_pgi_element_size(int ast)718 _pgi_element_size(int ast)
719 {
720 int argt, arg0, sptr, dtype, ret;
721 argt = A_ARGSG(ast);
722 arg0 = ARGT_ARG(argt, 0); /* variable or array */
723 sptr = memsym_of_ast(arg0);
724 if (sptr <= NOSYM) {
725 return astb.i0;
726 }
727 dtype = DDTG(DTYPEG(sptr));
728 ret = mk_cval(size_of(dtype), DT_INT);
729 return ret;
730 } /* _pgi_element_size */
731
732 /*
733 * replace pgi_kind( array )
734 */
735 static int
_pgi_kind(int ast)736 _pgi_kind(int ast)
737 {
738 int argt, arg0, sptr, dtype, ret;
739 argt = A_ARGSG(ast);
740 arg0 = ARGT_ARG(argt, 0); /* variable or array */
741 sptr = memsym_of_ast(arg0);
742 if (sptr <= NOSYM) {
743 return astb.i0;
744 }
745 dtype = DDTG(DTYPEG(sptr));
746 ret = mk_cval(dtype_to_arg(dtype), DT_INT);
747 return ret;
748 } /* _pgi_kind */
749
750 /*
751 * return an expression that gives the size of dimension i of a shape
752 * descriptor
753 */
754 static int
size_shape(int shape,int i)755 size_shape(int shape, int i)
756 {
757 int a, mask;
758 int args = SHD_STRIDE(shape, i);
759 int argl = SHD_LWB(shape, i);
760 int argu = SHD_UPB(shape, i);
761 a = mk_binop(OP_SUB, argu, argl, astb.bnd.dtype);
762 a = mk_binop(OP_ADD, a, args, astb.bnd.dtype);
763 a = mk_binop(OP_DIV, a, args, astb.bnd.dtype);
764 mask = mk_binop(OP_GE, argu, argl, DT_LOG);
765 a = mk_merge(a, astb.bnd.zero, mask, astb.bnd.dtype);
766 if (astb.bnd.dtype != stb.user.dt_int) {
767 /* -i8: type of size is integer*8 so convert result */
768 a = mk_convert(a, stb.user.dt_int);
769 }
770 return a;
771 } /* size_shape */
772
773 /*
774 * replace size(array,dim) (from shape descriptor)
775 */
776 static int
_PDsize(int ast)777 _PDsize(int ast)
778 {
779 int argt, argdim, arg, dim, ss[1], dtype, newast, offset, argsym, argsdsc;
780 int rank;
781 newast = ast;
782 argt = A_ARGSG(ast);
783 arg = ARGT_ARG(argt, 0); /* section descriptor */
784 argdim = ARGT_ARG(argt, 1); /* dim */
785 argsym = 0;
786 argsdsc = 0;
787 if (A_TYPEG(arg) == A_ID) {
788 argsym = A_SPTRG(arg);
789 } else if (A_TYPEG(arg) == A_MEM) {
790 argsym = A_SPTRG(A_MEMG(arg));
791 }
792 if (argsym) {
793 argsdsc = SDSCG(argsym);
794 if (!argsdsc || !DESCUSEDG(argsdsc) || !DESCARRAYG(argsdsc) ||
795 DTY(DTYPEG(argsym)) != TY_ARRAY) {
796 argsdsc = 0;
797 }
798 }
799 dtype = A_DTYPEG(arg);
800 if (argsdsc) {
801 /* arg is an array and has a section descriptor */
802 if (argdim == astb.ptr0) {
803 /* global size */
804 ss[0] = mk_cval(get_desc_gsize_index(), DT_INT);
805 } else if (A_ALIASG(argdim)) {
806 argdim = A_ALIASG(argdim);
807 /* get constant value */
808 dim = get_int_cval(A_SPTRG(argdim));
809 offset = get_global_extent_index(dim - 1);
810 ss[0] = mk_cval((INT)offset, DT_INT);
811 } else {
812 /* dimension is not constant, compute offset */
813 int base;
814 base = get_global_extent_index(0);
815 offset = get_global_extent_index(1);
816 ss[0] = mk_cval((INT)(offset - base), DT_INT);
817 ss[0] = mk_binop(OP_MUL, argdim, ss[0], DT_INT);
818 ss[0] = mk_binop(OP_ADD, mk_cval(base - (offset - base), DT_INT), ss[0],
819 DT_INT);
820 }
821 newast = mk_subscr(mk_id(argsdsc), ss, 1, DTYPEG(argsdsc));
822 newast = check_member(arg, newast);
823 } else {
824 /* compute size from the shape descriptor */
825 int shape, i;
826
827 shape = A_SHAPEG(arg); /* this shape is always stride one */
828 rank = SHD_NDIM(shape);
829 if (argdim == astb.ptr0) {
830 /* global size */
831 newast = 0;
832 for (i = 0; i < rank; ++i) {
833 int a, args;
834 args = SHD_STRIDE(shape, i);
835 if (args != astb.i1 && args != astb.bnd.one) {
836 return ast;
837 }
838 a = size_shape(shape, i);
839 if (!newast) {
840 newast = a;
841 } else {
842 newast = mk_binop(OP_MUL, newast, a, A_DTYPEG(a));
843 }
844 }
845 } else if (A_ALIASG(argdim)) {
846 argdim = A_ALIASG(argdim);
847 /* get constant value */
848 dim = get_int_cval(A_SPTRG(argdim));
849 newast = size_shape(shape, dim - 1);
850 } else {
851 /* dimension is not constant, give up */
852 newast = ast;
853 }
854 }
855 return newast;
856 } /* _PDsize */
857
858 /**
859 * \brief Used to simplify PD_lbound or PD_ubound call ast nodes to the value
860 * from shape descriptor of adjustable array.
861 * \param lbound Flag which represents whether this is a call to lbound routine.
862 * When set to zero, it means call is to ubound.
863 * \param ast The AST node representing the call to lbound/ubound.
864 * \return AST node representing value extracted from shape.
865 */
866 static int
_PDbound(int lbound,int ast)867 _PDbound(int lbound, int ast)
868 {
869 int argt, argdim, arg, dim;
870 int rank, shape, bound;
871 argt = A_ARGSG(ast);
872 arg = ARGT_ARG(argt, 0);
873 argdim = ARGT_ARG(argt, 1);
874 /* The implementation requires that argument is an array and that dimension argument
875 is a constant. */
876 if (A_TYPEG(arg) == A_ID &&
877 DTY(A_DTYPEG(arg)) == TY_ARRAY &&
878 A_ALIASG(argdim)) {
879 shape = A_SHAPEG(arg);
880 /* Replacement of bound call can only happen if shape is known */
881 if (shape) {
882 rank = SHD_NDIM(shape);
883 argdim = A_ALIASG(argdim);
884 dim = get_int_cval(A_SPTRG(argdim));
885 if (lbound) {
886 bound = SHD_LWB(shape, dim - 1);
887 } else {
888 bound = SHD_UPB(shape, dim - 1);
889 }
890 return bound;
891 }
892 }
893
894 return ast;
895 } /* _PDbound */
896
897 /*
898 * replace RTE_lbound/RTE_ubound(rank,dim,b1,b2,b3,...)
899 */
900 static int
_RTE_bound(int lbound,int ast)901 _RTE_bound(int lbound, int ast)
902 {
903 int argt, arg0, arg1, rank, dim, newast;
904 newast = ast;
905 argt = A_ARGSG(ast);
906 arg0 = ARGT_ARG(argt, 0); /* rank */
907 arg1 = ARGT_ARG(argt, 1); /* dim */
908 if (A_ALIASG(arg0)) {
909 arg0 = A_ALIASG(arg0);
910 rank = get_int_cval(A_SPTRG(arg0));
911 if (A_ARGCNTG(ast) == rank + 2) {
912 if (A_ALIASG(arg1)) {
913 arg1 = A_ALIASG(arg1);
914 dim = get_int_cval(A_SPTRG(arg1));
915 if (dim >= 1 && dim <= rank) {
916 newast = ARGT_ARG(argt, (dim - 1) + 2 + (lbound ? 0 : 1));
917 }
918 }
919 }
920 }
921 return newast;
922 } /* _RTE_bound */
923
924 /*
925 * replace RTE_lb/RTE_ub(rank,dim,l1,u1,l1,u2,...)
926 */
927 static int
_RTE_xb(int lbound,int ast,int rdt,int dolong)928 _RTE_xb(int lbound, int ast, int rdt, int dolong)
929 {
930 int argt, arg0, arg1, rank, dim, newast;
931 newast = ast;
932 argt = A_ARGSG(ast);
933 arg0 = ARGT_ARG(argt, 0); /* rank */
934 arg1 = ARGT_ARG(argt, 1); /* dim */
935 if (A_ALIASG(arg0)) {
936 arg0 = A_ALIASG(arg0);
937 rank = get_int_cval(A_SPTRG(arg0));
938 if (A_ARGCNTG(ast) == 2 * rank + 2) {
939 if (A_ALIASG(arg1)) {
940 arg1 = A_ALIASG(arg1);
941 dim = get_int_cval(A_SPTRG(arg1));
942 if (dim >= 1 && dim <= rank) {
943 int tsource, fsource, mask; /* merge arguemnts */
944 int ub, lb;
945 lb = ARGT_ARG(argt, 2 * (dim - 1) + 2);
946 ub = ARGT_ARG(argt, 2 * (dim - 1) + 2 + 1);
947 if (lbound) {
948 tsource = lb;
949 fsource = astb.bnd.one;
950 } else {
951 tsource = ub;
952 fsource = astb.bnd.zero;
953 }
954 mask = mk_binop(OP_LE, lb, ub, DT_LOG);
955 newast = mk_merge(tsource, fsource, mask, dolong ? DT_INT8 : DT_INT);
956 if (rdt) {
957 newast = mk_convert(newast, rdt);
958 }
959 }
960 }
961 }
962 }
963 return newast;
964 } /* _RTE_xb */
965
966 /*
967 * replace RTE_uba and RTE_lba
968 */
969 static int
_RTE_ba(int lbound,int ast)970 _RTE_ba(int lbound, int ast)
971 {
972 int argt, arg0, arg1, rank, dim, lhs, rhs, ss[1];
973 int ub, lb, newif, cmp, newstd;
974
975 argt = A_ARGSG(ast);
976 arg0 = ARGT_ARG(argt, 0); /* result array */
977 arg1 = ARGT_ARG(argt, 1); /* rank */
978 if (A_ALIASG(arg1)) {
979 arg1 = A_ALIASG(arg1);
980 rank = get_int_cval(A_SPTRG(arg1));
981 if (A_ARGCNTG(ast) == rank * 2 + 2) {
982 for (dim = 1; dim <= rank; dim++) {
983 lb = ARGT_ARG(argt, (dim - 1) * 2 + 2);
984 ub = ARGT_ARG(argt, (dim - 1) * 2 + 3);
985 ss[0] = mk_cval((INT)dim, DT_INT);
986 lhs = mk_subscr(arg0, ss, 1, DT_INT);
987
988 if (dim == rank && ub == astb.ptr0) {
989 /*
990 * Special case for F77 assumed size arrays which
991 * have no upper bound in the last dimension.
992 */
993 rhs = (lbound ? lb : astb.bnd.zero);
994 insert_assign(lhs, rhs, beforestd);
995 } else if (lbound && (lb == astb.i1 || lb == astb.bnd.one)) {
996 /*
997 * Special case for constant one lower bound.
998 * No need for the if-then-else.
999 */
1000 insert_assign(lhs, lb, beforestd);
1001 } else {
1002 /* if (lb <= ub) ... */
1003 newif = mk_stmt(A_IFTHEN, 0);
1004 cmp = mk_binop(OP_LE, lb, ub, DT_LOG);
1005 A_IFEXPRP(newif, cmp);
1006 newstd = add_stmt_before(newif, beforestd);
1007 STD_PAR(newstd) = STD_PAR(beforestd);
1008 STD_TASK(newstd) = STD_TASK(beforestd);
1009 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1010 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1011
1012 /* lhs = (lbound ? lb : ub) */
1013 rhs = (lbound ? lb : ub);
1014 insert_assign(lhs, rhs, beforestd);
1015
1016 /* else */
1017 newif = mk_stmt(A_ELSE, 0);
1018 newstd = add_stmt_before(newif, beforestd);
1019 STD_PAR(newstd) = STD_PAR(beforestd);
1020 STD_TASK(newstd) = STD_TASK(beforestd);
1021 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1022 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1023
1024 /* lhs = (lbound ? 1 : 0) */
1025 rhs = (lbound ? astb.bnd.one : astb.bnd.zero);
1026 insert_assign(lhs, rhs, beforestd);
1027
1028 /* end if */
1029 newif = mk_stmt(A_ENDIF, 0);
1030 newstd = add_stmt_before(newif, beforestd);
1031 STD_PAR(newstd) = STD_PAR(beforestd);
1032 STD_TASK(newstd) = STD_TASK(beforestd);
1033 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1034 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1035 }
1036 }
1037 ast_to_comment(ast);
1038 }
1039 }
1040 return ast;
1041 }
1042
1043 /*
1044 * return operand of %val(), else just return the ast
1045 */
1046 static int
value(int ast)1047 value(int ast)
1048 {
1049 if (ast > 0 && A_TYPEG(ast) == A_UNOP &&
1050 (A_OPTYPEG(ast) == OP_VAL || A_OPTYPEG(ast) == OP_BYVAL))
1051 ast = A_LOPG(ast);
1052 if (ast > 0 && A_ALIASG(ast))
1053 ast = A_ALIASG(ast);
1054 return ast;
1055 } /* value */
1056
1057 /*
1058 * put value in a symbol if it's an expression
1059 */
1060 static int
symvalue(int ast,char c,int num,int * ptemp,int var,int sdsc)1061 symvalue(int ast, char c, int num, int *ptemp, int var, int sdsc)
1062 {
1063 int temp, newasn, newstd, a;
1064 ast = value(ast);
1065 if (!var && (A_TYPEG(ast) == A_ID || A_TYPEG(ast) == A_CNST))
1066 return ast;
1067 if (A_TYPEG(ast) == A_SUBSCR && A_TYPEG(A_LOPG(ast)) == A_ID &&
1068 (sdsc > 0 ? A_SPTRG(A_LOPG(ast)) == sdsc
1069 : DESCARRAYG(A_SPTRG(A_LOPG(ast)))))
1070 return ast;
1071 if (*ptemp == 0) {
1072 *ptemp = temp = getnewccsymf(ST_VAR, ".c%d_%d", num, newsymnum++);
1073 SCP(temp, SC_LOCAL);
1074 DTYPEP(temp, astb.bnd.dtype);
1075 if (STD_PAR(beforestd) || STD_TASK(beforestd))
1076 SCP(temp, SC_PRIVATE);
1077 }
1078 a = mk_id(*ptemp);
1079 if (ast == a)
1080 return ast;
1081 newasn = mk_stmt(A_ASN, 0);
1082 A_DESTP(newasn, a);
1083 A_SRCP(newasn, ast);
1084 newstd = add_stmt_before(newasn, beforestd);
1085 STD_PAR(newstd) = STD_PAR(beforestd);
1086 STD_TASK(newstd) = STD_TASK(beforestd);
1087 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1088 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1089 return a;
1090 } /* symvalue */
1091
1092 /*
1093 * see above
1094 */
1095 static void
_simple_replacements(int ast,int * pany)1096 _simple_replacements(int ast, int *pany)
1097 {
1098 if (A_TYPEG(ast) == A_FUNC || A_TYPEG(ast) == A_CALL) {
1099 int lop;
1100 lop = A_LOPG(ast);
1101 if (lop && A_TYPEG(lop) == A_ID) {
1102 int fsptr;
1103 fsptr = A_SPTRG(lop);
1104 if (HCCSYMG(fsptr) && STYPEG(fsptr) == ST_PROC) {
1105 /* compiler created function */
1106 int newast;
1107 char *fname;
1108 int in_device_code;
1109 fname = SYMNAME(fsptr);
1110 newast = ast;
1111 in_device_code = 0;
1112 if (strcmp(fname, mkRteRtnNm(RTE_lboundDsc)) == 0) {
1113 newast = _pghpf_bound(1, ast);
1114 } else if (strcmp(fname, mkRteRtnNm(RTE_uboundDsc)) == 0) {
1115 newast = _pghpf_bound(0, ast);
1116 } else if (strcmp(fname, mkRteRtnNm(RTE_extent)) == 0) {
1117 newast = _pghpf_size(0, ast);
1118 } else if (strcmp(fname, mkRteRtnNm(RTE_sizeDsc)) == 0) {
1119 newast = _pghpf_size(1, ast);
1120 } else if (strcmp(fname, mkRteRtnNm(RTE_size)) == 0) {
1121 newast = _RTE_size(ast);
1122 } else if (strcmp(fname, mkRteRtnNm(RTE_lbound)) == 0) {
1123 newast = _RTE_bound(1, ast);
1124 } else if (strcmp(fname, mkRteRtnNm(RTE_ubound)) == 0) {
1125 newast = _RTE_bound(0, ast);
1126 } else if (strcmp(fname, mkRteRtnNm(RTE_lba)) == 0) {
1127 if (in_device_code || XBIT(137, 0x20))
1128 newast = _RTE_ba(1, ast);
1129 } else if (strcmp(fname, mkRteRtnNm(RTE_uba)) == 0) {
1130 if (in_device_code || XBIT(137, 0x20))
1131 newast = _RTE_ba(0, ast);
1132 } else if (strcmp(fname, mkRteRtnNm(RTE_extent)) == 0) {
1133 newast = _pghpf_size(0, ast);
1134 } else if (strcmp(fname, mkRteRtnNm(RTE_sizeDsc)) == 0) {
1135 newast = _pghpf_size(1, ast);
1136 } else if (strcmp(fname, mkRteRtnNm(RTE_size)) == 0) {
1137 newast = _RTE_size(ast);
1138 } else if (strcmp(fname, mkRteRtnNm(RTE_lbound)) == 0) {
1139 newast = _RTE_bound(1, ast);
1140 } else if (strcmp(fname, mkRteRtnNm(RTE_ubound)) == 0) {
1141 newast = _RTE_bound(0, ast);
1142 } else if (strcmp(fname, mkRteRtnNm(RTE_lba)) == 0) {
1143 if (in_device_code || XBIT(137, 0x20))
1144 newast = _RTE_ba(1, ast);
1145 } else if (strcmp(fname, mkRteRtnNm(RTE_uba)) == 0) {
1146 if (in_device_code || XBIT(137, 0x20))
1147 newast = _RTE_ba(0, ast);
1148 } else if (strcmp(fname, mkRteRtnNm(RTE_lb)) == 0) {
1149 /* Last arg:
1150 * large arrays || ub/lb retval is 8 byte int || int is 8 byte
1151 */
1152 newast = _RTE_xb(1, ast, 0,
1153 XBIT(68, 0x1) || XBIT(86, 0x2) || XBIT(128, 0x10));
1154 } else if (strcmp(fname, mkRteRtnNm(RTE_ub)) == 0) {
1155 /* Last arg:
1156 * large arrays || ub/lb retval is 8 byte int || int is 8 byte
1157 */
1158 newast = _RTE_xb(0, ast, 0,
1159 XBIT(68, 0x1) || XBIT(86, 0x2) || XBIT(128, 0x10));
1160 }
1161 if (newast != ast) {
1162 if (A_DTYPEG(newast) != A_DTYPEG(ast))
1163 newast = mk_convert(newast, A_DTYPEG(ast));
1164 ast_replace(ast, newast);
1165 *pany = *pany + 1;
1166 }
1167 } else if (XBIT(57, 0x4000000)) {
1168 int newast;
1169 char *fname;
1170 fname = SYMNAME(fsptr);
1171 newast = ast;
1172 if (strcmp(fname, "pgi_element_size") == 0) {
1173 newast = _pgi_element_size(ast);
1174 } else if (strcmp(fname, "pgi_kind") == 0) {
1175 newast = _pgi_kind(ast);
1176 }
1177 if (newast != ast) {
1178 if (A_DTYPEG(newast) != A_DTYPEG(ast))
1179 newast = mk_convert(newast, A_DTYPEG(ast));
1180 ast_replace(ast, newast);
1181 *pany = *pany + 1;
1182 }
1183 }
1184 }
1185 } else if (A_TYPEG(ast) == A_INTR) {
1186 int lop;
1187 lop = A_LOPG(ast);
1188 if (lop && A_TYPEG(lop) == A_ID) {
1189 int fsptr;
1190 fsptr = A_SPTRG(lop);
1191 if (STYPEG(fsptr) == ST_PD) {
1192 /* predeclared procedure */
1193 int newast;
1194 newast = ast;
1195 if (PDNUMG(fsptr) == PD_size) {
1196 /* size(array,dim) ==> array$sd( extent(dim) ) if there is a $sd
1197 * ==> ubound(array,dim)-lbound(array,dim)+1 else
1198 * size(array,<0>) ==> array$sd( gsize ) if there is a $sd
1199 * ==> product(ubound(array,dim)-lbound(array,dim)+1)
1200 *else
1201 * size(expr,dim) ==> ubound(shape,dim)-lbound(shape,dim)+1
1202 * size(expr,dim) ==> product(ubound(shape,dim)-lbound(shape,dim)+1)
1203 */
1204 newast = _PDsize(ast);
1205 } else if (PDNUMG(fsptr) == PD_lbound) {
1206 newast = _PDbound(1, ast);
1207 } else if (PDNUMG(fsptr) == PD_ubound) {
1208 newast = _PDbound(0, ast);
1209 }
1210 if (newast != ast) {
1211 if (A_DTYPEG(newast) != A_DTYPEG(ast))
1212 newast = mk_convert(newast, A_DTYPEG(ast));
1213 ast_replace(ast, newast);
1214 *pany = *pany + 1;
1215 }
1216 }
1217 }
1218 }
1219 } /* _simple_replacements */
1220
1221 static void
convert_simple(void)1222 convert_simple(void)
1223 {
1224 int std, stdnext;
1225 int ast, any;
1226
1227 for (std = STD_NEXT(0); std; std = stdnext) {
1228 stdnext = STD_NEXT(std);
1229 ast = STD_AST(std);
1230 ast_visit(1, 1);
1231 any = 0; /* any replacements found? */
1232 beforestd = std;
1233 ast_traverse(ast, NULL, _simple_replacements, &any);
1234 if (any) {
1235 ast = ast_rewrite(ast);
1236 STD_AST(std) = ast;
1237 A_STDP(ast, std);
1238 }
1239 ast_unvisit();
1240 }
1241 } /* convert_simple */
1242
1243 /*
1244 * check that this is a single subscript with constant value as given
1245 */
1246 static int
check_subscript(int ast,int value)1247 check_subscript(int ast, int value)
1248 {
1249 int asd, ss, val;
1250 asd = A_ASDG(ast);
1251 if (ASD_NDIM(asd) != 1)
1252 return 0;
1253 ss = ASD_SUBS(asd, 0);
1254 if (A_TYPEG(ss) != A_CNST)
1255 return 0;
1256 val = get_int_cval(A_SPTRG(ss));
1257 if (value != val)
1258 return 0;
1259 return 1;
1260 } /* check_subscript */
1261
1262 /*
1263 * check that the constant value matches what we expect
1264 */
1265 static int
check_value(int ast,int value)1266 check_value(int ast, int value)
1267 {
1268 int val;
1269 if (A_TYPEG(ast) != A_CNST)
1270 return 0;
1271 val = get_int_cval(A_SPTRG(ast));
1272 if (value != val)
1273 return 0;
1274 return 1;
1275 } /* check_value */
1276
1277 /*
1278 * for RTE_sect calls, see if the lower bound / upper bound / stride
1279 * arguments for this dimension are the corresponding full dimension.
1280 * lower bound = section descriptor(lbound)
1281 * upper bound = section descriptor(ubound) OR
1282 * upper bound = section descriptor(lbound) + (section descriptor(extent)-1)
1283 * stride = 1
1284 */
1285 static int
full_dimension(int astlower,int astupper,int aststride,int dim)1286 full_dimension(int astlower, int astupper, int aststride, int dim)
1287 {
1288 int sdsc = 0;
1289 if (!check_value(aststride, 1))
1290 return 0;
1291 if (A_TYPEG(astlower) == A_SUBSCR) {
1292 if (A_TYPEG(A_LOPG(astlower)) != A_ID)
1293 return 0;
1294 sdsc = A_SPTRG(A_LOPG(astlower));
1295 if (!DESCARRAYG(sdsc))
1296 return 0;
1297 if (!check_subscript(astlower, get_global_lower_index(dim)))
1298 return 0;
1299 } else {
1300 return 0;
1301 }
1302 if (A_TYPEG(astupper) == A_SUBSCR) {
1303 if (A_TYPEG(A_LOPG(astupper)) != A_ID)
1304 return 0;
1305 if (A_SPTRG(A_LOPG(astupper)) != sdsc)
1306 return 0;
1307 if (!check_subscript(astupper, get_global_upper_index(dim)))
1308 return 0;
1309 } else if (A_TYPEG(astupper) == A_BINOP && A_OPTYPEG(astupper) == OP_ADD) {
1310 int astleft, astright;
1311 astleft = A_LOPG(astupper);
1312 astright = A_ROPG(astupper);
1313 if (A_TYPEG(astleft) == A_SUBSCR) {
1314 if (A_TYPEG(A_LOPG(astleft)) != A_ID)
1315 return 0;
1316 if (A_SPTRG(A_LOPG(astleft)) != sdsc)
1317 return 0;
1318 if (!check_subscript(astleft, get_global_lower_index(dim)))
1319 return 0;
1320 } else {
1321 return 0;
1322 }
1323 if (A_TYPEG(astright) == A_BINOP && A_OPTYPEG(astright) == OP_SUB) {
1324 astleft = A_LOPG(astright);
1325 astright = A_ROPG(astright);
1326 if (A_TYPEG(astleft) == A_SUBSCR) {
1327 if (A_TYPEG(A_LOPG(astleft)) != A_ID)
1328 return 0;
1329 if (A_SPTRG(A_LOPG(astleft)) != sdsc)
1330 return 0;
1331 if (!check_subscript(astleft, get_global_extent_index(dim)))
1332 return 0;
1333 } else {
1334 return 0;
1335 }
1336 if (!check_value(astright, 1))
1337 return 0;
1338 } else {
1339 return 0;
1340 }
1341 } else {
1342 return 0;
1343 }
1344 return sdsc;
1345 } /* full_dimension */
1346
1347 /*
1348 * insert an assignment statement
1349 */
1350 static void
insert_assign(int lhs,int rhs,int beforestd)1351 insert_assign(int lhs, int rhs, int beforestd)
1352 {
1353 int newasn, newstd;
1354 if (lhs == rhs)
1355 return;
1356 newasn = MKASSN(lhs, rhs);
1357 newstd = add_stmt_before(newasn, beforestd);
1358 STD_PAR(newstd) = STD_PAR(beforestd);
1359 STD_TASK(newstd) = STD_TASK(beforestd);
1360 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1361 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1362 } /* insert_assign */
1363
1364 /*
1365 * replace RTE_sect calls
1366 * RTE_sect( newsd, oldsd, dims, [lower, upper, stride,]... flags )
1367 *
1368 * newsd.rank = rank -- must be constant
1369 * newsd.kind = oldsd.kind
1370 * newsd.bytelen = oldsd.bytelen
1371 * flagstemp = oldsd.flags -- handle constant case here
1372 * newsd.lsize = oldsd.lsize
1373 * newsd.gbase = oldsd.gbase
1374 * d=0
1375 * if flagstemp & SECTZBASE
1376 * lbasetemp = 1
1377 * else
1378 * lbasetemp = oldsd.lbase
1379 * endif
1380 * gsizetemp = 1
1381 * for r = 0 to rank-1 do
1382 * if flags & (1<<r) then -- section dimension
1383 * upper = oldsd.upper[r]
1384 * lower = oldsd.lower[r]
1385 * stride = oldsd.stride[r]
1386 * set extent=upper-lower+stride
1387 * if stride == -1 then extent = -extent
1388 * elseif stride != 1 then extent /= stride; endif
1389 * if flags & SECTZBASE then
1390 * if extent < 0 then extent = 0 endif
1391 * newsd[d].lbound = 1
1392 * newsd[d].ubound = extent
1393 * newsd[d].lstride = stride * oldsd[r].lstride
1394 * lbasetemp -= newsd[d].lstride
1395 * else
1396 * if extent < 0 then extent = 0; upper = lower-1; stride=1; endif
1397 * newsd[d].extent = extent
1398 * if flags & NOREINDEX and stride == 1 then
1399 * newsd[d].lbound = lower
1400 * newsd[d].ubound = upper
1401 * set myoffset=0
1402 * else
1403 * newsd[d].lbound = 1
1404 * newsd[d].ubound = extent
1405 * set myoffset = lower-stride
1406 * endif
1407 * newsd[d].lstride = stride * oldsd[r].lstride
1408 * lbasetemp += myoffset * oldsd[r].lstride
1409 * endif
1410 * newsd[d].sstride = 1
1411 * newsd[d].soffset = 0
1412 * if newsd[d].lstride != gsizetemp then reset flagstemp -= SEQUENTIAL_SECTION
1413 *endif
1414 * set gsizetemp *= extent
1415 * ++d
1416 * else
1417 * set lidx = oldsd[r].sstride * oldsd[r].lbound + oldsd[r].soffset =
1418 *oldsd[r].lbound
1419 * set k = oldsd[r].lstride * ( lidx - oldsd[r].lbound )
1420 * = oldsd[r].lstride * ( lower - oldsd[r].lbound )
1421 * = oldsd[r].lstride * lower - oldsd[r].lstride * oldsd[r].lbound
1422 * lbasetemp += k + (oldsd[r].lstride * oldsd[r].lbound)
1423 * += oldsd[r].lstride * lower - oldsd[r].lstride * oldsd[r].lbound
1424 * + (oldsd[r].lstride * oldsd[r].lbound)
1425 * += oldsd[r].lstride * lower
1426 * endif
1427 * endfor
1428 * newsd.flags = flagstemp
1429 * newsd.lbase = lbasetemp
1430 * newsd.tag = DESCRIPTOR
1431 */
1432
1433 #define VALUE_ARGT_ARG(a, b) value(ARGT_ARG(a, b))
1434
1435 static int
_sect(int ast,int i8)1436 _sect(int ast, int i8)
1437 {
1438 #define TAGDESC 35
1439 #define SECTZBASE 0x00400000
1440 #define SEQSECTION 0x20000000
1441 #define TEMPLATE 0x00010000
1442 int argt, newargt, f, funcast;
1443 int astoldsd, astnewsd, astrank, astflags;
1444 int sptroldsd, sptrnewsd;
1445 int rank, flags, dims, dim;
1446 int newstd, gsizeast, astgsize, lbaseast, astlbase;
1447 int flagstemp = 0, flagsast = 0, flagsseq = 1, gsizetemp = 0, lbasetemp = 0;
1448 int needgsize;
1449 int lowertemp = 0, uppertemp = 0, stridetemp = 0, extenttemp = 0;
1450 int myoffset = 0, astoffset = 0;
1451 int newif, cmp, mightbesequential = 1, leading, leadingfull,
1452 computesequential;
1453 int r, d;
1454 int dtype = DT_INT;
1455 if (i8)
1456 dtype = DT_INT8;
1457 argt = A_ARGSG(ast);
1458 astnewsd = ARGT_ARG(argt, 0);
1459 astoldsd = ARGT_ARG(argt, 1);
1460 if (A_TYPEG(astnewsd) != A_ID || A_TYPEG(astoldsd) != A_ID)
1461 return 0;
1462 sptrnewsd = A_SPTRG(astnewsd);
1463 sptroldsd = A_SPTRG(astoldsd);
1464 if (CLASSG(sptrnewsd) || CLASSG(sptroldsd))
1465 return 0;
1466 astrank = VALUE_ARGT_ARG(argt, 2);
1467 if (astrank <= 0)
1468 return 0;
1469 if (A_TYPEG(astrank) != A_CNST)
1470 return 0;
1471 rank = CONVAL2G(A_SPTRG(astrank));
1472 if (A_ARGCNTG(ast) != 3 * rank + 4)
1473 return 0;
1474 astflags = VALUE_ARGT_ARG(argt, 3 * rank + 3);
1475 if (astflags <= 0)
1476 return 0;
1477 if (A_TYPEG(astflags) != A_CNST)
1478 return 0;
1479 flags = CONVAL2G(A_SPTRG(astflags));
1480 if (flags & 0x100) /* BOGUSFLAG */
1481 return 0;
1482 /* output dimensions is the pop count of flags */
1483 dims = (flags & 0x55) + ((flags >> 1) & 0x15);
1484 dims = (dims & 0x33) + ((dims >> 2) & 0x13);
1485 dims += (dims >> 4);
1486 dims = dims & 0xf;
1487 if (dims > rank || dims <= 0)
1488 return 0;
1489 needgsize = 0;
1490 if (XBIT(47, 0x1000000) || SCG(sptroldsd) == SC_CMBLK || gbl.internal == 1 ||
1491 (gbl.internal > 1 && INTERNALG(sptroldsd)) || ARGG(sptroldsd))
1492 needgsize = 1;
1493
1494 /* set newsd.rank = rank */
1495 insert_assign(get_desc_rank(sptrnewsd), mk_isz_cval(dims, astb.bnd.dtype),
1496 beforestd);
1497 /* copy newsd.kind = oldsd.kind */
1498 insert_assign(get_kind(sptrnewsd), get_kind(sptroldsd), beforestd);
1499 /* copy newsd.len = oldsd.len */
1500 #ifdef SDSCCONTIGG
1501 if (SDSCCONTIGG(sptroldsd)) {
1502 insert_assign(get_byte_len(sptrnewsd),
1503 mk_isz_cval(BYTELENG(sptroldsd), astb.bnd.dtype), beforestd);
1504 } else
1505 #endif
1506 {
1507 insert_assign(get_byte_len(sptrnewsd), get_byte_len(sptroldsd), beforestd);
1508 }
1509 /* copy flags_temp = oldsd.flags */
1510 flagsast = get_desc_flags(sptroldsd);
1511 flagsseq = 1;
1512 /* copy newsd.gbase = oldsd.gbase */
1513 insert_assign(get_gbase(sptrnewsd), get_gbase(sptroldsd), beforestd);
1514 if (XBIT(49, 0x100) && !XBIT(49, 0x80000000) && !XBIT(68, 0x1)) {
1515 /* pointers are two ints long */
1516 insert_assign(get_gbase2(sptrnewsd), get_gbase2(sptroldsd), beforestd);
1517 }
1518 /* r runs through old rank; d runs through new dims */
1519 d = 0;
1520 if (flags & SECTZBASE) {
1521 /* set lbasetemp = 1 */
1522 lbaseast = astb.bnd.one;
1523 } else {
1524 /* copy lbasetemp = oldsd.lbase */
1525 lbaseast = get_xbase(sptroldsd);
1526 }
1527
1528 /* might this be a sequential section?
1529 * only if all leading dimensions are sections with stride == 1
1530 */
1531 leading = 1;
1532 leadingfull = 1;
1533 computesequential = 1;
1534 for (r = 0; r < rank; ++r) {
1535 if (!(flags & (1 << r))) {
1536 /* nonvector dimension */
1537 leading = 0;
1538 needgsize = 1;
1539 } else {
1540 int aststride, astlower, astupper;
1541 if (!leading) {
1542 /* vector dimension after nonvector dimension
1543 * like a(:,2,:) can't be sequential */
1544 mightbesequential = 0;
1545 computesequential = 0;
1546 needgsize = 1;
1547 break;
1548 }
1549 aststride = VALUE_ARGT_ARG(argt, 5 + 3 * r);
1550 if (!check_value(aststride, 1)) {
1551 /* a(1:n:2) can't be sequential */
1552 mightbesequential = 0;
1553 computesequential = 0;
1554 needgsize = 1;
1555 break;
1556 }
1557 if (!leadingfull) {
1558 /* a(:,1:n,:) might be sequential */
1559 computesequential = 1;
1560 needgsize = 1;
1561 }
1562 astlower = VALUE_ARGT_ARG(argt, 3 + 3 * r);
1563 astupper = VALUE_ARGT_ARG(argt, 4 + 3 * r);
1564 if (!full_dimension(astlower, astupper, aststride, r)) {
1565 leadingfull = 0;
1566 needgsize = 1;
1567 }
1568 }
1569 }
1570 if (computesequential)
1571 needgsize = 1;
1572 if (needgsize) {
1573 /* create temp to hold global size */
1574 gsizetemp = getnewccsymf(ST_VAR, ".g%d_%d", ast, newsymnum++);
1575 SCP(gsizetemp, SC_LOCAL);
1576 DTYPEP(gsizetemp, astb.bnd.dtype);
1577 if (STD_PAR(beforestd) || STD_TASK(beforestd)) {
1578 SCP(gsizetemp, SC_PRIVATE);
1579 }
1580 gsizeast = astb.bnd.one;
1581 }
1582 if (!mightbesequential && flagsseq) {
1583 f = SEQSECTION;
1584 f = ~f;
1585 newargt = mk_argt(2);
1586 ARGT_ARG(newargt, 0) = flagsast;
1587 ARGT_ARG(newargt, 1) = mk_isz_cval(f, dtype);
1588 flagsast = mk_func_node(A_INTR, mk_id(intast_sym[I_AND]), 2, newargt);
1589 A_OPTYPEP(flagsast, I_AND);
1590 A_DTYPEP(flagsast, dtype);
1591 flagsseq = 0;
1592 }
1593 for (r = 0; r < rank; ++r) {
1594 int astlower = 0, astupper = 0, aststride = 0, astextent = 0, sdsc;
1595 ISZ_T extent, stride;
1596 astlower = VALUE_ARGT_ARG(argt, 3 + 3 * r);
1597 astupper = VALUE_ARGT_ARG(argt, 4 + 3 * r);
1598 aststride = VALUE_ARGT_ARG(argt, 5 + 3 * r);
1599 if (flags & (1 << r)) {
1600 if ((sdsc = full_dimension(astlower, astupper, aststride, r))) {
1601 astlower = symvalue(astlower, 'l', sptrnewsd, &lowertemp, 0, 0);
1602 if ((flags & NOREINDEX) && XBIT(70, 0x800000)) {
1603 /* going to need the upper bound */
1604 astupper =
1605 symvalue(astupper, 'u', sptrnewsd, &uppertemp, 0, sptrnewsd);
1606 }
1607 astextent = get_extent(sdsc, r);
1608 } else {
1609 astlower = symvalue(astlower, 'l', sptrnewsd, &lowertemp, 0, 0);
1610 if (XBIT(70, 0x800000)) {
1611 astupper =
1612 symvalue(astupper, 'u', sptrnewsd, &uppertemp, 0, sptrnewsd);
1613 }
1614 aststride = symvalue(aststride, 's', sptrnewsd, &stridetemp, 0, 0);
1615 /* section dimension */
1616 if (astlower == aststride) {
1617 astextent = astupper;
1618 } else {
1619 /* this is carefully orchestrated.
1620 * if the RTE_sect call was to create a section of another
1621 * descriptor, for instance when we pass a section of an
1622 * array to a subprogram, the call looks like:
1623 * call RTE_sect(..,a$sd(lower),extent+(a$sd(lower)-a$sd(stride))..
1624 * where the upper bound of the section is lower+extent-stride.
1625 * here, we want to organize the expression to cancel out the
1626 * (lower-stride) if we can. */
1627 astextent =
1628 mk_binop(OP_SUB, astlower, aststride, A_DTYPEG(aststride));
1629 astextent =
1630 mk_binop(OP_SUB, astupper, astextent, A_DTYPEG(astextent));
1631 }
1632 astextent =
1633 symvalue(astextent, 'x', sptrnewsd, &extenttemp, 0, sptrnewsd);
1634 if (A_TYPEG(astextent) == A_CNST && A_TYPEG(aststride) == A_CNST) {
1635 extent = CONVAL2G(A_SPTRG(astextent));
1636 stride = CONVAL2G(A_SPTRG(aststride));
1637 if (stride == -1) {
1638 extent = -extent;
1639 } else {
1640 extent = extent / stride;
1641 }
1642 if (extent <= 0) {
1643 stride = 1;
1644 aststride = astb.bnd.one;
1645 if (XBIT(70, 0x800000)) {
1646 astupper =
1647 mk_binop(OP_SUB, astlower, astb.bnd.one, A_DTYPEG(astlower));
1648 }
1649 extent = 0;
1650 astextent = astb.bnd.zero;
1651 } else {
1652 astextent = mk_isz_cval(extent, A_DTYPEG(astextent));
1653 }
1654 } else {
1655 if (A_TYPEG(aststride) == A_CNST) {
1656 stride = CONVAL2G(A_SPTRG(aststride));
1657 if (stride == -1) {
1658 astextent = mk_unop(OP_NEG, astextent, A_DTYPEG(astextent));
1659 } else if (stride != 1) {
1660 astextent =
1661 mk_binop(OP_DIV, astextent, aststride, A_DTYPEG(astextent));
1662 }
1663 astextent =
1664 symvalue(astextent, 'x', sptrnewsd, &extenttemp, 1, sptrnewsd);
1665 } else {
1666 /* generate code to do the divide */
1667 /* if( stride .eq. -1 ) then */
1668
1669 if (A_TYPEG(astextent) == A_CNST) {
1670 astextent = symvalue(astextent, 'x', sptrnewsd, &extenttemp, 1,
1671 sptrnewsd);
1672 }
1673 newif = mk_stmt(A_IFTHEN, 0);
1674 cmp = mk_binop(OP_EQ, aststride,
1675 mk_isz_cval(-1, A_DTYPEG(aststride)), DT_LOG);
1676 A_IFEXPRP(newif, cmp);
1677 newstd = add_stmt_before(newif, beforestd);
1678 STD_PAR(newstd) = STD_PAR(beforestd);
1679 STD_TASK(newstd) = STD_TASK(beforestd);
1680 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1681 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1682 /* extent = -extent */
1683 insert_assign(astextent,
1684 mk_unop(OP_NEG, astextent, A_DTYPEG(astextent)),
1685 beforestd);
1686 /* else if( stride .ne. 1 )then */
1687 newif = mk_stmt(A_ELSEIF, 0);
1688 cmp = mk_binop(OP_NE, aststride, astb.bnd.one, DT_LOG);
1689 A_IFEXPRP(newif, cmp);
1690 newstd = add_stmt_before(newif, beforestd);
1691 STD_PAR(newstd) = STD_PAR(beforestd);
1692 STD_TASK(newstd) = STD_TASK(beforestd);
1693 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1694 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1695 /* extent = extent / stride */
1696 insert_assign(astextent, mk_binop(OP_DIV, astextent, aststride,
1697 A_DTYPEG(astextent)),
1698 beforestd);
1699 /* endif */
1700 newif = mk_stmt(A_ENDIF, 0);
1701 newstd = add_stmt_before(newif, beforestd);
1702 STD_PAR(newstd) = STD_PAR(beforestd);
1703 STD_TASK(newstd) = STD_TASK(beforestd);
1704 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1705 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1706 }
1707 /* make sure upper bound is in a variable */
1708 if (XBIT(70, 0x800000)) {
1709 astupper =
1710 symvalue(astupper, 'u', sptrnewsd, &uppertemp, 1, sptrnewsd);
1711 }
1712 /* if( extent < 0 )then */
1713 newif = mk_stmt(A_IFTHEN, 0);
1714 cmp = mk_binop(OP_LE, astextent, astb.bnd.zero, DT_LOG);
1715 A_IFEXPRP(newif, cmp);
1716 newstd = add_stmt_before(newif, beforestd);
1717 STD_PAR(newstd) = STD_PAR(beforestd);
1718 STD_TASK(newstd) = STD_TASK(beforestd);
1719 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1720 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1721 /* extent = 0 */
1722 insert_assign(astextent, astb.bnd.zero, beforestd);
1723 if (XBIT(70, 0x800000)) {
1724 /* upper = lower-1 */
1725 insert_assign(astupper, mk_binop(OP_SUB, astlower, astb.bnd.one,
1726 A_DTYPEG(astlower)),
1727 beforestd);
1728 }
1729 /* endif */
1730 newif = mk_stmt(A_ENDIF, 0);
1731 newstd = add_stmt_before(newif, beforestd);
1732 STD_PAR(newstd) = STD_PAR(beforestd);
1733 STD_TASK(newstd) = STD_TASK(beforestd);
1734 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1735 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1736 }
1737 }
1738 /* newsd[d].extent = extent */
1739 insert_assign(get_extent(sptrnewsd, d), astextent, beforestd);
1740
1741 if (flags & SECTZBASE) {
1742 /* newsd[d].lbound = 1 */
1743 insert_assign(get_global_lower(sptrnewsd, d), astb.bnd.one, beforestd);
1744 if (XBIT(70, 0x800000)) {
1745 /* newsd[d].ubound = extent */
1746 insert_assign(get_global_upper(sptrnewsd, d), astextent, beforestd);
1747 }
1748 /* newsd[d].lstride = stride * oldsd[r].lstride */
1749 insert_assign(get_local_multiplier(sptrnewsd, d),
1750 mk_binop(OP_MUL, aststride,
1751 get_local_multiplier(sptroldsd, r),
1752 A_DTYPEG(aststride)),
1753 beforestd);
1754 /* lbasetemp -= newsd[d].lstride */
1755 astlbase =
1756 mk_binop(OP_SUB, lbaseast, get_local_multiplier(sptrnewsd, d),
1757 A_DTYPEG(aststride));
1758 lbaseast = symvalue(astlbase, 'b', sptroldsd, &lbasetemp, 1, 0);
1759 } else if ((flags & NOREINDEX) && A_TYPEG(aststride) == A_CNST &&
1760 CONVAL2G(A_SPTRG(aststride)) == 1) {
1761 /* newsd[d].lbound = lower */
1762 insert_assign(get_global_lower(sptrnewsd, d), astlower, beforestd);
1763 if (XBIT(70, 0x800000)) {
1764 /* newsd[d].ubound = upper */
1765 insert_assign(get_global_upper(sptrnewsd, d), astupper, beforestd);
1766 }
1767 /* newsd[d].lstride = stride * oldsd[r].lstride */
1768 insert_assign(get_local_multiplier(sptrnewsd, d),
1769 mk_binop(OP_MUL, aststride,
1770 get_local_multiplier(sptroldsd, r),
1771 A_DTYPEG(aststride)),
1772 beforestd);
1773 } else if ((flags & NOREINDEX)) {
1774 /* if stride == 1 then */
1775 newif = mk_stmt(A_IFTHEN, 0);
1776 cmp = mk_binop(OP_EQ, aststride, astb.bnd.one, DT_LOG);
1777 A_IFEXPRP(newif, cmp);
1778 newstd = add_stmt_before(newif, beforestd);
1779 STD_PAR(newstd) = STD_PAR(beforestd);
1780 STD_TASK(newstd) = STD_TASK(beforestd);
1781 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1782 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1783 /* newsd[d].lbound = lower */
1784 insert_assign(get_global_lower(sptrnewsd, d), astlower, beforestd);
1785 if (XBIT(70, 0x800000)) {
1786 /* newsd[d].ubound = upper */
1787 insert_assign(get_global_upper(sptrnewsd, d), astupper, beforestd);
1788 }
1789 /* set myoffset=0 */
1790 if (myoffset == 0) {
1791 myoffset = getnewccsymf(ST_VAR, ".o%d_%d", ast, newsymnum++);
1792 astlower = symvalue(astlower, 'l', sptrnewsd, &lowertemp, 0, 0);
1793 SCP(myoffset, SC_LOCAL);
1794 DTYPEP(myoffset, astb.bnd.dtype);
1795 if (STD_PAR(beforestd) || STD_TASK(beforestd)) {
1796 SCP(myoffset, SC_PRIVATE);
1797 }
1798 astoffset = mk_id(myoffset);
1799 }
1800 insert_assign(astoffset, astb.bnd.zero, beforestd);
1801 /* else */
1802 newif = mk_stmt(A_ELSE, 0);
1803 newstd = add_stmt_before(newif, beforestd);
1804 STD_PAR(newstd) = STD_PAR(beforestd);
1805 STD_TASK(newstd) = STD_TASK(beforestd);
1806 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1807 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1808 /* newsd[d].lbound = 1 */
1809 insert_assign(get_global_lower(sptrnewsd, d), astb.bnd.one, beforestd);
1810 if (XBIT(70, 0x800000)) {
1811 /* newsd[d].ubound = extent */
1812 insert_assign(get_global_upper(sptrnewsd, d), astextent, beforestd);
1813 }
1814 /* set myoffset = lower-stride */
1815 if (astlower == aststride) {
1816 insert_assign(astoffset, astb.bnd.zero, beforestd);
1817 } else {
1818 insert_assign(astoffset,
1819 mk_binop(OP_SUB, astlower, aststride, astb.bnd.dtype),
1820 beforestd);
1821 }
1822 /* endif */
1823 newif = mk_stmt(A_ENDIF, 0);
1824 newstd = add_stmt_before(newif, beforestd);
1825 STD_PAR(newstd) = STD_PAR(beforestd);
1826 STD_TASK(newstd) = STD_TASK(beforestd);
1827 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1828 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1829 /* newsd[d].lstride = stride * oldsd[r].lstride */
1830 insert_assign(get_local_multiplier(sptrnewsd, d),
1831 mk_binop(OP_MUL, aststride,
1832 get_local_multiplier(sptroldsd, r),
1833 A_DTYPEG(aststride)),
1834 beforestd);
1835 /* lbasetemp += myoffset * oldsd[r].lstride */
1836 astlbase = mk_binop(OP_ADD, lbaseast,
1837 mk_binop(OP_MUL, astoffset,
1838 get_local_multiplier(sptroldsd, r),
1839 A_DTYPEG(aststride)),
1840 A_DTYPEG(aststride));
1841 lbaseast = symvalue(astlbase, 'b', sptroldsd, &lbasetemp, 1, 0);
1842 } else {
1843 int newstride;
1844 /* newsd[d].lbound = 1 */
1845 insert_assign(get_global_lower(sptrnewsd, d), astb.bnd.one, beforestd);
1846 if (XBIT(70, 0x800000)) {
1847 /* newsd[d].ubound = extent */
1848 insert_assign(get_global_upper(sptrnewsd, d), astextent, beforestd);
1849 }
1850 /* newsd[d].lstride = stride * oldsd[r].lstride */
1851 if (r == 0 && SDSCS1G(sptroldsd)) {
1852 /* linear stride of 1st dimension here is always 1 */
1853 newstride = aststride;
1854 #ifdef SDSCCONTIGG
1855 } else if (r == 0 && SDSCCONTIGG(sptroldsd)) {
1856 /* linear stride of 1st dimension here is always 1 */
1857 newstride = aststride;
1858 #endif
1859 } else {
1860 newstride =
1861 mk_binop(OP_MUL, aststride, get_local_multiplier(sptroldsd, r),
1862 A_DTYPEG(aststride));
1863 }
1864 insert_assign(get_local_multiplier(sptrnewsd, d), newstride, beforestd);
1865 if (astlower != aststride) {
1866 /* lbasetemp += (lower-stride) * oldsd[r].lstride */
1867 astlbase = mk_binop(
1868 OP_ADD, lbaseast,
1869 mk_binop(OP_MUL, get_local_multiplier(sptroldsd, r),
1870 mk_binop(OP_SUB, astlower, aststride, astb.bnd.dtype),
1871 astb.bnd.dtype),
1872 astb.bnd.dtype);
1873 lbaseast = symvalue(astlbase, 'b', sptroldsd, &lbasetemp, 1, 0);
1874 }
1875 }
1876 if (XBIT(70, 0x800000)) {
1877 /* newsd[d].sstride = 1 */
1878 insert_assign(get_section_stride(sptrnewsd, d), astb.bnd.one,
1879 beforestd);
1880 /* newsd[d].soffset = 0 */
1881 insert_assign(get_section_offset(sptrnewsd, d), astb.bnd.zero,
1882 beforestd);
1883 }
1884 if (computesequential && flagsseq) {
1885 if (flagstemp == 0) {
1886 int sptrfunc;
1887 newsymnum++;
1888 flagstemp = getnewccsym('f', newsymnum, ST_VAR);
1889 SCP(flagstemp, SC_LOCAL);
1890 DTYPEP(flagstemp, astb.bnd.dtype);
1891 if (STD_PAR(beforestd) || STD_TASK(beforestd)) {
1892 SCP(flagstemp, SC_PRIVATE);
1893 }
1894 /* flags = oldflags */
1895 insert_assign(mk_id(flagstemp), flagsast, beforestd);
1896 flagsast = mk_id(flagstemp);
1897
1898 /* if( descriptor_length == datatype_length ) then
1899 * flags = flags | SEQUENTIAL
1900 * endif */
1901 newif = mk_stmt(A_IFTHEN, 0);
1902 newargt = mk_argt(1);
1903 ARGT_ARG(newargt, 0) = get_kind(sptrnewsd);
1904 sptrfunc = sym_mkfunc("__get_size_of", DT_INT);
1905 funcast = mk_func_node(A_FUNC, mk_id(sptrfunc), 1, newargt);
1906 cmp = mk_binop(OP_EQ, get_byte_len(sptrnewsd), funcast, DT_LOG);
1907 A_IFEXPRP(newif, cmp);
1908 newstd = add_stmt_before(newif, beforestd);
1909 STD_PAR(newstd) = STD_PAR(beforestd);
1910 STD_TASK(newstd) = STD_TASK(beforestd);
1911 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1912 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1913
1914 newargt = mk_argt(2);
1915 ARGT_ARG(newargt, 0) = flagsast;
1916 f = SEQSECTION;
1917 ARGT_ARG(newargt, 1) = mk_isz_cval(f, dtype);
1918 funcast = mk_func_node(A_INTR, mk_id(intast_sym[I_OR]), 2, newargt);
1919 A_OPTYPEP(funcast, I_OR);
1920 A_DTYPEP(funcast, dtype);
1921 insert_assign(flagsast, funcast, beforestd);
1922
1923 newif = mk_stmt(A_ENDIF, 0);
1924 newstd = add_stmt_before(newif, beforestd);
1925 STD_PAR(newstd) = STD_PAR(beforestd);
1926 STD_TASK(newstd) = STD_TASK(beforestd);
1927 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1928 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1929 }
1930 /* if newsd[d].lstride != gsizetemp then */
1931 newif = mk_stmt(A_IFTHEN, 0);
1932 cmp = mk_binop(OP_NE, get_local_multiplier(sptrnewsd, d), gsizeast,
1933 DT_LOG);
1934 A_IFEXPRP(newif, cmp);
1935 newstd = add_stmt_before(newif, beforestd);
1936 STD_PAR(newstd) = STD_PAR(beforestd);
1937 STD_TASK(newstd) = STD_TASK(beforestd);
1938 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1939 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1940 /* flags &= ~SEQUENTIAL_SECTION */
1941 newargt = mk_argt(2);
1942 ARGT_ARG(newargt, 0) = flagsast;
1943 f = SEQSECTION;
1944 f = ~f;
1945 ARGT_ARG(newargt, 1) = mk_isz_cval(f, dtype);
1946 funcast = mk_func_node(A_INTR, mk_id(intast_sym[I_AND]), 2, newargt);
1947 A_OPTYPEP(funcast, I_AND);
1948 A_DTYPEP(funcast, dtype);
1949 insert_assign(flagsast, funcast, beforestd);
1950 /* endif */
1951 newif = mk_stmt(A_ENDIF, 0);
1952 newstd = add_stmt_before(newif, beforestd);
1953 STD_PAR(newstd) = STD_PAR(beforestd);
1954 STD_TASK(newstd) = STD_TASK(beforestd);
1955 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
1956 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
1957 }
1958 if (needgsize) {
1959 /* gsizetemp *= extent */
1960 astgsize = mk_binop(OP_MUL, gsizeast, astextent, astb.bnd.dtype);
1961 gsizeast = symvalue(astgsize, 'g', sptroldsd, &gsizetemp, 1, 0);
1962 }
1963 ++d;
1964 } else if (!(flags & SECTZBASE)) {
1965 /* single dimension */
1966 /* lbasetemp += oldsd[r].lstride * lower */
1967 astlbase = mk_binop(OP_ADD, lbaseast,
1968 mk_binop(OP_MUL, get_local_multiplier(sptroldsd, r),
1969 astlower, astb.bnd.dtype),
1970 astb.bnd.dtype);
1971 lbaseast = symvalue(astlbase, 'b', sptroldsd, &lbasetemp, 1, 0);
1972 }
1973 }
1974 /* newsd.flags = flags */
1975 insert_assign(get_desc_flags(sptrnewsd), flagsast, beforestd);
1976 /* newsd.lbase = lbasetemp */
1977 insert_assign(get_xbase(sptrnewsd), lbaseast, beforestd);
1978 if (needgsize) {
1979 /* newsd.gsize = gsizetemp */
1980 insert_assign(get_desc_gsize(sptrnewsd), gsizeast, beforestd);
1981 /* newsd.lsize = gsizetemp */
1982 insert_assign(get_desc_lsize(sptrnewsd), gsizeast, beforestd);
1983 } else {
1984 /* copy newsd.gsize = oldsd.gsize */
1985 insert_assign(get_desc_gsize(sptrnewsd), get_desc_gsize(sptroldsd),
1986 beforestd);
1987 /* copy newsd.lsize = oldsd.lsize */
1988 insert_assign(get_desc_lsize(sptrnewsd), get_desc_lsize(sptroldsd),
1989 beforestd);
1990 }
1991 /* newsd.tag = DESCRIPTOR */
1992 insert_assign(get_desc_tag(sptrnewsd), mk_isz_cval(TAGDESC, dtype),
1993 beforestd);
1994 return 1;
1995 } /* _sect */
1996
1997 /*
1998 * replace RTE_template[123] calls
1999 * RTE_template[123]( newsd, flags, kind, bytelen [,lower, upper] )
2000 *
2001 * newsd.rank = rank -- must be constant
2002 * newsd.kind = kind
2003 * newsd.bytelen = bytelen
2004 * newsd.gbase = 0
2005 * d=0
2006 * lbasetemp = 1
2007 * gsizetemp = 1
2008 * for r = 0 to rank-1 do
2009 * upper = upper[r]
2010 * lower = lower[r]
2011 * set extent=upper-lower+1
2012 * if upper < lower then extent = 0; upper = lower-1; endif
2013 * newsd[d].extent = extent
2014 * newsd[d].lbound = lower
2015 * newsd[d].ubound = upper
2016 * newsd[d].lstride = gsizetemp
2017 * lbasetemp -= lower * gsizetemp
2018 * newsd[d].sstride = 1
2019 * newsd[d].soffset = 0
2020 * set gsizetemp *= extent
2021 * endfor
2022 * newsd.flags = flags
2023 * newsd.lbase = lbasetemp
2024 * newsd.lsize = gsizetemp
2025 * newsd.gsize = gsizetemp
2026 * newsd.tag = DESCRIPTOR
2027 */
2028 static int
_template(int ast,int rank,LOGICAL usevalue,int i8)2029 _template(int ast, int rank, LOGICAL usevalue, int i8)
2030 {
2031 int argt;
2032 int astnewsd, astflags, argbase;
2033 int sptrnewsd;
2034 int flags;
2035 int newstd, astgsize, gsizeast, lbaseast, astlbase;
2036 int gsizetemp = 0, lbasetemp = 0;
2037 int lowertemp = 0, uppertemp = 0, extenttemp = 0;
2038 int newif, cmp;
2039 int r;
2040 int dtype = DT_INT;
2041 if (i8)
2042 dtype = DT_INT8;
2043 argt = A_ARGSG(ast);
2044 astnewsd = ARGT_ARG(argt, 0);
2045 if (A_TYPEG(astnewsd) != A_ID)
2046 return 0;
2047 sptrnewsd = A_SPTRG(astnewsd);
2048 if (rank > 0) {
2049 /* known number of dimensions */
2050 argbase = 0;
2051 if (A_ARGCNTG(ast) != 2 * rank + 4)
2052 return 0;
2053 } else {
2054 int astrank;
2055 argbase = 1;
2056 astrank = VALUE_ARGT_ARG(argt, argbase);
2057 if (astrank <= 0)
2058 return 0;
2059 if (A_TYPEG(astrank) != A_CNST)
2060 return 0;
2061 rank = CONVAL2G(A_SPTRG(astrank));
2062 if (A_ARGCNTG(ast) != 2 * rank + 5)
2063 return 0;
2064 }
2065 astflags = VALUE_ARGT_ARG(argt, argbase + 1);
2066 if (astflags <= 0)
2067 return 0;
2068 if (A_TYPEG(astflags) != A_CNST)
2069 return 0;
2070 flags = CONVAL2G(A_SPTRG(astflags));
2071 if (flags & 0x100) /* BOGUSFLAG */
2072 return 0;
2073 flags |= TEMPLATE | SEQSECTION;
2074
2075 /* set newsd.rank = rank */
2076 insert_assign(get_desc_rank(sptrnewsd), mk_isz_cval(rank, astb.bnd.dtype),
2077 beforestd);
2078 /* copy newsd.kind = kind */
2079 insert_assign(get_kind(sptrnewsd), VALUE_ARGT_ARG(argt, argbase + 2),
2080 beforestd);
2081 /* copy newsd.len = len */
2082 insert_assign(get_byte_len(sptrnewsd), VALUE_ARGT_ARG(argt, argbase + 3),
2083 beforestd);
2084 /* initialize lbasetemp */
2085 lbaseast = astb.bnd.one;
2086
2087 gsizeast = astb.bnd.one;
2088 for (r = 0; r < rank; ++r) {
2089 int astextent;
2090 int astlower = VALUE_ARGT_ARG(argt, argbase + 4 + 2 * r);
2091 int astupper = VALUE_ARGT_ARG(argt, argbase + 5 + 2 * r);
2092 astlower = symvalue(astlower, 'l', sptrnewsd, &lowertemp, 0, 0);
2093 if (XBIT(70, 0x800000)) {
2094 astupper = symvalue(astupper, 'u', sptrnewsd, &uppertemp, 0, sptrnewsd);
2095 }
2096 /* section dimension */
2097 if (astlower == astb.bnd.one) {
2098 astextent = astupper;
2099 } else {
2100 astextent = mk_binop(OP_SUB, astupper, astlower, A_DTYPEG(astupper));
2101 astextent =
2102 mk_binop(OP_ADD, astextent, astb.bnd.one, A_DTYPEG(astextent));
2103 }
2104 if (A_TYPEG(astextent) == A_CNST) {
2105 ISZ_T extent = CONVAL2G(A_SPTRG(astextent));
2106 if (extent <= 0) {
2107 if (XBIT(70, 0x800000)) {
2108 astupper =
2109 mk_binop(OP_SUB, astlower, astb.bnd.one, A_DTYPEG(astlower));
2110 }
2111 extent = 0;
2112 astextent = astb.bnd.zero;
2113 } else {
2114 astextent = mk_isz_cval(extent, A_DTYPEG(astextent));
2115 }
2116 } else {
2117 astextent =
2118 symvalue(astextent, 'x', sptrnewsd, &extenttemp, 1, sptrnewsd);
2119 /* make sure upper bound is in a variable */
2120 if (XBIT(70, 0x800000)) {
2121 astupper = symvalue(astupper, 'u', sptrnewsd, &uppertemp, 1, sptrnewsd);
2122 }
2123 /* if(ub < lb) */
2124 newif = mk_stmt(A_IFTHEN, 0);
2125 cmp = mk_binop(OP_LT, astupper, astlower, DT_LOG);
2126 A_IFEXPRP(newif, cmp);
2127 newstd = add_stmt_before(newif, beforestd);
2128 STD_PAR(newstd) = STD_PAR(beforestd);
2129 STD_TASK(newstd) = STD_TASK(beforestd);
2130 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
2131 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
2132 /* extent = 0 */
2133 insert_assign(astextent, astb.bnd.zero, beforestd);
2134 if (XBIT(70, 0x800000)) {
2135 /* upper = lower-1 */
2136 insert_assign(astupper, mk_binop(OP_SUB, astlower, astb.bnd.one,
2137 A_DTYPEG(astlower)),
2138 beforestd);
2139 }
2140 /* endif */
2141 newif = mk_stmt(A_ENDIF, 0);
2142 newstd = add_stmt_before(newif, beforestd);
2143 STD_PAR(newstd) = STD_PAR(beforestd);
2144 STD_TASK(newstd) = STD_TASK(beforestd);
2145 STD_ACCEL(newstd) = STD_ACCEL(beforestd);
2146 STD_KERNEL(newstd) = STD_KERNEL(beforestd);
2147 }
2148 /* newsd[r].extent = extent */
2149 insert_assign(get_extent(sptrnewsd, r), astextent, beforestd);
2150
2151 /* newsd[r].lbound = lower */
2152 insert_assign(get_global_lower(sptrnewsd, r), astlower, beforestd);
2153 if (XBIT(70, 0x800000)) {
2154 /* newsd[r].ubound = upper */
2155 insert_assign(get_global_upper(sptrnewsd, r), astupper, beforestd);
2156 }
2157 /* newsd[r].lstride = stride * oldsd[r].lstride */
2158 insert_assign(get_local_multiplier(sptrnewsd, r), gsizeast, beforestd);
2159 if (astlower != astb.bnd.zero) {
2160 astlbase = mk_binop(OP_SUB, lbaseast,
2161 mk_binop(OP_MUL, gsizeast, astlower, astb.bnd.dtype),
2162 astb.bnd.dtype);
2163 lbaseast = symvalue(astlbase, 'b', sptrnewsd, &lbasetemp, 0, 0);
2164 }
2165 if (XBIT(70, 0x800000)) {
2166 /* newsd[r].sstride = 1 */
2167 insert_assign(get_section_stride(sptrnewsd, r), astb.bnd.one, beforestd);
2168 /* newsd[r].soffset = 0 */
2169 insert_assign(get_section_offset(sptrnewsd, r), astb.bnd.zero, beforestd);
2170 }
2171 /* gsizetemp *= extent */
2172 astgsize = mk_binop(OP_MUL, gsizeast, astextent, astb.bnd.dtype);
2173 gsizeast = symvalue(astgsize, 'g', sptrnewsd, &gsizetemp, 1, 0);
2174 }
2175 /* newsd.flags = flags */
2176 insert_assign(get_desc_flags(sptrnewsd), mk_isz_cval(flags, astb.bnd.dtype),
2177 beforestd);
2178 /* newsd.lbase = lbasetemp */
2179 insert_assign(get_xbase(sptrnewsd), lbaseast, beforestd);
2180 /* newsd.gbase = 0 */
2181 insert_assign(get_gbase(sptrnewsd), astb.bnd.zero, beforestd);
2182 if (XBIT(49, 0x100) && !XBIT(49, 0x80000000) && !XBIT(68, 0x1)) {
2183 /* pointers are two ints long */
2184 insert_assign(get_gbase2(sptrnewsd), astb.bnd.zero, beforestd);
2185 }
2186 /* newsd.gsize = gsizetemp */
2187 insert_assign(get_desc_gsize(sptrnewsd), gsizeast, beforestd);
2188 /* newsd.lsize = gsizetemp */
2189 insert_assign(get_desc_lsize(sptrnewsd), gsizeast, beforestd);
2190 /* newsd.tag = DESCRIPTOR */
2191 insert_assign(get_desc_tag(sptrnewsd), mk_isz_cval(TAGDESC, dtype),
2192 beforestd);
2193 return 1;
2194 } /* _template */
2195
2196 /*
2197 * section descriptor member
2198 */
2199 static int
_sd_member(int subscript,int sdx,int sdtype)2200 _sd_member(int subscript, int sdx, int sdtype)
2201 {
2202 int subscr[2];
2203 subscr[0] = mk_isz_cval(subscript, sdtype);
2204 return mk_subscr(sdx, subscr, 1, sdtype);
2205 } /* _sd_member */
2206
2207 LOGICAL
inline_RTE_set_type(int ddesc,int sdesc,int stmt,int after,DTYPE src_dtype,int astmem)2208 inline_RTE_set_type(int ddesc, int sdesc, int stmt, int after,
2209 DTYPE src_dtype, int astmem)
2210 {
2211 /* This function inlines RTE_set_type calls. Returns TRUE if successful,
2212 * else FALSE. The src_dtype is the declared type of the source object.
2213 */
2214
2215 int stdx, asn;
2216 int subscript;
2217 int ast1, ast2;
2218 DTYPE sdtype, dtype;
2219
2220 if (is_array_dtype(src_dtype))
2221 src_dtype = array_element_dtype(src_dtype);
2222
2223 if (SCG(sdesc) == SC_DUMMY || SCG(ddesc) == SC_DUMMY) {
2224 /* TBD */
2225 return FALSE;
2226 }
2227
2228 sdtype = astb.bnd.dtype;
2229
2230 if (XBIT(49, 0x100) && !XBIT(49, 0x80000000) && !XBIT(68, 0x1)) {
2231 subscript = DESC_HDR_GBASE + 2;
2232 dtype = DT_INT8;
2233 } else {
2234 subscript = DESC_HDR_GBASE + 1;
2235 dtype = astb.bnd.dtype;
2236 }
2237
2238 ast1 = mk_id(ddesc);
2239 ast1 = _sd_member(subscript, ast1, sdtype);
2240 A_DTYPEP(ast1, dtype);
2241
2242 if (CLASSG(sdesc)) {
2243 ast2 = mk_id(sdesc);
2244 ast2 = mk_unop(OP_LOC, ast2, dtype);
2245 } else {
2246 ast2 = mk_id(sdesc);
2247 ast2 = _sd_member(subscript, ast2, sdtype);
2248 A_DTYPEP(ast2, dtype);
2249 }
2250 if (ast1 && astmem && STYPEG(ddesc) == ST_MEMBER) {
2251 ast1 = check_member(astmem, ast1);
2252 }
2253
2254 if (ast1 && ast2) {
2255 asn = mk_assn_stmt(ast1, ast2, dtype);
2256 if (SCG(ddesc) != SC_EXTERN)
2257 ADDRTKNP(ddesc, 1);
2258 if (SCG(sdesc) != SC_EXTERN)
2259 ADDRTKNP(sdesc, 1);
2260 } else {
2261 return FALSE;
2262 }
2263 if (after)
2264 stdx = add_stmt_after(asn, stmt);
2265 else
2266 stdx = add_stmt_before(asn, stmt);
2267
2268 return TRUE;
2269 }
2270
2271 /*
2272 * copy one element from target section descriptor to pointer descriptor
2273 */
2274 static void
_ptrassign_copy(int subscript,int ptrsdx,int tgtsdx,int sdtype)2275 _ptrassign_copy(int subscript, int ptrsdx, int tgtsdx, int sdtype)
2276 {
2277 int stdx, asn;
2278 asn = MKASSN(_sd_member(subscript, ptrsdx, sdtype),
2279 _sd_member(subscript, tgtsdx, sdtype));
2280 stdx = add_stmt_before(asn, beforestd);
2281 } /* _ptrassign_copy */
2282
2283 /*
2284 * copy one element from target section descriptor to another element of the
2285 * pointer descriptor
2286 */
2287 static void
_ptrassign_copy2(int subscript,int ptrsdx,int subscript2,int tgtsdx,int sdtype)2288 _ptrassign_copy2(int subscript, int ptrsdx, int subscript2, int tgtsdx,
2289 int sdtype)
2290 {
2291 int stdx, asn;
2292 asn = MKASSN(_sd_member(subscript, ptrsdx, sdtype),
2293 _sd_member(subscript2, tgtsdx, sdtype));
2294 stdx = add_stmt_before(asn, beforestd);
2295 } /* _ptrassign_copy2 */
2296
2297 /*
2298 * set one element in pointer section descriptor
2299 */
2300 static void
_ptrassign_set(int subscript,int ptrsdx,int value,int sdtype)2301 _ptrassign_set(int subscript, int ptrsdx, int value, int sdtype)
2302 {
2303 int stdx, asn;
2304 asn =
2305 MKASSN(_sd_member(subscript, ptrsdx, sdtype), mk_isz_cval(value, sdtype));
2306 stdx = add_stmt_before(asn, beforestd);
2307 } /* _ptrassign_set */
2308
2309 /*
2310 * set one element in pointer section descriptor
2311 */
2312 static void
_ptrassign_set_ast(int subscript,int ptrsdx,int valastx,int sdtype)2313 _ptrassign_set_ast(int subscript, int ptrsdx, int valastx, int sdtype)
2314 {
2315 int stdx, asn;
2316 asn = MKASSN(_sd_member(subscript, ptrsdx, sdtype), valastx);
2317 stdx = add_stmt_before(asn, beforestd);
2318 } /* _ptrassign_set_ast */
2319
2320 /*
2321 * if this is a ptr_assign call that is for the whole array (sectflag == 0)
2322 * then replace by inline code.
2323 * if the pointer target is itself a pointer or allocatable,
2324 * copy the pointer value
2325 * else
2326 * replace by %loc(pointer target)
2327 * generate a loop to copy the descriptor
2328 */
2329 static int
_ptrassign(int astx)2330 _ptrassign(int astx)
2331 {
2332 int argt, sectflagx;
2333 int ptrx, ptrsdx, ptrsptr = 0, ptrsdsptr, ptrsdtype, tgtx, tgtsdx, tgtsptr;
2334 int asn, stdx, i, rank;
2335 argt = A_ARGSG(astx);
2336 sectflagx = ARGT_ARG(argt, 4);
2337 ptrx = ARGT_ARG(argt, 0);
2338 ptrsdx = ARGT_ARG(argt, 1);
2339 tgtx = ARGT_ARG(argt, 2);
2340 tgtsdx = ARGT_ARG(argt, 3);
2341 /* if the target is not an ID or MEMBER, give up */
2342 if (A_TYPEG(tgtx) != A_ID && A_TYPEG(tgtx) != A_MEM)
2343 return 0;
2344 /* if the target section descriptor is not an ID or MEMBER or CONST, give up
2345 */
2346 if (A_TYPEG(tgtsdx) != A_ID && A_TYPEG(tgtsdx) != A_MEM &&
2347 A_TYPEG(tgtsdx) != A_CNST)
2348 return 0;
2349 /* if the destination pointer is not an ID or MEMBER, give up */
2350 if (A_TYPEG(ptrx) != A_ID && A_TYPEG(ptrx) != A_MEM)
2351 return 0;
2352 /* if the destination section descriptor is not an ID or MEMBER, give up */
2353 if (A_TYPEG(ptrsdx) != A_ID && A_TYPEG(ptrsdx) != A_MEM)
2354 return 0;
2355 if (sectflagx != astb.i0 && sectflagx != astb.k0 &&
2356 (tgtsdx != ptrsdx /*|| XBIT(1,0x800)*/))
2357 /* leave the call in place */
2358 return 0;
2359 /* if the target is itself a pointer, we can simply copy the pointer value */
2360 if (A_TYPEG(tgtx) == A_ID) {
2361 tgtsptr = A_SPTRG(tgtx);
2362 } else if (A_TYPEG(tgtx) == A_MEM) {
2363 tgtsptr = A_SPTRG(A_MEMG(tgtx));
2364 }
2365 if (A_TYPEG(ptrx) == A_ID) {
2366 ptrsptr = A_SPTRG(ptrx);
2367 } else if (A_TYPEG(ptrx) == A_MEM) {
2368 ptrsptr = A_SPTRG(A_MEMG(ptrx));
2369 }
2370 #ifdef TEXTUREG
2371 if (ptrsptr && TEXTUREG(ptrsptr))
2372 return 0;
2373 #endif
2374 #ifdef DEVICEG
2375 if (ptrsptr && DEVICEG(ptrsptr))
2376 return 0;
2377 #endif
2378 if (A_TYPEG(ptrsdx) == A_ID) {
2379 ptrsdsptr = A_SPTRG(ptrsdx);
2380 if (STYPEG(ptrsptr) == ST_MEMBER && STYPEG(ptrsdsptr) != ST_MEMBER) {
2381 ptrsdsptr = 0;
2382 }
2383 } else if (A_TYPEG(ptrsdx) == A_MEM) {
2384 ptrsdsptr = A_SPTRG(A_MEMG(ptrsdx));
2385 }
2386 if (MIDNUMG(ptrsptr) == 0)
2387 return 0;
2388 if (POINTERG(tgtsptr)) {
2389 if (MIDNUMG(tgtsptr) == 0)
2390 return 0;
2391 /* copy the pointer */
2392 asn = MKASSN(check_member(ptrx, mk_id(MIDNUMG(ptrsptr))),
2393 check_member(tgtx, mk_id(MIDNUMG(tgtsptr))));
2394 } else {
2395 /* must take %loc(arg) */
2396 asn = MKASSN(check_member(ptrx, mk_id(MIDNUMG(ptrsptr))),
2397 mk_unop(OP_LOC, tgtx, DT_PTR));
2398 }
2399 stdx = add_stmt_before(asn, beforestd);
2400 if (ptrsdsptr) {
2401 ptrsdtype = DDTG(DTYPEG(ptrsdsptr));
2402 if (A_TYPEG(tgtsdx) == A_ID) {
2403 tgtsdx = mk_id(A_SPTRG(tgtsdx));
2404 } else if (A_TYPEG(tgtsdx) == A_MEM) {
2405 tgtsdx = mk_member(A_PARENTG(tgtsdx), mk_id(A_SPTRG(A_MEMG(tgtsdx))),
2406 A_DTYPEG(tgtsdx));
2407 }
2408 if (A_TYPEG(tgtsdx) == A_CNST) {
2409 /* PTRSD(tag) = value */
2410 _ptrassign_set_ast(DESC_HDR_TAG, ptrsdx, tgtsdx, ptrsdtype);
2411 } else if (ptrsdx != tgtsdx) {
2412 /* PTRSD(tag) = Descriptor */
2413 /* PTRSD(rank) = TGTSD(rank) */
2414 /* PTRSD(kind) = TGTSD(kind) */
2415 /* PTRSD(len) = TGTSD(len) */
2416 /* PTRSD(flags) = TGTSD(flags) */
2417 /* PTRSD(lsize) = TGTSD(lsize) */
2418 /* PTRSD(gsize) = TGTSD(gsize) */
2419 /* PTRSD(lbase) = TGTSD(lbase) */
2420 /* PTRSD(gbase) = TGTSD(gbase) */
2421 /* for i = 0; i < rank ++i */
2422 /* PTRSD(lower(i)) = 1 */
2423 /* PTRSD(extent(i)) = TGTSD(extent(i)) */
2424 /* PTRSD(upper(i)) = TGTSD(extent(i)) */
2425 /* PTRSD(lstride(i)) = TGTSD(lstride(i)) */
2426 /* PTRSD(soffset(i)) = 0 */
2427 /* PTRSD(sstride(i)) = 0 */
2428 _ptrassign_set(DESC_HDR_TAG, ptrsdx, TAGDESC, ptrsdtype);
2429 _ptrassign_copy(DESC_HDR_RANK, ptrsdx, tgtsdx, ptrsdtype);
2430 _ptrassign_copy(DESC_HDR_KIND, ptrsdx, tgtsdx, ptrsdtype);
2431 _ptrassign_copy(DESC_HDR_BYTE_LEN, ptrsdx, tgtsdx, ptrsdtype);
2432 _ptrassign_copy(DESC_HDR_FLAGS, ptrsdx, tgtsdx, ptrsdtype);
2433 _ptrassign_copy(DESC_HDR_LSIZE, ptrsdx, tgtsdx, ptrsdtype);
2434 _ptrassign_copy(DESC_HDR_GSIZE, ptrsdx, tgtsdx, ptrsdtype);
2435 if (ASSUMSHPG(tgtsptr) && !XBIT(58, 0x400000)) {
2436 _ptrassign_set(DESC_HDR_LBASE, ptrsdx, 1, ptrsdtype);
2437 } else {
2438 _ptrassign_copy(DESC_HDR_LBASE, ptrsdx, tgtsdx, ptrsdtype);
2439 }
2440 _ptrassign_copy(DESC_HDR_GBASE, ptrsdx, tgtsdx, ptrsdtype);
2441 if (XBIT(49, 0x100) && !XBIT(49, 0x80000000)
2442 && !XBIT(68, 0x1)
2443 ) {
2444 /* pointers are two ints long */
2445 _ptrassign_copy(DESC_HDR_GBASE + 1, ptrsdx, tgtsdx, ptrsdtype);
2446 }
2447 rank = ADD_NUMDIM(DTYPEG(ptrsptr));
2448 for (i = 0; i < rank; ++i) {
2449 int lb;
2450 if (!ASSUMSHPG(tgtsptr) || XBIT(58, 0x400000)) {
2451 _ptrassign_copy(get_global_lower_index(i), ptrsdx, tgtsdx, ptrsdtype);
2452 } else {
2453 /* for assumed-shape arguments, use the declared bounds */
2454 lb = ADD_LWAST(DTYPEG(tgtsptr), i);
2455 _ptrassign_set_ast(get_global_lower_index(i), ptrsdx, lb, ptrsdtype);
2456 }
2457 _ptrassign_copy(get_global_extent_index(i), ptrsdx, tgtsdx, ptrsdtype);
2458 _ptrassign_set(get_section_stride_index(i), ptrsdx, 0, ptrsdtype);
2459 _ptrassign_set(get_section_offset_index(i), ptrsdx, 0, ptrsdtype);
2460 _ptrassign_copy(get_multiplier_index(i), ptrsdx, tgtsdx, ptrsdtype);
2461 if (ASSUMSHPG(tgtsptr) && !XBIT(58, 0x400000)) {
2462 /* adjust the LBASE */
2463 int a;
2464 a = mk_binop(OP_MUL,
2465 _sd_member(get_multiplier_index(i), ptrsdx, ptrsdtype),
2466 lb, ptrsdtype);
2467 a = mk_binop(OP_SUB, _sd_member(DESC_HDR_LBASE, ptrsdx, ptrsdtype), a,
2468 ptrsdtype);
2469 _ptrassign_set_ast(DESC_HDR_LBASE, ptrsdx, a, ptrsdtype);
2470 }
2471 /* we could copy the upper bound, but it's never used by the runtime
2472 * anyway */
2473 /* _ptrassign_copy( get_global_upper_index(i), ptrsdx, tgtsdx, ptrsdtype
2474 * );*/
2475 }
2476 }
2477 }
2478 return 1; /* ### */
2479 } /* _ptrassign */
2480
2481 /*
2482 * inline RTE_sect calls, where possible
2483 * also inline simple ptr2_assign calls, where the pointee is the whole array
2484 * do this after sectfloat
2485 */
2486 void
sectinline(void)2487 sectinline(void)
2488 {
2489 int std, stdnext;
2490 int ast, any;
2491
2492 for (std = STD_NEXT(0); std; std = stdnext) {
2493 stdnext = STD_NEXT(std);
2494 ast = STD_AST(std);
2495 beforestd = std;
2496 if (A_TYPEG(ast) == A_CALL) {
2497 int lop;
2498 lop = A_LOPG(ast);
2499 if (lop && A_TYPEG(lop) == A_ID) {
2500 int fsptr;
2501 fsptr = A_SPTRG(lop);
2502 if (HCCSYMG(fsptr) && STYPEG(fsptr) == ST_PROC) {
2503 int i;
2504 i = getF90TmplSectRtn(SYMNAME(fsptr));
2505 switch (i & FTYPE_MASK) {
2506 case FTYPE_SECT:
2507 /* found one of the names */
2508 if (_sect(ast, i & FTYPE_I8)) {
2509 ast_to_comment(ast);
2510 }
2511 break;
2512 case FTYPE_TEMPLATE:
2513 if (_template(ast, -1, FALSE, i & FTYPE_I8))
2514 ast_to_comment(ast);
2515 break;
2516 case FTYPE_TEMPLATE1:
2517 if (_template(ast, 1, FALSE, i & FTYPE_I8))
2518 ast_to_comment(ast);
2519 break;
2520 case FTYPE_TEMPLATE1V:
2521 if (_template(ast, 1, TRUE, i & FTYPE_I8))
2522 ast_to_comment(ast);
2523 break;
2524 case FTYPE_TEMPLATE2:
2525 if (_template(ast, 2, FALSE, i & FTYPE_I8))
2526 ast_to_comment(ast);
2527 break;
2528 case FTYPE_TEMPLATE2V:
2529 if (_template(ast, 2, TRUE, i & FTYPE_I8))
2530 ast_to_comment(ast);
2531 break;
2532 case FTYPE_TEMPLATE3:
2533 if (_template(ast, 3, FALSE, i & FTYPE_I8))
2534 ast_to_comment(ast);
2535 break;
2536 case FTYPE_TEMPLATE3V:
2537 if (_template(ast, 3, TRUE, i & FTYPE_I8))
2538 ast_to_comment(ast);
2539 break;
2540 }
2541 }
2542 }
2543 } else if (A_TYPEG(ast) == A_ICALL) {
2544 switch (A_OPTYPEG(ast)) {
2545 case I_PTR2_ASSIGN:
2546 /* see if this can be inlined */
2547 if (_ptrassign(ast)) {
2548 ast_to_comment(ast);
2549 }
2550 break;
2551 }
2552 }
2553 }
2554 } /* sectinline */
2555
2556 static void
convert_statements(void)2557 convert_statements(void)
2558 {
2559 int std, stdnext;
2560 int ast;
2561 int parallel_depth;
2562 int task_depth;
2563
2564 init_tbl();
2565 unvisit_every_sptr();
2566
2567 parallel_depth = 0;
2568 task_depth = 0;
2569 for (std = STD_NEXT(0); std; std = stdnext) {
2570 stdnext = STD_NEXT(std);
2571 ast = STD_AST(std);
2572 switch (A_TYPEG(ast)) {
2573 case A_ALLOC:
2574 if (A_TKNG(ast) == TK_ALLOCATE) {
2575 stdnext = conv_allocate(std);
2576 } else {
2577 assert(A_TKNG(ast) == TK_DEALLOCATE, "conv_statements: bad dealloc",
2578 std, 4);
2579 stdnext = conv_deallocate(std);
2580 }
2581 break;
2582 case A_MP_PARALLEL:
2583 ++parallel_depth;
2584 /*symutl.sc = SC_PRIVATE;*/
2585 set_descriptor_sc(SC_PRIVATE);
2586 break;
2587 case A_MP_ENDPARALLEL:
2588 --parallel_depth;
2589 if (parallel_depth == 0 && task_depth == 0) {
2590 /*symutl.sc = SC_LOCAL;*/
2591 set_descriptor_sc(SC_LOCAL);
2592 }
2593 break;
2594 case A_MP_TASK:
2595 case A_MP_TASKLOOP:
2596 ++task_depth;
2597 set_descriptor_sc(SC_PRIVATE);
2598 break;
2599 case A_MP_ENDTASK:
2600 case A_MP_ETASKLOOP:
2601 --task_depth;
2602 if (parallel_depth == 0 && task_depth == 0) {
2603 set_descriptor_sc(SC_LOCAL);
2604 }
2605 break;
2606 default:
2607 break;
2608 }
2609 }
2610 free_tbl();
2611 }
2612
2613 static void
_mark_descr(int ast,int * dummy)2614 _mark_descr(int ast, int *dummy)
2615 {
2616 if (A_TYPEG(ast) == A_MEM)
2617 ast = A_MEMG(ast);
2618 if (A_TYPEG(ast) == A_ID) {
2619 int sptr, stype;
2620 sptr = A_SPTRG(ast);
2621 stype = STYPEG(sptr);
2622 if ((stype == ST_ARRAY || stype == ST_MEMBER) && DESCARRAYG(sptr)) {
2623 VISITP(sptr, 1);
2624 }
2625 }
2626 } /* _mark_descr */
2627
2628 static void
convert_template_instance(void)2629 convert_template_instance(void)
2630 {
2631 int sptr, std, stdnext;
2632 /* we are looking for cases where we have a RTE_template call
2633 * followed by a pghpf_instance call, and the pghpf_instance call
2634 * is the ONLY use of the RTE_template output template.
2635 * for instance
2636 * call RTE_template(aa$sd,1,2,0,0,1,20)
2637 * call pghpf_instance(aa$sd1,aa$sd,27,4,0)
2638 * replace aa$sd by aa$sd1 here
2639 */
2640
2641 /* reset VISIT flags */
2642 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
2643 VISITP(sptr, 0);
2644 }
2645
2646 /* Look for all uses of section descriptors anywhere
2647 * outside of calls to RTE_template and pghpf_instance */
2648 for (std = STD_NEXT(0); std; std = stdnext) {
2649 int ast, sptr, argcnt, dummy;
2650 stdnext = STD_NEXT(std);
2651 ast = STD_AST(std);
2652 switch (A_TYPEG(ast)) {
2653 case A_CALL:
2654 sptr = memsym_of_ast(A_LOPG(ast));
2655 if (STYPEG(sptr) != ST_PROC)
2656 break;
2657 argcnt = A_ARGCNTG(ast);
2658 if (STYPEG(sptr) == ST_PROC) {
2659 /* don't look at RTE_template calls */
2660 if (strcmp(SYMNAME(sptr), mkRteRtnNm(RTE_template)) == 0)
2661 break;
2662 /* don't look at pghpf_instance calls
2663 * if the previous statement is a RTE_template call */
2664 if (strcmp(SYMNAME(sptr), mkRteRtnNm(RTE_instance)) == 0) {
2665 int stdprev, astprev;
2666 stdprev = STD_PREV(std);
2667 astprev = STD_AST(stdprev);
2668 if (A_TYPEG(astprev) == A_CALL) {
2669 int sptrprev;
2670 sptrprev = A_SPTRG(A_LOPG(astprev));
2671 if (STYPEG(sptrprev) == ST_PROC &&
2672 strcmp(SYMNAME(sptrprev), mkRteRtnNm(RTE_template)) == 0)
2673 break;
2674 }
2675 }
2676 }
2677 /* FALL THROUGH */
2678 default:
2679 ast_visit(1, 1);
2680 ast_traverse(ast, NULL, _mark_descr, &dummy);
2681 ast_unvisit();
2682 break;
2683 }
2684 }
2685 /* Look for pghpf_instance calls where the previous statement
2686 * is a RTE_template call, and where the input descriptor to the instance
2687 * is the output descriptor of the template call, and the descriptor
2688 * has no other uses */
2689 for (std = STD_NEXT(0); std; std = stdnext) {
2690 int ast, sptr, argcnt;
2691 stdnext = STD_NEXT(std);
2692 ast = STD_AST(std);
2693 if (A_TYPEG(ast) == A_CALL) {
2694 sptr = memsym_of_ast(A_LOPG(ast));
2695 argcnt = A_ARGCNTG(ast);
2696 if (STYPEG(sptr) == ST_PROC && argcnt == 5 &&
2697 strcmp(SYMNAME(sptr), mkRteRtnNm(RTE_instance)) == 0) {
2698 int stdprev, astprev;
2699 stdprev = STD_PREV(std);
2700 astprev = STD_AST(stdprev);
2701 if (A_TYPEG(astprev) == A_CALL) {
2702 int sptrprev;
2703 sptrprev = A_SPTRG(A_LOPG(astprev));
2704 if (STYPEG(sptrprev) == ST_PROC &&
2705 strcmp(SYMNAME(sptrprev), mkRteRtnNm(RTE_template)) == 0) {
2706 /* get argument lists */
2707 int argsi, insd, outsd, argst, tempsd, sptrsd, collapse;
2708 argsi = A_ARGSG(ast);
2709 outsd = ARGT_ARG(argsi, 0);
2710 insd = ARGT_ARG(argsi, 1);
2711 argst = A_ARGSG(astprev);
2712 tempsd = ARGT_ARG(argst, 0);
2713 sptrsd = sym_of_ast(tempsd);
2714 collapse = ARGT_ARG(argsi, 4);
2715 if (sptrsd && !VISITG(sptrsd) && tempsd == insd &&
2716 tempsd != outsd) {
2717 if (collapse == astb.i0 || collapse == astb.k0) {
2718 /* replace
2719 * call RTE_template(aa$sd,1,2,0,0,1,20)
2720 * call pghpf_instance(aa$sd1,aa$sd,27,4,0)
2721 * by
2722 * call RTE_template(aa$sd1,1,2,27,4,1,20)
2723 */
2724 ARGT_ARG(argst, 0) = outsd;
2725 ARGT_ARG(argst, 3) = ARGT_ARG(argsi, 2);
2726 ARGT_ARG(argst, 4) = ARGT_ARG(argsi, 3);
2727 delete_stmt(std);
2728 } else {
2729 /* replace
2730 * call RTE_template(aa$sd,1,2,0,0,1,20)
2731 * call pghpf_instance(aa$sd1,aa$sd,27,4,0)
2732 * by
2733 * call RTE_template(aa$sd1,1,2,0,0,1,20)
2734 * call pghpf_instance(aa$sd1,aa$sd1,27,4,0)
2735 */
2736 ARGT_ARG(argsi, 1) = outsd;
2737 ARGT_ARG(argst, 0) = outsd;
2738 }
2739 STYPEP(sptrsd, ST_UNKNOWN);
2740 }
2741 if (sptrsd && tempsd == insd && tempsd == outsd &&
2742 (collapse == astb.i0 || collapse == astb.k0)) {
2743 /* replace
2744 * call RTE_template(aa$sd,1,2,0,0,1,20)
2745 * call pghpf_instance(aa$sd,aa$sd,27,4,0)
2746 * by
2747 * call RTE_template(aa$sd,1,2,27,4,1,20)
2748 */
2749 ARGT_ARG(argst, 3) = ARGT_ARG(argsi, 2);
2750 ARGT_ARG(argst, 4) = ARGT_ARG(argsi, 3);
2751 delete_stmt(std);
2752 }
2753 }
2754 }
2755 }
2756 }
2757 }
2758
2759 /* go back and reset VISIT flags again */
2760 for (sptr = stb.firstosym; sptr < stb.stg_avail; ++sptr) {
2761 VISITP(sptr, 0);
2762 }
2763
2764 /* look for pghpf_instance calls where the input/output descriptors
2765 * are identical; replace by assignments
2766 * look for RTE_template calls;
2767 * if the rank is constant, replace by
2768 * RTE_template1/RTE_template2/RTE_template3 or
2769 * RTE_template1v/RTE_template2v/RTE_template3v calls, as appropriate */
2770 for (std = STD_NEXT(0); std; std = stdnext) {
2771 int ast, sptr, argcnt;
2772 stdnext = STD_NEXT(std);
2773 ast = STD_AST(std);
2774 if (A_TYPEG(ast) == A_CALL) {
2775 sptr = memsym_of_ast(A_LOPG(ast));
2776 argcnt = A_ARGCNTG(ast);
2777 if (STYPEG(sptr) == ST_PROC && argcnt == 5 &&
2778 strcmp(SYMNAME(sptr), mkRteRtnNm(RTE_instance)) == 0) {
2779 /* replace call pghpf_instance(a$sd,a$sd,kind,len,0)
2780 * by direct assignment
2781 * a$sd(kindoffset) = kind
2782 * a$sd(lenoffset) = len
2783 */
2784 int argsi, outsd, insd, collapse;
2785 argsi = A_ARGSG(ast);
2786 outsd = ARGT_ARG(argsi, 0);
2787 insd = ARGT_ARG(argsi, 1);
2788 collapse = ARGT_ARG(argsi, 4);
2789 if (outsd == insd && A_TYPEG(insd) == A_ID &&
2790 (collapse == astb.i0 || collapse == astb.k0)) {
2791 int kind, len, lhs, newasn, newstd;
2792 insd = A_SPTRG(insd);
2793 kind = ARGT_ARG(argsi, 2);
2794 len = ARGT_ARG(argsi, 3);
2795 lhs = get_kind(insd);
2796 newasn = mk_stmt(A_ASN, 0);
2797 A_DESTP(newasn, lhs);
2798 A_SRCP(newasn, kind);
2799 newstd = add_stmt_before(newasn, std);
2800 lhs = get_byte_len(insd);
2801 newasn = mk_stmt(A_ASN, 0);
2802 A_DESTP(newasn, lhs);
2803 A_SRCP(newasn, len);
2804 STD_AST(std) = newasn;
2805 }
2806 } else if (STYPEG(sptr) == ST_PROC &&
2807 strcmp(SYMNAME(sptr), mkRteRtnNm(RTE_template)) == 0) {
2808 /* call RTE_template(aa$sd,rank,flags,kind,len,lb1,lb2)
2809 * turn into
2810 * call RTE_template1(aa$sd,flags,kind,len,lb1,lb2) */
2811 int args, rank, ii;
2812 args = A_ARGSG(ast);
2813 rank = ARGT_ARG(args, 1);
2814 if (A_ALIASG(rank)) {
2815 rank = A_ALIASG(rank);
2816 rank = get_int_cval(A_SPTRG(rank));
2817 if (rank >= 1 && rank <= 3) {
2818 int fsptr, a;
2819 FtnRtlEnum rtlRtn;
2820 /* one fewer argument */
2821 --argcnt;
2822 for (a = 1; a < argcnt; ++a) {
2823 ARGT_ARG(args, a) = ARGT_ARG(args, a + 1);
2824 }
2825 ARGT_CNT(args) = argcnt;
2826 A_ARGCNTP(ast, argcnt);
2827 if (size_of(DT_PTR) != size_of(DT_INT)) {
2828 /* on hammer, seems faster to pass by ref */
2829 switch (rank) {
2830 case 1:
2831 rtlRtn = RTE_template1;
2832 break;
2833 case 2:
2834 rtlRtn = RTE_template2;
2835 break;
2836 case 3:
2837 rtlRtn = RTE_template3;
2838 break;
2839 }
2840 } else {
2841 switch (rank) {
2842 case 1:
2843 rtlRtn = RTE_template1v;
2844 break;
2845 case 2:
2846 rtlRtn = RTE_template2v;
2847 break;
2848 case 3:
2849 rtlRtn = RTE_template3v;
2850 break;
2851 }
2852 for (a = 1; a < argcnt; ++a) {
2853 ARGT_ARG(args, a) = mk_unop(OP_VAL, ARGT_ARG(args, a), DT_INT);
2854 }
2855 }
2856 fsptr = sym_mkfunc(mkRteRtnNm(rtlRtn), DT_NONE);
2857 NODESCP(fsptr, 1);
2858 ii = mk_id(fsptr);
2859 A_LOPP(ast, ii);
2860 /*
2861 * tpr 3569: a call to RTE_template() without the
2862 * upperbound of the last dimension is generated
2863 * for an assumed-size array. But, the rank-specific
2864 * template functions accesses the upper bound
2865 * which could cause a segfault. Just add the
2866 * the dimension's lowerbound as the upper bound.
2867 */
2868 if (argcnt < rank * 2 + 4) {
2869 ARGT_ARG(args, argcnt) = ARGT_ARG(args, argcnt - 1);
2870 argcnt++;
2871 ARGT_CNT(args) = argcnt;
2872 A_ARGCNTP(ast, argcnt);
2873 }
2874 }
2875 }
2876 }
2877 }
2878 }
2879 } /* convert_template_instance */
2880
2881 static int
conv_deallocate(int std)2882 conv_deallocate(int std)
2883 {
2884 int dealloc_ast, idast;
2885 int ast;
2886 int astnew;
2887 int sptr;
2888 int argt;
2889 int secd;
2890 int arrdsc;
2891 int arrdsc1;
2892 int target;
2893 LITEMF *list;
2894 int i;
2895 int nargs;
2896
2897 dealloc_ast = A_SRCG(STD_AST(std));
2898 again:
2899 switch (A_TYPEG(dealloc_ast)) {
2900 case A_ID:
2901 sptr = A_SPTRG(dealloc_ast);
2902 idast = dealloc_ast;
2903 break;
2904 case A_MEM:
2905 sptr = A_SPTRG(A_MEMG(dealloc_ast));
2906 idast = dealloc_ast;
2907 break;
2908 case A_SUBSCR:
2909 dealloc_ast = A_LOPG(dealloc_ast);
2910 goto again;
2911 default:
2912 interr("conv_deallocate: unexpected ast", dealloc_ast, 4);
2913 }
2914
2915 /* free the section and the align */
2916 arrdsc = DESCRG(sptr);
2917 if (arrdsc == 0)
2918 goto exit_;
2919 secd = SECDG(arrdsc);
2920 if (secd == 0)
2921 goto exit_;
2922
2923 list = 0;
2924 for (i = 0; i < tbl.avl; i++) {
2925 if (tbl.base[i].f1 == sptr)
2926 list = tbl.base[i].f3;
2927 else if (STYPEG(sptr) == ST_MEMBER && STYPEG(tbl.base[i].f1) == ST_MEMBER &&
2928 ENCLDTYPEG(sptr) == ENCLDTYPEG(tbl.base[i].f1) &&
2929 strcmp(SYMNAME(sptr), SYMNAME(tbl.base[i].f1)) == 0) {
2930 /* This occurs with parameterized derived types */
2931 list = tbl.base[i].f3;
2932 }
2933 }
2934
2935 /*
2936 * f22379: there are cases where 'all' descriptors are created where there
2937 * may not be a matching allocate, such as a a pointer member of a
2938 * polymorphic typ> For now, I'm just removing the assert for now -- in the
2939 * future, we may want to qualify the assert.
2940 assert(list, "conv_deallocate: did not find corresponding allocate", sptr, 3);
2941 */
2942 if (!list || list->nitem == 0)
2943 goto exit_;
2944 nargs = list->nitem + 1;
2945 argt = mk_argt(nargs);
2946 ARGT_ARG(argt, 0) = mk_cval(list->nitem, DT_INT);
2947 for (i = 0; i < list->nitem; i++) {
2948 int mast;
2949 mast = check_member(idast, mk_id(glist(list, i)));
2950 ARGT_ARG(argt, list->nitem - i) = mast;
2951 }
2952 ast = mk_func_node(A_CALL, mk_id(sym_mkfunc(mkRteRtnNm(RTE_freen), DT_NONE)),
2953 nargs, argt);
2954 add_stmt_before(ast, std);
2955 exit_:
2956 std = STD_NEXT(std);
2957 if (STD_IGNORE(STD_PREV(std)))
2958 delete_stmt(STD_PREV(std));
2959 return std;
2960 }
2961
2962 /* Algorithm:
2963 * This routine converts allocatable arrays.
2964 * allocate(a(a$sd(33):a$sd(34)))
2965 * This allocate stmt is user defined statement
2966 * not compiler define allocates.
2967 * It calls emit_alnd_secd to set align and section descriptor
2968 * for allocatable arrays.
2969 * emit_alnd_secd has to generate algn and sec just before allocate stmt
2970 * unlike non-array.
2971 */
2972 extern LOGICAL want_descriptor_anyway(int sptr);
2973
2974 static int
conv_allocate(int std)2975 conv_allocate(int std)
2976 {
2977 int alloc_ast, idast;
2978 int ast;
2979 int sptr;
2980 int subsc, memast;
2981 int lstd;
2982 int i;
2983 int asd;
2984 int dtype;
2985 int align, oalign, odist, oproc;
2986 int tmplate;
2987 int astnew;
2988 LITEMF *list;
2989 int nd;
2990 int ptr;
2991 int newtmpl, tmpl;
2992 int a_dtype;
2993
2994 alloc_ast = STD_AST(std);
2995 memast = subsc = A_SRCG(alloc_ast);
2996 /* only set a_dtype for typed allocation, not sourced allocation, etc. */
2997 a_dtype = (!A_STARTG(alloc_ast)) ? A_DTYPEG(alloc_ast) : 0;
2998 switch (A_TYPEG(subsc)) {
2999 case A_SUBSCR:
3000 sptr = sptr_of_subscript(subsc);
3001 memast = idast = A_LOPG(subsc);
3002 asd = A_ASDG(subsc);
3003 if (!HCCSYMG(sptr)) {
3004 /* if the sptr is not a compiler generated temp, skip the "UGLY HACK"
3005 * This became necessary with the addition of ALLOCATE SOURCE/MOLD.
3006 * TODO: Think this needs to be revisited.
3007 */
3008 break;
3009 }
3010 /* UGLY HACK:
3011 * if this is a temporary that was created on behalf of
3012 * a derived type member, use the member as the 'idast' */
3013 dtype = DTYPEG(sptr);
3014 if (DTY(dtype) == TY_ARRAY) {
3015 int lower = ADD_LWBD(dtype, 0);
3016 if (lower && A_TYPEG(lower) == A_SUBSCR)
3017 lower = A_LOPG(lower);
3018 if (lower && A_TYPEG(lower) == A_MEM) {
3019 idast = lower;
3020 } else if (lower && A_TYPEG(lower) == A_ID &&
3021 STYPEG(A_SPTRG(lower)) == ST_MEMBER) {
3022 /* candidate case */
3023 int subs;
3024 subs = ASD_SUBS(asd, 0);
3025 if (subs && A_TYPEG(subs) == A_TRIPLE)
3026 subs = A_LBDG(subs);
3027 if (subs && A_TYPEG(subs) == A_SUBSCR)
3028 subs = A_LOPG(subs);
3029 if (subs && A_TYPEG(subs) == A_MEM)
3030 idast = subs;
3031 }
3032 }
3033 break;
3034 case A_ID:
3035 sptr = A_SPTRG(subsc);
3036 idast = subsc;
3037 subsc = 0;
3038 break;
3039 case A_MEM:
3040 sptr = A_SPTRG(A_MEMG(subsc));
3041 idast = subsc;
3042 subsc = 0;
3043 break;
3044 default:
3045 interr("conv_allocate: unexpected ast", alloc_ast, 4);
3046 }
3047
3048 if (DTY(DTYPEG(sptr)) != TY_ARRAY)
3049 goto exit_;
3050 /* pointer based but not allocatable variables */
3051 if (SCG(sptr) == SC_BASED && !ALLOCG(sptr))
3052 goto exit_;
3053 if (NODESCG(sptr))
3054 goto exit_;
3055
3056 dtype = DTYPEG(sptr);
3057 /* put out the array bounds assignments */
3058
3059 align = ALIGNG(sptr);
3060 if (want_descriptor_anyway(sptr))
3061 DESCUSEDP(sptr, 1);
3062
3063 init_fl();
3064
3065 /* if this is a host subprogram, it
3066 * may be passed as argument in a contained subprogram,
3067 * but we don't know here */
3068 if (gbl.internal == 1 || STYPEG(sptr) == ST_MEMBER)
3069 DESCUSEDP(sptr, 1);
3070 if (DESCUSEDG(sptr) && !TPALLOCG(sptr)) {
3071 set_typed_alloc(a_dtype);
3072 emit_alnd_secd(sptr, idast, TRUE, std, subsc);
3073 set_typed_alloc(DT_NONE);
3074 }
3075
3076 /* allocating an array pointer, need to plug the runtime desc gbase field */
3077 if (DTY(DTYPEG(sptr)) == TY_ARRAY && POINTERG(sptr) &&
3078 (flg.debug || XBIT(70, 0x2000000))) {
3079 int src;
3080 int dest;
3081 int stmt;
3082 if (STYPEG(sptr) == ST_MEMBER) {
3083 src = mk_member(A_PARENTG(idast), mk_id(MIDNUMG(sptr)),
3084 DTYPEG(MIDNUMG(sptr)));
3085 dest = check_member(idast, get_gbase(SDSCG(sptr)));
3086 } else {
3087 src = mk_id(MIDNUMG(sptr));
3088 dest = get_gbase(SDSCG(sptr));
3089 }
3090 /*
3091 * For the time being, the pointer is copied to the gbase field
3092 * by the runtime routine, RTE_ptrcp(). This has always been the
3093 * behavior for 64-bit; however, for 32-bit, we were generating
3094 * assignments. Unfortuately, there is an ili mismatch (the
3095 * source is 'AR' and the store expects 'IR') caught by dump_ili().
3096 */
3097 stmt = begin_call(A_CALL, sym_mkfunc_nodesc(mkRteRtnNm(RTE_ptrcp), DT_NONE),
3098 2);
3099 add_arg(dest);
3100 add_arg(src);
3101
3102 add_stmt_after(stmt, std);
3103 }
3104
3105 /* may have to reset 'visit' flag */
3106
3107 nd = get_tbl();
3108 list = clist();
3109 for (i = 0; i < fl.avl; i++) {
3110 plist(list, fl.base[i]);
3111 }
3112 tbl.base[nd].f1 = sptr;
3113 tbl.base[nd].f3 = list;
3114 FREE(fl.base);
3115
3116 exit_:
3117 std = STD_NEXT(std);
3118 if (STD_IGNORE(STD_PREV(std)))
3119 delete_stmt(STD_PREV(std));
3120 return std;
3121 }
3122
3123 static int
lhs_dim(int forall,int astli)3124 lhs_dim(int forall, int astli)
3125 {
3126 int lhs, lhsd;
3127 int ndim, asd;
3128 int nd;
3129 CTYPE *ct;
3130 int i;
3131
3132 nd = A_OPT1G(forall);
3133 ct = FT_CYCLIC(nd);
3134 lhs = ct->lhs;
3135 lhsd = left_subscript_ast(lhs);
3136 asd = A_ASDG(lhsd);
3137 ndim = ASD_NDIM(asd);
3138 for (i = 0; i < ndim; i++) {
3139 if (ct->idx[i])
3140 if (ASTLI_SPTR(ct->idx[i]) == ASTLI_SPTR(astli))
3141 return i;
3142 }
3143 return -1;
3144 }
3145
3146 static void
conv_fused_forall(int std,int ast,int * stdnextp)3147 conv_fused_forall(int std, int ast, int *stdnextp)
3148 {
3149 int i;
3150 int forall;
3151 int nd;
3152 int stmt;
3153 int expr;
3154 int fusedstd;
3155 int exprp, exprn;
3156 int forallp, foralln;
3157 int lhs;
3158 int stdnext = *stdnextp;
3159
3160 nd = A_OPT1G(ast);
3161 if (FT_NFUSE(nd, 0) == 0)
3162 return;
3163
3164 for (i = 0; i < FT_NFUSE(nd, 0); i++) {
3165 fusedstd = FT_FUSEDSTD(nd, 0, i);
3166 forall = STD_AST(fusedstd);
3167 if (i == 0)
3168 exprp = 0;
3169 else {
3170 forallp = STD_AST(FT_FUSEDSTD(nd, 0, i - 1));
3171 exprp = A_IFEXPRG(forallp);
3172 }
3173
3174 if (i == FT_NFUSE(nd, 0) - 1)
3175 exprn = 0;
3176 else {
3177 foralln = STD_AST(FT_FUSEDSTD(nd, 0, i + 1));
3178 exprn = A_IFEXPRG(foralln);
3179 }
3180
3181 if (A_TYPEG(forall) != A_FORALL)
3182 continue;
3183 expr = A_IFEXPRG(forall);
3184 if (expr && !is_same_mask(expr, exprp)) {
3185 insert_mask(expr, STD_PREV(stdnext));
3186 }
3187
3188 stmt = A_IFSTMTG(forall);
3189 if (stmt)
3190 rewrite_asn(stmt, 0, FALSE, MAXSUBS);
3191 if (stmt) {
3192 if (A_SRCG(stmt) != A_DESTG(stmt)) {
3193 add_stmt_before(stmt, stdnext);
3194 }
3195 if (expr && !is_same_mask(expr, exprn))
3196 insert_endmask(expr, STD_PREV(stdnext));
3197 }
3198
3199 if (fusedstd == stdnext) {
3200 *stdnextp = STD_NEXT(stdnext);
3201 }
3202 if (STD_LINENO(std) && STD_LINENO(fusedstd))
3203 ccff_info(MSGFUSE, "FUS030", gbl.findex, STD_LINENO(std),
3204 "Array assignment / Forall at line %linelist fused",
3205 "linelist=%d", STD_LINENO(fusedstd), NULL);
3206 delete_stmt(fusedstd);
3207 }
3208 }
3209
3210 static LOGICAL
is_same_mask(int expr,int expr1)3211 is_same_mask(int expr, int expr1)
3212 {
3213
3214 LOGICAL l, r;
3215 int argt, argt1;
3216 int sptr, sptr1;
3217 int dim, dim1;
3218 int ast, ast1;
3219 int ndim, ndim1;
3220 int asd, asd1;
3221
3222 if (expr == 0 || expr1 == 0)
3223 return FALSE;
3224 if (A_TYPEG(expr) != A_TYPEG(expr1))
3225 return FALSE;
3226 switch (A_TYPEG(expr)) {
3227 case A_CMPLXC:
3228 case A_CNST:
3229 case A_ID:
3230 case A_SUBSTR:
3231 case A_MEM:
3232 case A_TRIPLE:
3233 case A_LABEL:
3234 if (expr == expr1)
3235 return TRUE;
3236 else
3237 return FALSE;
3238 case A_SUBSCR:
3239 if (expr == expr1)
3240 return TRUE;
3241
3242 sptr = sym_of_ast(expr);
3243 sptr1 = sym_of_ast(expr1);
3244 /* compare a$arrdsc(41) with b$arrdsc(41)
3245 * if a and b distributed the same way this should be equal */
3246 if (STYPEG(sptr) == ST_ARRDSC && STYPEG(sptr1) == ST_ARRDSC) {
3247 asd = A_ASDG(expr);
3248 ndim = ASD_NDIM(asd);
3249 asd1 = A_ASDG(expr1);
3250 ndim1 = ASD_NDIM(asd1);
3251 assert(ndim == 1 && ndim == ndim1, "is_same_mask: unmatched ndim", expr,
3252 3);
3253 if (ndim != ndim1)
3254 return FALSE;
3255 if (ASD_SUBS(asd, 0) != ASD_SUBS(asd1, 0))
3256 return FALSE;
3257 sptr = ARRAYG(sptr);
3258 sptr1 = ARRAYG(sptr1);
3259 assert(sptr && sptr1, "is_same_mask: can not find original array", sptr,
3260 3);
3261 if (is_same_array_alignment(sptr, sptr1))
3262 return TRUE;
3263 }
3264 return FALSE;
3265
3266 case A_BINOP:
3267 if (A_DTYPEG(expr) != A_DTYPEG(expr1))
3268 return FALSE;
3269 if (A_OPTYPEG(expr) != A_OPTYPEG(expr1))
3270 return FALSE;
3271 l = is_same_mask(A_LOPG(expr), A_LOPG(expr1));
3272 r = is_same_mask(A_ROPG(expr), A_ROPG(expr1));
3273 return l && r;
3274 case A_UNOP:
3275 if (A_DTYPEG(expr) != A_DTYPEG(expr1))
3276 return FALSE;
3277 if (A_OPTYPEG(expr) != A_OPTYPEG(expr1))
3278 return FALSE;
3279 return is_same_mask(A_LOPG(expr), A_LOPG(expr1));
3280 case A_PAREN:
3281 return is_same_mask(A_LOPG(expr), A_LOPG(expr1));
3282 case A_CONV:
3283 if (A_DTYPEG(expr) != A_DTYPEG(expr1))
3284 return FALSE;
3285 return is_same_mask(A_LOPG(expr), A_LOPG(expr1));
3286 case A_INTR:
3287 case A_FUNC:
3288 if (expr == expr1)
3289 return TRUE;
3290 sptr = A_SPTRG(A_LOPG(expr));
3291 sptr1 = A_SPTRG(A_LOPG(expr1));
3292 if (sptr != sptr1)
3293 return FALSE;
3294 if (strcmp(SYMNAME(sptr), mkRteRtnNm(RTE_islocal_idx)) != 0)
3295 return FALSE;
3296 argt = A_ARGSG(expr);
3297 argt1 = A_ARGSG(expr1);
3298
3299 sptr = ARRAYG(memsym_of_ast(ARGT_ARG(argt, 0)));
3300 dim = get_int_cval(A_SPTRG(ARGT_ARG(argt, 1)));
3301 ast = ARGT_ARG(argt, 2);
3302
3303 sptr1 = ARRAYG(memsym_of_ast(ARGT_ARG(argt1, 0)));
3304 dim1 = get_int_cval(A_SPTRG(ARGT_ARG(argt1, 1)));
3305 ast1 = ARGT_ARG(argt1, 2);
3306
3307 if (ast != ast1)
3308 return FALSE;
3309
3310 return TRUE;
3311 default:
3312 interr("is_same_mask: unexpected ast", expr, 2);
3313 return FALSE;
3314 }
3315 }
3316
3317 static LOGICAL
is_same_mask_in_fused(int std,int * pos)3318 is_same_mask_in_fused(int std, int *pos)
3319 {
3320 int forall, forall1;
3321 int fusedstd;
3322 int nd;
3323 int expr, expr1;
3324 int list1, listp;
3325 int isptr;
3326 int i;
3327 int reverse[7];
3328 int n;
3329 CTYPE *ct;
3330 int max;
3331 int ast, src;
3332
3333 /* put all the mask first */
3334 forall = STD_AST(std);
3335 nd = A_OPT1G(forall);
3336 ct = FT_CYCLIC(nd);
3337
3338 expr = A_IFEXPRG(forall);
3339 for (i = 0; i < FT_NFUSE(nd, 0); i++) {
3340 fusedstd = FT_FUSEDSTD(nd, 0, i);
3341 forall1 = STD_AST(fusedstd);
3342 expr1 = A_IFEXPRG(forall1);
3343 if (!is_same_mask(expr, expr1))
3344 return FALSE;
3345 }
3346
3347 /* don't let cyclic and block-cyclic to be mask fused */
3348 /* for (i=0;i<7;i++)
3349 if (ct->cb_block[i] || ct->c_init[i]) return FALSE;
3350 */
3351
3352 *pos = position_finder(forall, expr);
3353
3354 /* Find the position of GETs calls at forall */
3355 for (i = 0; i < FT_NMGET(nd); i++) {
3356 ast = glist(FT_MGET(nd), i);
3357 assert(A_TYPEG(ast) == A_HGETSCLR, "find_mask_calls_pos: wrong ast type",
3358 ast, 3);
3359 src = A_SRCG(ast);
3360 max = position_finder(forall, src);
3361 if (max > *pos)
3362 *pos = max;
3363 }
3364
3365 max = find_max_of_mask_calls_pos(forall);
3366 if (max > *pos)
3367 *pos = max;
3368
3369 for (i = 0; i < FT_NFUSE(nd, 0); i++) {
3370 fusedstd = FT_FUSEDSTD(nd, 0, i);
3371 forall1 = STD_AST(fusedstd);
3372 A_IFEXPRP(forall1, 0);
3373 }
3374
3375 return TRUE;
3376 }
3377
3378 /* Register the barrier at stdBar for all FORALL statements fused with
3379 * astForall. If bBefore = TRUE, the barrier occurs before the loop. */
3380 static void
record_fused_barriers(LOGICAL bBefore,int astForall,int stdBar)3381 record_fused_barriers(LOGICAL bBefore, int astForall, int stdBar)
3382 {
3383 int nd;
3384 int ift;
3385 int nFused, iFused;
3386 int stdFused;
3387 int astFused;
3388
3389 ift = A_OPT1G(astForall);
3390 if (!ift)
3391 return;
3392 nFused = FT_NFUSE(ift, 0);
3393
3394 for (iFused = 0; iFused < nFused; iFused++) {
3395 stdFused = FT_FUSEDSTD(ift, 0, iFused);
3396 astFused = STD_AST(stdFused);
3397 if (!astFused)
3398 continue;
3399 record_barrier(bBefore, astFused, stdBar);
3400 }
3401 }
3402
3403 int
conv_forall(int std)3404 conv_forall(int std)
3405 {
3406 int forall;
3407 int stmt;
3408 int newast;
3409 int stdnext;
3410 int triplet_list;
3411 int triplet;
3412 int index_var;
3413 int n;
3414 int expr;
3415 int std1;
3416 int ldim;
3417 int nd;
3418 CTYPE *ct;
3419 int i;
3420 int revers[7];
3421 int pos, cnt;
3422 LOGICAL samemask;
3423 int lhs_sptr, lhs_ast;
3424 int doifstmt, ifexpr, zero;
3425 int stride, tmp_ifexpr;
3426
3427 stdnext = STD_NEXT(std);
3428 if (no_effect_forall(std))
3429 return stdnext;
3430
3431 forall = STD_AST(std);
3432 n = 0;
3433 triplet_list = A_LISTG(forall);
3434 for (; triplet_list; triplet_list = ASTLI_NEXT(triplet_list))
3435 n++;
3436 find_mask_calls_pos(forall);
3437 pos = n;
3438 samemask = is_same_mask_in_fused(std, &pos);
3439 find_stmt_calls_pos(forall, pos);
3440
3441 n = 0;
3442 triplet_list = A_LISTG(forall);
3443 nd = A_OPT1G(forall);
3444 lhs_ast = left_subscript_ast(A_DESTG(A_IFSTMTG(forall)));
3445 lhs_sptr = memsym_of_ast(lhs_ast);
3446
3447 ct = FT_CYCLIC(nd);
3448 if (ct->ifast)
3449 insert_mask(A_IFEXPRG(ct->ifast), STD_PREV(stdnext));
3450
3451 doifstmt = 1; /* only place if stmt if stride is 1 for now */
3452 ifexpr = 0;
3453 for (; triplet_list; triplet_list = ASTLI_NEXT(triplet_list)) {
3454 revers[n] = triplet_list;
3455 n++;
3456 ldim = 0;
3457 triplet = ASTLI_TRIPLE(triplet_list);
3458
3459 if (!XBIT(34, 0x8000000)) {
3460 if (DTY(DT_INT) != TY_INT8 && !XBIT(68, 0x1)) {
3461 zero = astb.i0;
3462 } else {
3463 zero = astb.bnd.zero;
3464 }
3465 tmp_ifexpr = mk_binop(OP_SUB, A_UPBDG(triplet), A_LBDG(triplet),
3466 A_DTYPEG(A_LBDG(triplet)));
3467 if (A_STRIDEG(triplet) != astb.i1) {
3468 stride = A_STRIDEG(triplet);
3469 if (stride == 0)
3470 stride = astb.i1;
3471 } else {
3472 stride = astb.i1;
3473 }
3474 tmp_ifexpr =
3475 mk_binop(OP_ADD, tmp_ifexpr, stride, A_DTYPEG(A_LBDG(triplet)));
3476 tmp_ifexpr =
3477 mk_binop(OP_DIV, tmp_ifexpr, stride, A_DTYPEG(A_LBDG(triplet)));
3478 tmp_ifexpr = mk_binop(OP_LE, tmp_ifexpr, zero, DT_LOG);
3479 if (ifexpr) {
3480 ifexpr = mk_binop(OP_LOR, tmp_ifexpr, ifexpr, DT_LOG);
3481 } else {
3482 ifexpr = tmp_ifexpr;
3483 }
3484 }
3485
3486 if (ct->lhs)
3487 ldim = lhs_dim(forall, triplet_list);
3488 if (ldim >= 0) {
3489 if (ct->cb_init[ldim])
3490 add_stmt_before(ct->cb_init[ldim], stdnext);
3491 if (ct->cb_do[ldim])
3492 add_stmt_before(ct->cb_do[ldim], stdnext);
3493 if (ct->cb_block[ldim]) {
3494 int astBlock = ct->cb_block[ldim];
3495 int astCall, ast1;
3496 int argt;
3497 int dim;
3498
3499 if (normalize_bounds(lhs_sptr)) {
3500 assert(A_TYPEG(astBlock) == A_CALL && A_ARGCNTG(astBlock) == 8,
3501 "conv_forall: missing block_loop", std, 4);
3502 argt = A_ARGSG(astBlock);
3503 dim = get_int_cval(A_SPTRG(ARGT_ARG(argt, 1))) - 1;
3504 assert(ldim == dim, "conv_forall: missing dim in block_loop", std, 4);
3505
3506 astCall = begin_call(A_CALL, sym_of_ast(A_LOPG(astBlock)), 8);
3507 add_arg(ARGT_ARG(argt, 0)); /* descriptor */
3508 add_arg(ARGT_ARG(argt, 1)); /* dimension */
3509
3510 /* Normalize the lower bound. */
3511 ast1 = ARGT_ARG(argt, 2);
3512 ast1 = sub_lbnd(DTYPEG(lhs_sptr), dim, ast1, lhs_ast);
3513 add_arg(ast1); /* lower bound */
3514
3515 /* Normalize the upper bound. */
3516 ast1 = ARGT_ARG(argt, 3);
3517 ast1 = sub_lbnd(DTYPEG(lhs_sptr), dim, ast1, lhs_ast);
3518 add_arg(ast1); /* upper bound */
3519
3520 add_arg(ARGT_ARG(argt, 4)); /* stride */
3521
3522 add_arg(ARGT_ARG(argt, 5)); /* cycle # */
3523
3524 add_arg(ARGT_ARG(argt, 6)); /* output lower bound */
3525 add_arg(ARGT_ARG(argt, 7)); /* output upper bound */
3526 add_stmt_before(astCall, stdnext);
3527
3528 ast1 = add_lbnd(DTYPEG(lhs_sptr), dim, ARGT_ARG(argt, 6), lhs_ast);
3529 ast1 = mk_assn_stmt(ARGT_ARG(argt, 6), ast1, DT_INT);
3530 add_stmt_before(ast1, stdnext);
3531
3532 ast1 = add_lbnd(DTYPEG(lhs_sptr), dim, ARGT_ARG(argt, 7), lhs_ast);
3533 ast1 = mk_assn_stmt(ARGT_ARG(argt, 7), ast1, DT_INT);
3534 add_stmt_before(ast1, stdnext);
3535 } else
3536 add_stmt_before(astBlock, stdnext);
3537 }
3538 }
3539 }
3540 /* don't do one dimension */
3541 if (n <= 1 || STD_ZTRIP(std) != 1)
3542 doifstmt = 0;
3543
3544 triplet_list = A_LISTG(forall);
3545
3546 cnt = 0;
3547 for (; triplet_list; triplet_list = ASTLI_NEXT(triplet_list)) {
3548 int dovar, tstd;
3549 ldim = 0;
3550 if (ct->lhs)
3551 ldim = lhs_dim(forall, triplet_list);
3552 if (ldim >= 0 && ct->c_init[ldim])
3553 add_stmt_before(ct->c_init[ldim], stdnext);
3554
3555 add_mask_calls(cnt, forall, stdnext);
3556
3557 if (samemask && cnt == pos) {
3558 expr = A_IFEXPRG(forall);
3559 if (expr)
3560 insert_mask(expr, STD_PREV(stdnext));
3561 }
3562
3563 add_stmt_calls(cnt, forall, stdnext);
3564
3565 index_var = ASTLI_SPTR(triplet_list);
3566 triplet = ASTLI_TRIPLE(triplet_list);
3567
3568 newast = mk_stmt(A_DO, 0);
3569 dovar = mk_id(index_var);
3570 A_DOVARP(newast, dovar);
3571 A_M1P(newast, A_LBDG(triplet));
3572 A_M2P(newast, A_UPBDG(triplet));
3573 if (A_STRIDEG(triplet) != astb.i1) {
3574 A_M3P(newast, A_STRIDEG(triplet));
3575 } else {
3576 A_M3P(newast, astb.i1);
3577 }
3578 A_M4P(newast, ifexpr);
3579
3580 tstd = add_stmt_before(newast, stdnext);
3581
3582 STD_ZTRIP(tstd) = 0;
3583 if (doifstmt && !XBIT(34, 0x8000000)) {
3584 STD_ZTRIP(tstd) = 1;
3585 }
3586
3587 cnt++;
3588 }
3589
3590 add_mask_calls(cnt, forall, stdnext);
3591
3592 if (cnt == pos) {
3593 expr = A_IFEXPRG(forall);
3594 if (expr)
3595 insert_mask(expr, STD_PREV(stdnext));
3596 }
3597
3598 add_stmt_calls(cnt, forall, stdnext);
3599
3600 if (ct->inner_cyclic)
3601 for (i = 0; i < ct->inner_cyclic->nitem; i++)
3602 add_stmt_before(glist(ct->inner_cyclic, i), stdnext);
3603
3604 stmt = A_IFSTMTG(forall);
3605
3606 /*
3607 plist = FT_PCALL(nd);
3608 for(ip = 0; ip< FT_NPCALL(nd); ip++) {
3609 pstd = plist->item;
3610 plist = plist->next;
3611 past = STD_AST(pstd);
3612 delete_stmt(pstd);
3613 pstd=add_stmt_before(past, stdnext);
3614 pghpf_local_mode = 1;
3615 transform_ast(pstd, past);
3616 pghpf_local_mode = 0;
3617 }
3618 */
3619 arg_gbl.std = stdnext;
3620 rewrite_asn(stmt, 0, FALSE, MAXSUBS);
3621 if (stmt) {
3622 /* perhaps should move this part related to elemental function
3623 * to another function.
3624 * At this point, a function is already converted to a subroutine call.
3625 * It was done in semfunc.c in func_call().
3626 */
3627 int ast;
3628 int rhs = A_SRCG(stmt);
3629 int lhs = A_DESTG(stmt);
3630 int func_ast = 0;
3631 int func_sptr = 0;
3632 int dt = 0;
3633 int afunc = 0;
3634
3635 if ((afunc = (A_TYPEG(rhs) == A_FUNC))) {
3636 func_ast = A_LOPG(rhs);
3637 func_sptr = A_SPTRG(func_ast);
3638 dt = DTYPEG(func_sptr);
3639 }
3640 if (afunc && func_sptr && ELEMENTALG(func_sptr) && ADJLENG(func_sptr)) {
3641 int argcnt, argt, i;
3642 int result_sptr = A_SPTRG(ARGT_ARG(A_ARGSG(rhs), 0));
3643 int result_ast = mk_id(result_sptr);
3644
3645 /* make A_CALL instead of A_FUNC */
3646 argcnt = A_ARGCNTG(rhs);
3647 argt = mk_argt(argcnt);
3648 ast = mk_func_node(A_CALL, mk_id(func_sptr), argcnt, A_ARGSG(rhs));
3649 std = add_stmt_before(ast, stdnext);
3650
3651 /* b(i) = scalar_temp */
3652 ast = mk_assn_stmt(lhs, result_ast, dt);
3653 std = add_stmt_after(ast, std);
3654 rewrite_asn(ast, 0, FALSE, MAXSUBS);
3655 } else if (A_TYPEG(rhs) == A_INTR &&
3656 (A_OPTYPEG(rhs) == I_ADJUSTL || A_OPTYPEG(rhs) == I_ADJUSTR)) {
3657 /* make a scalar temp instead of an array to avoid allocating memory. In
3658 the case of adjust(l/r) the size of result string is same as incoming
3659 string. So, storing the return value can be optimized out. Hence, the
3660 use of a scalar temp.
3661 */
3662 lhs = mk_id(get_temp(DT_INT));
3663 ast = mk_assn_stmt(lhs, rhs, dt);
3664 add_stmt_before(ast, stdnext);
3665 } else if (A_TYPEG(rhs) == A_INTR && A_OPTYPEG(rhs) == I_TRIM) {
3666 /* In case of trim, the return value needs to be retained as the size
3667 of the returning string may change, hence the incoming lhs with an
3668 array of temps need to be retained.
3669 */
3670 ast = mk_assn_stmt(lhs, rhs, dt);
3671 add_stmt_before(ast, stdnext);
3672 } else if (A_SRCG(stmt) != A_DESTG(stmt)) {
3673 add_stmt_before(stmt, stdnext);
3674 }
3675 if (!samemask && expr)
3676 insert_endmask(expr, STD_PREV(stdnext));
3677
3678 conv_fused_forall(std, forall, &stdnext);
3679
3680 for (i = n - 1; i >= 0; i--) {
3681 int tstd;
3682 triplet_list = revers[i];
3683 if (samemask && i + 1 == pos && expr)
3684 insert_endmask(expr, STD_PREV(stdnext));
3685
3686 ldim = 0;
3687 if (ct->lhs)
3688 ldim = lhs_dim(forall, triplet_list);
3689 if (ldim >= 0 && ct->c_inc[ldim])
3690 add_stmt_before(ct->c_inc[ldim], stdnext);
3691
3692 newast = mk_stmt(A_ENDDO, 0);
3693 tstd = add_stmt_before(newast, stdnext);
3694 if (doifstmt)
3695 STD_ZTRIP(tstd) = 1;
3696 }
3697
3698 if (samemask && i + 1 == pos && expr)
3699 insert_endmask(expr, STD_PREV(stdnext));
3700 for (i = n - 1; i >= 0; i--) {
3701 triplet_list = revers[i];
3702 ldim = 0;
3703 if (ct->lhs)
3704 ldim = lhs_dim(forall, triplet_list);
3705 if (ldim >= 0) {
3706 if (ct->cb_inc[ldim])
3707 add_stmt_before(ct->cb_inc[ldim], stdnext);
3708 if (ct->cb_enddo[ldim])
3709 add_stmt_before(ct->cb_enddo[ldim], stdnext);
3710 }
3711 }
3712 if (ct->endifast)
3713 insert_endmask(A_IFEXPRG(ct->ifast), STD_PREV(stdnext));
3714 } else {
3715 int tstd;
3716 while (TRUE) {
3717 std1 = stdnext;
3718 stmt = STD_AST(stdnext);
3719 stdnext = STD_NEXT(stdnext);
3720 if (A_TYPEG(stmt) == A_ENDFORALL) {
3721 if (expr)
3722 insert_endmask(expr, STD_PREV(stdnext));
3723 newast = mk_stmt(A_ENDDO, 0);
3724 while (n--) {
3725 tstd = add_stmt_before(newast, stdnext);
3726 if (doifstmt)
3727 STD_ZTRIP(tstd) = 1;
3728 }
3729 delete_stmt(std); /* delete forall */
3730 delete_stmt(std1); /* delede endforall */
3731 break;
3732 } else if (A_TYPEG(stmt) == A_FORALL)
3733 stdnext = conv_forall(std);
3734 assert(stdnext, "conv_forall:unmatched forall", std, 4);
3735 }
3736 }
3737
3738 /* fix up line numbers and propagate par flag */
3739 for (i = std; i != stdnext; i = STD_NEXT(i)) {
3740 STD_LINENO(i) = STD_LINENO(std);
3741 STD_PAR(i) = STD_PAR(std);
3742 STD_TASK(i) = STD_TASK(std);
3743 STD_ACCEL(i) = STD_ACCEL(std);
3744 STD_KERNEL(i) = STD_KERNEL(std);
3745 }
3746
3747 /* for parallel PURE calls */
3748 pure_gbl.local_mode = 1;
3749 search_pure_function(std, stdnext);
3750 pure_gbl.local_mode = 0;
3751 ast_to_comment(forall);
3752 return stdnext;
3753 }
3754
3755 static void
replace_loop_on_fuse_list(int oldloop,int maskloop)3756 replace_loop_on_fuse_list(int oldloop, int maskloop)
3757 {
3758 int nd = A_OPT1G(STD_AST(oldloop));
3759 int head = FT_HEADER(nd);
3760 int nfused;
3761 int i;
3762 nd = A_OPT1G(STD_AST(head));
3763 nfused = FT_NFUSE(nd, 0);
3764 for (i = 0; i < nfused; i++) {
3765 if (FT_FUSEDSTD(nd, 0, i) == oldloop) {
3766 FT_FUSEDSTD(nd, 0, i) = maskloop;
3767 break;
3768 }
3769 }
3770 }
3771
3772 /* ast for forall */
3773 /* ast for subscript expression */
3774 /* statement before which to allocate temp */
3775 /* statement after which to deallocate temp */
3776 /* datatype, or zero */
3777 /* ast with data type of element required */
3778 static int
get_temp_forall2(int forall_ast,int subscr_ast,int alloc_stmt,int dealloc_stmt,int dty,int ast_dty)3779 get_temp_forall2(int forall_ast, int subscr_ast, int alloc_stmt,
3780 int dealloc_stmt, int dty, int ast_dty)
3781 {
3782 int sptr, astd, dstd, asd;
3783 int subscr[MAXSUBS];
3784 int par, ndim, lp, std, ast, ast2, i, fg, forloop, fg2, lp2;
3785 int save_sc;
3786 int dtype = dty ? dty : (DDTG(A_DTYPEG(ast_dty)));
3787 int cvlen = 0;
3788 T_LIST *q;
3789 lp = 0;
3790 cvlen = 0;
3791 std = alloc_stmt;
3792
3793 fg = STD_FG(std);
3794 if (A_TYPEG(subscr_ast) == A_MEM) {
3795 goto new_sptr;
3796 /* subscr_ast = A_PARENTG(subscr_ast); */
3797 }
3798 asd = A_ASDG(subscr_ast);
3799 ndim = ASD_NDIM(asd);
3800
3801 if (fg)
3802 lp = FG_LOOP(fg);
3803 else
3804 goto new_sptr;
3805
3806 if (!lp)
3807 goto new_sptr;
3808
3809 if (LP_MEXITS(lp))
3810 goto new_sptr;
3811
3812 /* don't do char for now */
3813 if (DTY(dtype) == TY_CHAR)
3814 goto new_sptr;
3815
3816 add_loop_hd(lp);
3817
3818 /* notes that loop may change when we re-init */
3819 for (q = templist; q; q = q->next) {
3820 fg2 = STD_FG(q->std);
3821 if (fg2)
3822 lp2 = FG_LOOP(fg2);
3823 else
3824 continue;
3825 if (!lp2)
3826 continue;
3827
3828 if (q->std == std || q->dtype != dtype || q->cvlen != cvlen ||
3829 q->sc != symutl.sc || LP_PARENT(lp2) != LP_PARENT(lp))
3830 continue;
3831
3832 if (ndim != ASD_NDIM(q->asd))
3833 continue;
3834 if (same_forall_size(lp2, lp, 0)) {
3835 #if DEBUG
3836 if (DBGBIT(43, 0x800)) {
3837 fprintf(gbl.dbgfil, "Reuse tmp array ostd:%d new:%d sptr:%d\n", q->std,
3838 std, sptr);
3839 }
3840 #endif
3841
3842 /* add and remove stmts to flowgraph */
3843 rdilts(fg);
3844 dstd = mk_mem_deallocate(mk_id(q->temp), dealloc_stmt);
3845 FG_STDLAST(fg) = dstd;
3846 wrilts(fg);
3847
3848 rdilts(fg2);
3849 FG_STDLAST(fg2) = STD_PREV(FG_STDLAST(fg2));
3850 wrilts(fg2);
3851
3852 ast_to_comment(STD_AST(q->dstd));
3853 q->dstd = dstd;
3854 q->std = std;
3855 STD_HSTBLE(q->astd) = dstd;
3856 STD_HSTBLE(q->dstd) = q->astd;
3857 par = STD_PAR(alloc_stmt) || STD_TASK(alloc_stmt);
3858 if (par) {
3859 save_sc = symutl.sc;
3860 set_descriptor_sc(SC_PRIVATE);
3861 }
3862 if (dty) {
3863 sptr = get_forall_subscr(forall_ast, subscr_ast, subscr, dty);
3864 } else {
3865 sptr = get_forall_subscr(forall_ast, subscr_ast, subscr,
3866 DDTG(A_DTYPEG(ast_dty)));
3867 }
3868 if (par) {
3869 set_descriptor_sc(save_sc);
3870 }
3871 return q->temp;
3872 }
3873 }
3874 new_sptr:
3875 par = STD_PAR(alloc_stmt) || STD_TASK(alloc_stmt);
3876 if (par) {
3877 save_sc = symutl.sc;
3878 set_descriptor_sc(SC_PRIVATE);
3879 }
3880
3881 if (dty) {
3882 sptr = mk_forall_sptr(forall_ast, subscr_ast, subscr, dty);
3883 } else {
3884 sptr =
3885 mk_forall_sptr(forall_ast, subscr_ast, subscr, DDTG(A_DTYPEG(ast_dty)));
3886 }
3887 if (par) {
3888 set_descriptor_sc(save_sc);
3889 }
3890
3891 if (fg) {
3892 rdilts(fg);
3893 }
3894 astd = mk_mem_allocate(mk_id(sptr), subscr, alloc_stmt, ast_dty);
3895 dstd = mk_mem_deallocate(mk_id(sptr), dealloc_stmt);
3896 if (fg)
3897 wrilts(fg);
3898
3899 if (!par) {
3900 STD_HSTBLE(astd) = dstd;
3901 STD_HSTBLE(dstd) = astd;
3902 if (STD_ACCEL(alloc_stmt))
3903 STD_RESCOPE(astd) = 1;
3904 if (STD_ACCEL(dealloc_stmt))
3905 STD_RESCOPE(dstd) = 1;
3906 }
3907
3908 GET_T_LIST(q);
3909 q->next = templist;
3910 templist = q;
3911 q->temp = sptr;
3912 q->asd = asd;
3913 q->dtype = dtype;
3914 q->cvlen = cvlen;
3915 q->std = std;
3916 q->sc = symutl.sc;
3917 q->astd = astd;
3918 q->dstd = dstd;
3919
3920 return sptr;
3921 }
3922
3923 static LOGICAL
is_pointer(int ast)3924 is_pointer(int ast)
3925 {
3926 if (A_TYPEG(ast) == A_SUBSCR)
3927 ast = A_LOPG(ast);
3928 if (A_TYPEG(ast) == A_MEM)
3929 ast = A_MEMG(ast);
3930 if (A_TYPEG(ast) != A_ID)
3931 return FALSE;
3932 if (POINTERG(A_SPTRG(ast)))
3933 return TRUE;
3934 return FALSE;
3935 }
3936
3937 /* This routine is to check whether forall has dependency.
3938 * If it has, it creates temp which is shape array with lhs.
3939 * For example,
3940 * forall(i=1:N) a(i) = a(i-1)+.....
3941 * will be rewritten
3942 * forall(i=1:N) temp(i) = a(i-1)+.....
3943 * forall(i=1:N) a(i) = temp(i)
3944 */
3945
3946 /*
3947 * This routine assumes that input is block forall with an assignment
3948 * statement in it.
3949 */
3950 static void
forall_dependency(int std)3951 forall_dependency(int std)
3952 {
3953 int lhs, rhs;
3954 int asn;
3955 int sptr;
3956 int temp_ast;
3957 int newasn;
3958 int forall;
3959 int newforall;
3960 int newstd;
3961 int nd;
3962 int header;
3963 int lineno;
3964 LOGICAL bIndep, isdepend;
3965 int sptr_lhs;
3966 CTYPE *ct;
3967 int lhso;
3968 int par;
3969 int task;
3970 int expr;
3971
3972 forall = STD_AST(std);
3973 par = STD_PAR(std);
3974 task = STD_TASK(std);
3975 asn = A_IFSTMTG(forall);
3976 lhs = A_DESTG(asn);
3977 sptr_lhs = sym_of_ast(lhs);
3978 rhs = A_SRCG(asn);
3979 expr = A_IFEXPRG(forall);
3980
3981 nd = A_OPT1G(forall);
3982 header = FT_HEADER(nd);
3983 /* find pointer original lhs */
3984 if (POINTERG(sptr_lhs)) {
3985 ct = FT_CYCLIC(nd);
3986 if (ct && ct->lhs)
3987 lhso = ct->lhs;
3988 else
3989 lhso = lhs;
3990 } else
3991 lhso = lhs;
3992
3993 /* forall-independent */
3994 lineno = STD_LINENO(std);
3995 open_pragma(lineno);
3996 bIndep = XBIT(19, 0x100) != 0;
3997 if (bIndep) {
3998 close_pragma();
3999 return;
4000 }
4001
4002 /* take conditional expr, if there is dependency */
4003 if (expr)
4004 if (is_dependent(lhs, expr, forall, std, std) ||
4005 is_mask_call_dependent(forall, lhs)) {
4006 if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
4007 if (is_pointer(lhs) && !lhs_needtmp(lhs, rhs, std))
4008 return;
4009 /* get_temp_forall2() is defined in this file */
4010 sptr = get_temp_forall2(forall, lhs, header, std, DT_LOG, 0);
4011 } else {
4012 /* symutl.c:get_temp_forall() */
4013 sptr = get_temp_forall(forall, lhs, header, std, DT_LOG, 0);
4014 }
4015 if (flg.opt >= 2 && !XBIT(2, 0x400000))
4016 temp_ast = reference_for_temp(sptr, lhs, forall);
4017 else
4018 temp_ast = reference_for_temp(sptr, lhso, forall);
4019 A_IFEXPRP(forall, temp_ast);
4020 newforall = mk_stmt(A_FORALL, 0);
4021 A_LISTP(newforall, A_LISTG(forall));
4022 A_OPT1P(newforall, A_OPT1G(forall));
4023 A_IFEXPRP(newforall, 0);
4024 newasn = mk_stmt(A_ASN, 0);
4025 A_DESTP(newasn, temp_ast);
4026 A_SRCP(newasn, expr);
4027 A_IFSTMTP(newforall, newasn);
4028 move_mask_calls(newforall);
4029 remove_mask_calls(newforall);
4030 remove_mask_calls(forall);
4031 newstd = add_stmt_before(newforall, std);
4032 STD_PAR(newstd) = par;
4033 STD_TASK(newstd) = task;
4034
4035 /* add the newstd to the std fuse list */
4036 replace_loop_on_fuse_list(std, newstd);
4037
4038 report_comm(std, DEPENDENCY_CAUSE);
4039 un_fuse(forall);
4040 un_fuse(newforall);
4041
4042 /* need to add this to flow graph otherwise add_loop_hd will drop it */
4043 if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
4044 int fg = STD_FG(std);
4045 int newfg = add_fg(FG_LPREV(fg));
4046 FG_STDLAST(newfg) = newstd;
4047 FG_STDFIRST(newfg) = newstd;
4048 }
4049 }
4050
4051 isdepend = is_dependent(lhs, rhs, forall, std, std);
4052 if (isdepend || is_stmt_call_dependent(forall, lhs)) {
4053 if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
4054 if (is_pointer(lhs) && !lhs_needtmp(lhs, rhs, std)) {
4055 return;
4056 }
4057 /* get_temp_forall2() is defined in this file */
4058 sptr = get_temp_forall2(forall, lhs, header, std, 0, lhs);
4059 } else {
4060 /* symutl.c:get_temp_forall() */
4061 sptr = get_temp_forall(forall, lhs, header, std, 0, lhs);
4062 }
4063 if (flg.opt >= 2 && !XBIT(2, 0x400000))
4064 temp_ast = reference_for_temp(sptr, lhs, forall);
4065 else
4066 temp_ast = reference_for_temp(sptr, lhso, forall);
4067 A_DESTP(asn, temp_ast);
4068 A_IFSTMTP(forall, asn);
4069 newforall = mk_stmt(A_FORALL, 0);
4070 A_LISTP(newforall, A_LISTG(forall));
4071 A_OPT1P(newforall, A_OPT1G(forall));
4072 A_IFEXPRP(newforall, A_IFEXPRG(forall));
4073 newasn = mk_stmt(A_ASN, 0);
4074 A_DESTP(newasn, lhs);
4075 A_SRCP(newasn, temp_ast);
4076 A_IFSTMTP(newforall, newasn);
4077 remove_mask_calls(newforall);
4078 remove_stmt_calls(newforall);
4079 newstd = add_stmt_after(newforall, std);
4080 STD_PAR(newstd) = par;
4081 STD_TASK(newstd) = task;
4082 report_comm(std, DEPENDENCY_CAUSE);
4083 un_fuse(forall);
4084 un_fuse(newforall);
4085 }
4086 close_pragma();
4087 }
4088
4089 static LOGICAL
is_stmt_call_dependent(int forall,int lhs)4090 is_stmt_call_dependent(int forall, int lhs)
4091 {
4092 int nd;
4093 int cstd;
4094 int i;
4095 LOGICAL l;
4096
4097 nd = A_OPT1G(forall);
4098 for (i = 0; i < FT_NSCALL(nd); i++) {
4099 cstd = glist(FT_SCALL(nd), i);
4100 l = is_call_dependent(cstd, forall, lhs);
4101 if (l)
4102 return TRUE;
4103 }
4104 return FALSE;
4105 }
4106
4107 static LOGICAL
is_mask_call_dependent(int forall,int lhs)4108 is_mask_call_dependent(int forall, int lhs)
4109 {
4110 int nd;
4111 int cstd;
4112 int i;
4113 LOGICAL l;
4114
4115 nd = A_OPT1G(forall);
4116 for (i = 0; i < FT_NMCALL(nd); i++) {
4117 cstd = glist(FT_MCALL(nd), i);
4118 l = is_call_dependent(cstd, forall, lhs);
4119 if (l)
4120 return TRUE;
4121 }
4122 return FALSE;
4123 }
4124
4125 static LOGICAL
is_call_dependent(int std,int forall,int lhs)4126 is_call_dependent(int std, int forall, int lhs)
4127 {
4128 int ast, ast1;
4129 int std1;
4130 int nd, nd1;
4131 int i;
4132 int argt;
4133 int nargs;
4134 LOGICAL l;
4135
4136 ast = STD_AST(std);
4137 nd = A_OPT1G(ast);
4138 assert(nd, "is_call_dependent: uninitialized pure call", ast, 3);
4139 nargs = A_ARGCNTG(ast);
4140 argt = A_ARGSG(ast);
4141 for (i = 0; i < nargs; ++i) {
4142 l = is_dependent(lhs, ARGT_ARG(argt, i), forall, std, std);
4143 if (l)
4144 return TRUE;
4145 }
4146
4147 for (i = 0; i < FT_CALL_NCALL(nd); i++) {
4148 std1 = glist(FT_CALL_CALL(nd), i);
4149 ast1 = STD_AST(std1);
4150 nd1 = A_OPT1G(ast1);
4151 assert(nd1, "is_call_dependent: uninitialized pure call", ast1, 3);
4152 l = is_call_dependent(std1, forall, lhs);
4153 if (l)
4154 return TRUE;
4155 }
4156 return FALSE;
4157 }
4158
4159 static void
move_mask_calls(int forall)4160 move_mask_calls(int forall)
4161 {
4162 int nd;
4163 int nd1;
4164
4165 nd = A_OPT1G(forall);
4166 nd1 = mk_ftb();
4167 BCOPY(ftb.base + nd1, ftb.base + nd, FT, 1);
4168 FT_NSCALL(nd1) = FT_NMCALL(nd);
4169 FT_SCALL(nd1) = FT_MCALL(nd);
4170 FT_NSGET(nd1) = FT_NMGET(nd);
4171 FT_SGET(nd1) = FT_MGET(nd);
4172 A_OPT1P(forall, nd1);
4173 }
4174 static void
remove_mask_calls(int forall)4175 remove_mask_calls(int forall)
4176 {
4177 int nd;
4178 int nd1;
4179
4180 nd = A_OPT1G(forall);
4181 nd1 = mk_ftb();
4182 BCOPY(ftb.base + nd1, ftb.base + nd, FT, 1);
4183 FT_NMCALL(nd1) = 0;
4184 FT_MCALL(nd1) = clist();
4185 FT_NMGET(nd1) = 0;
4186 FT_MGET(nd1) = clist();
4187 A_OPT1P(forall, nd1);
4188 }
4189
4190 static void
remove_stmt_calls(int forall)4191 remove_stmt_calls(int forall)
4192 {
4193 int nd;
4194 int nd1;
4195
4196 nd = A_OPT1G(forall);
4197 nd1 = mk_ftb();
4198 BCOPY(ftb.base + nd1, ftb.base + nd, FT, 1);
4199 FT_NSCALL(nd1) = 0;
4200 FT_SCALL(nd1) = clist();
4201 FT_NSGET(nd1) = 0;
4202 FT_SGET(nd1) = clist();
4203 A_OPT1P(forall, nd1);
4204 }
4205
4206 /* This routine return TRUE if there is a possiblity that
4207 * sptr is pointer and points sptr1 or
4208 * sptr1 is pointer and points sptr
4209 * otherwise return FALSE;
4210 * ### add pointer target information here
4211 */
4212 LOGICAL
is_pointer_dependent(int sptr,int sptr1)4213 is_pointer_dependent(int sptr, int sptr1)
4214 {
4215 if (DTY(DTYPEG(sptr)) != DTY(DTYPEG(sptr1)))
4216 return FALSE;
4217 if (POINTERG(sptr))
4218 if (POINTERG(sptr1) || TARGETG(sptr1))
4219 return TRUE;
4220
4221 if (POINTERG(sptr1))
4222 if (POINTERG(sptr) || TARGETG(sptr))
4223 return TRUE;
4224 return FALSE;
4225 }
4226
4227 /* ARRAY COLLAPSING */
4228
4229 /* typedefs for array collapsing */
4230 typedef struct {
4231 int astArr; /* SUBSCR AST of compiler-created array */
4232 int stdAlloc; /* STD of allocate statement for astArr */
4233 int stdDealloc; /* STD of deallocate statement for astArr */
4234 int lp; /* loop # defs of astArr */
4235 int astSclr; /* AST of new scalar */
4236 union {
4237 INT16 all;
4238 struct {
4239 unsigned descr : 1; /* found use of the array's descriptor */
4240 unsigned delete : 1; /* entry has been deleted */
4241 } bits;
4242 } flags;
4243 } COLLAPSE;
4244
4245 /* macros for array collapsing */
4246 #define COLLAPSE_ASTARR(i) collapse.base[i].astArr
4247 #define COLLAPSE_STDALLOC(i) collapse.base[i].stdAlloc
4248 #define COLLAPSE_STDDEALLOC(i) collapse.base[i].stdDealloc
4249 #define COLLAPSE_LP(i) collapse.base[i].lp
4250 #define COLLAPSE_ASTSCLR(i) collapse.base[i].astSclr
4251 #define COLLAPSE_DESCR(i) collapse.base[i].flags.bits.descr
4252 #define COLLAPSE_DELETE(i) collapse.base[i].flags.bits.delete
4253
4254 /* local storage for array collapsing */
4255 static struct {
4256 COLLAPSE *base; /* the COLLAPSE table */
4257 int size; /* size of the COLLAPSE table */
4258 int avail; /* next available struct in the COLLAPSE table */
4259 int lp; /* current loop */
4260 int std; /* current STD */
4261 } collapse;
4262
4263 static void
init_collapse(void)4264 init_collapse(void)
4265 {
4266 /* Initialize local storage. */
4267 collapse.size = 100;
4268 NEW(collapse.base, COLLAPSE, collapse.size);
4269 collapse.avail = 1;
4270 }
4271
4272 /* Replace all compiler-created temp arrays that are used only within
4273 * one loop with scalars. */
4274 static void
collapse_arrays(void)4275 collapse_arrays(void)
4276 {
4277 int ast;
4278 int ci;
4279 int sptrArr, sptrSclr;
4280 int nscalars;
4281
4282 /* Scan STDs looking for ALLOCATE/DEALLOCATE statements. */
4283 find_collapse_allocs();
4284
4285 /* Build the loop table. */
4286 hlopt_init(0);
4287 #if DEBUG
4288 if (DBGBIT(43, 1))
4289 dump_flowgraph();
4290 #endif
4291 #if DEBUG
4292 if (DBGBIT(43, 4))
4293 dump_loops();
4294 #endif
4295
4296 /* Determine if all defs of each array are within a single loop. */
4297 find_collapse_defs();
4298
4299 /* Determine if all uses of each array are within their defining loops. */
4300 find_collapse_uses();
4301
4302 /* Create new scalars */
4303 nscalars = 0;
4304 for (ci = 1; ci < collapse.avail; ci++) {
4305 if (COLLAPSE_DELETE(ci))
4306 continue;
4307 if (!COLLAPSE_ASTARR(ci) || A_TYPEG(COLLAPSE_ASTARR(ci)) != A_SUBSCR) {
4308 delete_collapse(ci);
4309 continue;
4310 }
4311 sptrArr = memsym_of_ast(COLLAPSE_ASTARR(ci));
4312 sptrSclr = sym_get_scalar(SYMNAME(sptrArr), "s", DDTG(DTYPEG(sptrArr)));
4313 COLLAPSE_ASTSCLR(ci) = mk_id(sptrSclr);
4314 nscalars++;
4315 }
4316
4317 if (nscalars)
4318 /* Collapse all arrays within the current program unit. */
4319 collapse_loops();
4320
4321 /* List loops containing collapsed arrays. */
4322 #if DEBUG
4323 if (DBGBIT(43, 256))
4324 report_collapse(0);
4325 #endif
4326
4327 /* Mark arrays with uses of array descriptors. */
4328 find_descrs();
4329
4330 /* Delete ALLOCATE/DEALLOCATE statements for arrays without uses of
4331 * array descriptors. */
4332 collapse_allocates(FALSE);
4333
4334 /* Reclaim storage. */
4335 for (ast = 1; ast < astb.stg_avail; ast++)
4336 A_OPT2P(ast, 0);
4337 hlopt_end(0, 0);
4338
4339 #if DEBUG
4340 if (DBGBIT(43, 128)) {
4341 fprintf(gbl.dbgfil, "----- Statements after array collapsing -----\n");
4342 dump_std();
4343 }
4344 #endif
4345 }
4346
4347 /* Frees memory used to collapse arrays. */
4348 static void
end_collapse(void)4349 end_collapse(void)
4350 {
4351 FREE(collapse.base);
4352 }
4353
4354 /* For each ALLOCATE of a compiler-created array, initialize an entry
4355 * within the COLLAPSE table. Set the OPT2 field of the
4356 * array's AST to the index of its COLLAPSE table entry. */
4357 static void
find_collapse_allocs(void)4358 find_collapse_allocs(void)
4359 {
4360 int std;
4361 int ast, astSrc, astArr;
4362 int ci;
4363
4364 for (std = STD_NEXT(0); std; std = STD_NEXT(std)) {
4365 ast = STD_AST(std);
4366 if (A_TYPEG(ast) != A_ALLOC)
4367 continue;
4368 astSrc = A_SRCG(ast);
4369 if (A_TKNG(ast) == TK_ALLOCATE) {
4370 if (A_TYPEG(astSrc) != A_SUBSCR)
4371 continue; /* ...must be pointer ALLOCATE. */
4372 astArr = A_LOPG(astSrc);
4373 if (A_TYPEG(astArr) != A_ID)
4374 continue;
4375 if (!HCCSYMG(A_SPTRG(astArr)) || !VCSYMG(A_SPTRG(astArr)))
4376 continue; /* array not compiler created */
4377 ci = A_OPT2G(astArr);
4378 if (ci) {
4379 delete_collapse(ci); /* multiple ALLOCATEs found */
4380 continue;
4381 }
4382
4383 /* Create a new COLLAPSE structure. */
4384 ci = collapse.avail++;
4385 NEED(collapse.avail, collapse.base, COLLAPSE, collapse.size,
4386 collapse.size + 100);
4387 BZERO(&collapse.base[ci], COLLAPSE, 1);
4388 COLLAPSE_ASTARR(ci) = astArr;
4389 COLLAPSE_STDALLOC(ci) = std;
4390
4391 /* Set the OPT2 field in the ID AST to point to the COLLAPSE
4392 * structure. */
4393 A_OPT2P(astArr, ci);
4394 } else /* A_TKNG(ast) == TK_DEALLOCATE */ {
4395 astArr = astSrc;
4396 ci = A_OPT2G(astArr);
4397 if (!ci || COLLAPSE_DELETE(ci))
4398 continue; /* array doesn't qualify */
4399 if (COLLAPSE_STDDEALLOC(ci)) {
4400 delete_collapse(ci); /* multiple DEALLOCATEs found */
4401 continue;
4402 }
4403 COLLAPSE_STDDEALLOC(ci) = std;
4404 }
4405 }
4406 }
4407
4408 /* Delete COLLAPSE table entry #ci. */
4409 static void
delete_collapse(int ci)4410 delete_collapse(int ci)
4411 {
4412 COLLAPSE_DELETE(ci) = TRUE;
4413 }
4414
4415 /* Find the loops containing definitions of arrays within the COLLAPSE
4416 * table. */
4417 static void
find_collapse_defs(void)4418 find_collapse_defs(void)
4419 {
4420 int def;
4421 int nme;
4422 int ci;
4423 int lpDef, lpi;
4424
4425 for (ci = 1; ci < collapse.avail; ci++) {
4426 if (COLLAPSE_DELETE(ci))
4427 continue;
4428 if (!COLLAPSE_STDALLOC(ci) || !COLLAPSE_STDDEALLOC(ci)) {
4429 delete_collapse(ci);
4430 continue;
4431 }
4432 nme = A_NMEG(COLLAPSE_ASTARR(ci));
4433 for (def = NME_DEF(nme); def; def = DEF_NEXT(def)) {
4434 if (DEF_STD(def) == COLLAPSE_STDALLOC(ci) ||
4435 DEF_STD(def) == COLLAPSE_STDDEALLOC(ci))
4436 continue;
4437 lpDef = FG_LOOP(DEF_FG(def));
4438 if (LP_CALLFG(lpDef)) {
4439 delete_collapse(ci);
4440 break;
4441 }
4442 if (COLLAPSE_LP(ci)) {
4443 if (lpDef != COLLAPSE_LP(ci) || DEF_LHS(def) != COLLAPSE_ASTARR(ci)) {
4444 /* array assigned in multiple loops or
4445 * different assignments in the same loop */
4446 delete_collapse(ci);
4447 break;
4448 }
4449 } else {
4450 COLLAPSE_LP(ci) = lpDef;
4451 COLLAPSE_ASTARR(ci) = DEF_ADDR(def);
4452 }
4453 }
4454 }
4455 }
4456
4457 /* Determine if uses of arrays in the COLLAPSE table are within the same
4458 * loops in which they are defined. */
4459 static void
find_collapse_uses(void)4460 find_collapse_uses(void)
4461 {
4462 int ci;
4463 int astArr;
4464 int nme;
4465 int def;
4466 DU *du;
4467 int use;
4468
4469 for (ci = 1; ci < collapse.avail; ci++) {
4470 if (COLLAPSE_DELETE(ci))
4471 continue;
4472 astArr = COLLAPSE_ASTARR(ci);
4473 if (A_TYPEG(astArr) == A_SUBSCR)
4474 astArr = A_LOPG(astArr);
4475 assert(A_TYPEG(astArr) == A_ID, "find_collapse_uses: unknown array type",
4476 ci, 4);
4477 nme = A_NMEG(astArr);
4478 for (def = NME_DEF(nme); def; def = DEF_NEXT(def)) {
4479 if (DEF_STD(def) == COLLAPSE_STDALLOC(ci) ||
4480 DEF_STD(def) == COLLAPSE_STDDEALLOC(ci))
4481 continue;
4482 for (du = DEF_DU(def); du; du = du->next) {
4483 use = du->use;
4484 if (is_parent_loop(COLLAPSE_LP(ci), FG_LOOP(USE_FG(use))) &&
4485 COLLAPSE_ASTARR(ci) == USE_ADDR(use))
4486 continue;
4487 delete_collapse(ci);
4488 goto next_ci;
4489 }
4490 }
4491 next_ci:;
4492 }
4493 }
4494
4495 /* Return TRUE if lpParent is a parent loop of loop lp. */
4496 static LOGICAL
is_parent_loop(int lpParent,int lp)4497 is_parent_loop(int lpParent, int lp)
4498 {
4499 if (lpParent == 0)
4500 return TRUE; /* all loops are descendents of loop #0 */
4501 for (; lp; lp = LP_PARENT(lp))
4502 if (lp == lpParent)
4503 return TRUE;
4504 return FALSE;
4505 }
4506
4507 /* Replace collapsible arrays with scalars in all loops within loop lp. */
4508 static void
collapse_loops(void)4509 collapse_loops(void)
4510 {
4511 int std;
4512 int ast, astArr;
4513 int ci;
4514 int nme;
4515 int def;
4516 DU *du;
4517 int use;
4518
4519 for (ci = 1; ci < collapse.avail; ci++) {
4520 if (COLLAPSE_DELETE(ci))
4521 continue;
4522 astArr = COLLAPSE_ASTARR(ci);
4523 if (A_TYPEG(astArr) == A_SUBSCR)
4524 astArr = A_LOPG(astArr);
4525 assert(A_TYPEG(astArr) == A_ID, "collapse_loops: unknown array type", ci,
4526 4);
4527 nme = A_NMEG(astArr);
4528 for (def = NME_DEF(nme); def; def = DEF_NEXT(def)) {
4529 if (DEF_STD(def) == COLLAPSE_STDALLOC(ci) ||
4530 DEF_STD(def) == COLLAPSE_STDDEALLOC(ci))
4531 continue;
4532 ast_visit(1, 1);
4533 ast_replace(COLLAPSE_ASTARR(ci), COLLAPSE_ASTSCLR(ci));
4534 std = DEF_STD(def);
4535 ast = ast_rewrite(STD_AST(std));
4536 STD_AST(std) = ast;
4537 A_STDP(ast, std);
4538 ast_unvisit();
4539 for (du = DEF_DU(def); du; du = du->next) {
4540 ast_visit(1, 1);
4541 use = du->use;
4542 ast_replace(COLLAPSE_ASTARR(ci), COLLAPSE_ASTSCLR(ci));
4543 std = USE_STD(use);
4544 ast = ast_rewrite(STD_AST(std));
4545 STD_AST(std) = ast;
4546 A_STDP(ast, std);
4547 ast_unvisit();
4548 }
4549 }
4550 }
4551 }
4552
4553 static int global_astArrdsc, global_flag;
4554
4555 static void
look_for_descriptor(int ast,int * unused)4556 look_for_descriptor(int ast, int *unused)
4557 {
4558 if (ast == global_astArrdsc)
4559 global_flag = 1;
4560 } /* look_for_descriptor */
4561
4562 /* Set the COLLAPSE_DESCR flag to TRUE for all arrays for which a descriptor
4563 * appears within the program. */
4564 static void
find_descrs(void)4565 find_descrs(void)
4566 {
4567 int ci;
4568 int astArr, astArrdsc, ast;
4569 int sptrArr, sptrArrdsc;
4570 int std, stdend;
4571 int nargs, arg;
4572 int args;
4573 int src;
4574
4575 for (ci = 1; ci < collapse.avail; ci++) {
4576 if (COLLAPSE_DELETE(ci))
4577 continue;
4578 astArr = A_LOPG(COLLAPSE_ASTARR(ci));
4579 sptrArr = A_SPTRG(astArr);
4580 if (NODESCG(sptrArr))
4581 continue;
4582 sptrArrdsc = DESCRG(sptrArr);
4583 astArrdsc = mk_id(sptrArrdsc);
4584 global_astArrdsc = astArrdsc;
4585 global_flag = 0;
4586
4587 /* Search through STDs for an occurrence of astArrdsc in a CALL. */
4588 stdend = STD_NEXT(COLLAPSE_STDDEALLOC(ci));
4589 ast_visit(1, 1);
4590 for (std = COLLAPSE_STDALLOC(ci); global_flag == 0 && std != stdend;
4591 std = STD_NEXT(std)) {
4592 ast = STD_AST(std);
4593 if (A_TYPEG(ast) == A_CALL) {
4594 nargs = A_ARGCNTG(ast);
4595 args = A_ARGSG(ast);
4596 for (arg = 0; arg < nargs; arg++) {
4597 if (ARGT_ARG(args, arg) == astArrdsc) {
4598 global_flag = 1;
4599 break;
4600 }
4601 }
4602 } else if (A_TYPEG(ast) == A_ASN) {
4603 src = A_SRCG(ast);
4604 if (A_TYPEG(src) == A_SUBSCR) {
4605 if (A_LOPG(src) == astArrdsc) {
4606 global_flag = 1;
4607 }
4608 }
4609 } else if (A_TYPEG(ast) == A_IFTHEN) {
4610 /* descriptor might be used by 'gen_single' */
4611 ast_traverse(ast, NULL, look_for_descriptor, NULL);
4612 }
4613 }
4614 if (global_flag)
4615 COLLAPSE_DESCR(ci) = TRUE;
4616 ast_unvisit();
4617 }
4618 }
4619
4620 /* If bDescr is FALSE, remove ALLOCATE/DEALLOCATE statements of
4621 * collapsed arrays without array descriptors. If bDescr is TRUE
4622 * delete ALLOCATE/DEALLOCATE statements of collapsed arrays with
4623 * array descriptors. */
4624 static void
collapse_allocates(LOGICAL bDescr)4625 collapse_allocates(LOGICAL bDescr)
4626 {
4627 int ci;
4628
4629 for (ci = 1; ci < collapse.avail; ci++) {
4630 if (COLLAPSE_DELETE(ci) || bDescr != COLLAPSE_DESCR(ci))
4631 continue;
4632 delete_stmt(COLLAPSE_STDALLOC(ci));
4633 delete_stmt(COLLAPSE_STDDEALLOC(ci));
4634 }
4635 }
4636
4637 static void
report_collapse(int lp)4638 report_collapse(int lp)
4639 {
4640 int ci;
4641 int lpi;
4642 int std;
4643 int lineno;
4644
4645 for (ci = 1; ci < collapse.avail; ci++)
4646 if (!COLLAPSE_DELETE(ci) && COLLAPSE_LP(ci) == lp)
4647 break;
4648 if (ci < collapse.avail) {
4649 for (std = FG_STDFIRST(LP_HEAD(lp)); std; std = STD_PREV(std))
4650 if (STD_LINENO(std))
4651 break;
4652 lineno = (std ? STD_LINENO(std) : 1);
4653 ccff_info(MSGOPT, "OPT044", gbl.findex, lineno,
4654 "Temp arrays collapsed to scalars", NULL);
4655 }
4656
4657 for (lpi = LP_CHILD(lp); lpi; lpi = LP_SIBLING(lpi))
4658 report_collapse(lpi);
4659 }
4660
4661 #if DEBUG
4662
4663 /* Dump the COLLAPSE table. */
4664 static void
dump_collapse(void)4665 dump_collapse(void)
4666 {
4667 int ci;
4668
4669 for (ci = 1; ci < collapse.avail; ci++) {
4670 fprintf(gbl.dbgfil, "Entry %d:\n", ci);
4671 if (COLLAPSE_DELETE(ci)) {
4672 fprintf(gbl.dbgfil, " DELETED\n");
4673 continue;
4674 }
4675 fprintf(gbl.dbgfil, " Temp array: ");
4676 dbg_print_ast(COLLAPSE_ASTARR(ci), gbl.dbgfil);
4677 fprintf(gbl.dbgfil, " Allocate STD %d, Deallocate STD %d, Defining loop "
4678 "%d, Descriptor %d:1\n",
4679 COLLAPSE_STDALLOC(ci), COLLAPSE_STDDEALLOC(ci), COLLAPSE_LP(ci),
4680 COLLAPSE_DESCR(ci));
4681 if (!COLLAPSE_ASTSCLR(ci))
4682 continue;
4683 fprintf(gbl.dbgfil, " New scalar: ");
4684 dbg_print_ast(COLLAPSE_ASTSCLR(ci), gbl.dbgfil);
4685 }
4686 }
4687 #endif
4688
4689 /* END OF ARRAY COLLAPSING */
4690
4691 static int
position_finder(int forall,int ast)4692 position_finder(int forall, int ast)
4693 {
4694 int list1, listp;
4695 int isptr;
4696 int i;
4697 int reverse[7];
4698 int n;
4699 int pos;
4700
4701 n = 0;
4702 list1 = A_LISTG(forall);
4703 for (listp = list1; listp != 0; listp = ASTLI_NEXT(listp)) {
4704 reverse[n] = ASTLI_SPTR(listp);
4705 n++;
4706 }
4707
4708 pos = n;
4709 for (i = n - 1; i >= 0; i--) {
4710 isptr = reverse[i];
4711 if (!contains_ast(ast, mk_id(isptr)))
4712 pos = pos - 1;
4713 else
4714 break;
4715 }
4716
4717 return pos;
4718 }
4719
4720 static void
find_calls_pos(int std,int forall,int must_pos)4721 find_calls_pos(int std, int forall, int must_pos)
4722 {
4723 int ast, ast1;
4724 int std1;
4725 int pos, pos1;
4726 int nd, nd1;
4727 int i;
4728
4729 ast = STD_AST(std);
4730 nd = A_OPT1G(ast);
4731 assert(nd, "find_calls_pos: something is wrong", ast, 3);
4732 pos = position_finder(forall, ast);
4733 if (must_pos > pos)
4734 pos = must_pos;
4735 for (i = 0; i < FT_CALL_NCALL(nd); i++) {
4736 std1 = glist(FT_CALL_CALL(nd), i);
4737 ast1 = STD_AST(std1);
4738 nd1 = A_OPT1G(ast1);
4739 assert(nd1, "find_calls_pos: something is wrong", ast1, 3);
4740 find_calls_pos(std1, forall, must_pos);
4741 pos1 = FT_CALL_POS(nd1);
4742 if (pos1 > pos)
4743 pos = pos1;
4744 }
4745 FT_CALL_POS(nd) = pos;
4746 }
4747
4748 static void
find_mask_calls_pos(int forall)4749 find_mask_calls_pos(int forall)
4750 {
4751 int nd;
4752 int i;
4753 int cstd;
4754
4755 nd = A_OPT1G(forall);
4756 for (i = 0; i < FT_NMCALL(nd); i++) {
4757 cstd = glist(FT_MCALL(nd), i);
4758 find_calls_pos(cstd, forall, 0);
4759 }
4760 }
4761
4762 static void
find_stmt_calls_pos(int forall,int mask_pos)4763 find_stmt_calls_pos(int forall, int mask_pos)
4764 {
4765 int nd;
4766 int cstd;
4767 int i;
4768
4769 nd = A_OPT1G(forall);
4770 for (i = 0; i < FT_NSCALL(nd); i++) {
4771 cstd = glist(FT_SCALL(nd), i);
4772 find_calls_pos(cstd, forall, mask_pos);
4773 }
4774 }
4775
4776 static int
find_max_of_mask_calls_pos(int forall)4777 find_max_of_mask_calls_pos(int forall)
4778 {
4779
4780 int nd, nd1;
4781 int i;
4782 int cstd;
4783 int ast;
4784 int max;
4785 int pos;
4786
4787 max = 0;
4788 nd = A_OPT1G(forall);
4789 for (i = 0; i < FT_NMCALL(nd); i++) {
4790 cstd = glist(FT_MCALL(nd), i);
4791 ast = STD_AST(cstd);
4792 nd1 = A_OPT1G(ast);
4793 assert(nd1, "find_calls_pos: something is wrong", ast, 3);
4794 pos = FT_CALL_POS(nd1);
4795 if (pos > max)
4796 max = pos;
4797 }
4798 return max;
4799 }
4800
4801 static void
put_calls(int pos,int std,int stdnext)4802 put_calls(int pos, int std, int stdnext)
4803 {
4804 int ast, ast1;
4805 int std1;
4806 int pos1;
4807 int nd, nd1;
4808 int i;
4809
4810 ast = STD_AST(std);
4811 nd = A_OPT1G(ast);
4812 assert(nd, "put_calls: something is wrong", ast, 3);
4813 for (i = 0; i < FT_CALL_NCALL(nd); i++) {
4814 std1 = glist(FT_CALL_CALL(nd), i);
4815 ast1 = STD_AST(std1);
4816 nd1 = A_OPT1G(ast1);
4817 assert(nd1, "put_calls: something is wrong", ast1, 3);
4818 put_calls(pos, std1, stdnext);
4819 }
4820 pos1 = FT_CALL_POS(nd);
4821 if (pos == pos1) {
4822 delete_stmt(std);
4823 std = add_stmt_before(ast, stdnext);
4824 pure_gbl.local_mode = 1;
4825 transform_call(std, ast);
4826 pure_gbl.local_mode = 0;
4827 }
4828 }
4829
4830 static void
add_mask_calls(int pos,int forall,int stdnext)4831 add_mask_calls(int pos, int forall, int stdnext)
4832 {
4833 int nd;
4834 int cstd;
4835 int i;
4836
4837 nd = A_OPT1G(forall);
4838 for (i = 0; i < FT_NMCALL(nd); i++) {
4839 cstd = glist(FT_MCALL(nd), i);
4840 put_calls(pos, cstd, stdnext);
4841 }
4842 }
4843
4844 static void
add_stmt_calls(int pos,int forall,int stdnext)4845 add_stmt_calls(int pos, int forall, int stdnext)
4846 {
4847 int nd;
4848 int cstd;
4849 int i;
4850
4851 nd = A_OPT1G(forall);
4852 for (i = 0; i < FT_NSCALL(nd); i++) {
4853 cstd = glist(FT_SCALL(nd), i);
4854 put_calls(pos, cstd, stdnext);
4855 }
4856 }
4857
4858 /* To enter local mode:
4859 * pghpf_saved_local_mode = pghpf_local_mode
4860 * pghpf_local_mode = 1
4861 */
4862 void
enter_local_mode(int std)4863 enter_local_mode(int std)
4864 {
4865 int ast, dest, src;
4866 int sptr = getsymbol("pghpf_local_mode");
4867 int sptr1 = getsymbol("pghpf_saved_local_mode");
4868
4869 STYPEP(sptr1, ST_VAR);
4870 DTYPEP(sptr1, DT_INT);
4871 DCLDP(sptr1, 1);
4872 SCP(sptr1, SC_LOCAL);
4873
4874 ast = mk_stmt(A_ASN, DT_INT);
4875 dest = mk_id(sptr1);
4876 A_DESTP(ast, dest);
4877 src = mk_id(sptr);
4878 A_SRCP(ast, src);
4879 add_stmt_before(ast, std);
4880
4881 ast = mk_stmt(A_ASN, DT_INT);
4882 A_DESTP(ast, src);
4883 A_SRCP(ast, astb.i1);
4884 add_stmt_before(ast, std);
4885 }
4886
4887 /* To exit local mode:
4888 * pghpf_local_mode = pghpf_saved_local_mode
4889 */
4890 void
exit_local_mode(int std)4891 exit_local_mode(int std)
4892 {
4893 int ast, dest, src;
4894 int sptr = getsymbol("pghpf_local_mode");
4895 int sptr1 = getsymbol("pghpf_saved_local_mode");
4896
4897 STYPEP(sptr1, ST_VAR);
4898 DTYPEP(sptr1, DT_INT);
4899 DCLDP(sptr1, 1);
4900 SCP(sptr1, SC_LOCAL);
4901
4902 ast = mk_stmt(A_ASN, DT_INT);
4903 dest = mk_id(sptr);
4904 A_DESTP(ast, dest);
4905 src = mk_id(sptr1);
4906 A_SRCP(ast, src);
4907 add_stmt_before(ast, std);
4908 }
4909
4910 static void
search_pure_function(int stdfirst,int stdlast)4911 search_pure_function(int stdfirst, int stdlast)
4912 {
4913 int std;
4914 int expr, newexpr;
4915 int ast;
4916 int lhs;
4917 int std1, ast1;
4918 int cnt;
4919
4920 for (std = stdfirst; std != stdlast; std = STD_NEXT(std)) {
4921 ast = STD_AST(std);
4922 /* must be forall mask */
4923 if (A_TYPEG(ast) == A_IFTHEN) {
4924 /* find endif */
4925 cnt = 0;
4926 for (std1 = STD_NEXT(std); std1 != stdlast; std1 = STD_NEXT(std1)) {
4927 ast1 = STD_AST(std1);
4928 if (A_TYPEG(ast1) == A_IFTHEN)
4929 cnt++;
4930 if (A_TYPEG(ast1) == A_ENDIF) {
4931 if (cnt == 0)
4932 break;
4933 else
4934 cnt--;
4935 }
4936 }
4937 expr = A_IFEXPRG(ast);
4938 newexpr = transform_pure_function(expr, std);
4939 A_IFEXPRP(ast, newexpr);
4940 }
4941 /* must be forall asn */
4942 else if (A_TYPEG(ast) == A_ASN) {
4943 lhs = A_DESTG(ast);
4944 if (A_TYPEG(lhs) == A_SUBSCR) {
4945 expr = A_SRCG(ast);
4946 newexpr = transform_pure_function(expr, std);
4947 A_SRCP(ast, newexpr);
4948 }
4949 }
4950 }
4951 }
4952
4953 static int
transform_pure_function(int expr,int std)4954 transform_pure_function(int expr, int std)
4955 {
4956
4957 int l, r, d, o;
4958 int l1, l2, l3;
4959 int i, nargs, argt, j;
4960 int lhs;
4961 int newexpr;
4962
4963 if (expr == 0)
4964 return expr;
4965 switch (A_TYPEG(expr)) {
4966 /* expressions */
4967 case A_BINOP:
4968 o = A_OPTYPEG(expr);
4969 d = A_DTYPEG(expr);
4970 l = transform_pure_function(A_LOPG(expr), std);
4971 r = transform_pure_function(A_ROPG(expr), std);
4972 return mk_binop(o, l, r, d);
4973 case A_UNOP:
4974 o = A_OPTYPEG(expr);
4975 d = A_DTYPEG(expr);
4976 l = transform_pure_function(A_LOPG(expr), std);
4977 return mk_unop(o, l, d);
4978 case A_CONV:
4979 d = A_DTYPEG(expr);
4980 l = transform_pure_function(A_LOPG(expr), std);
4981 return mk_convert(l, d);
4982 case A_PAREN:
4983 d = A_DTYPEG(expr);
4984 l = transform_pure_function(A_LOPG(expr), std);
4985 return mk_paren(l, d);
4986 case A_MEM:
4987 l = transform_pure_function(A_PARENTG(expr), std);
4988 r = A_MEMG(expr);
4989 d = A_DTYPEG(r);
4990 return mk_member(l, r, d);
4991 case A_SUBSTR:
4992 return expr;
4993 case A_INTR:
4994 nargs = A_ARGCNTG(expr);
4995 argt = A_ARGSG(expr);
4996 for (i = 0; i < nargs; ++i) {
4997 ARGT_ARG(argt, i) = transform_pure_function(ARGT_ARG(argt, i), std);
4998 }
4999 newexpr = mk_func_node((int)A_TYPEG(expr), A_LOPG(expr), nargs, argt);
5000 A_OPTYPEP(newexpr, A_OPTYPEG(expr));
5001 A_SHAPEP(newexpr, A_SHAPEG(expr));
5002 A_DTYPEP(newexpr, A_DTYPEG(expr));
5003 return newexpr;
5004 case A_FUNC:
5005 nargs = A_ARGCNTG(expr);
5006 argt = A_ARGSG(expr);
5007 for (i = 0; i < nargs; ++i) {
5008 ARGT_ARG(argt, i) = transform_pure_function(ARGT_ARG(argt, i), std);
5009 }
5010 newexpr = mk_func_node((int)A_TYPEG(expr), A_LOPG(expr), nargs, argt);
5011 A_SHAPEP(newexpr, A_SHAPEG(expr));
5012 A_DTYPEP(newexpr, A_DTYPEG(expr));
5013 transform_call(std, newexpr);
5014 return newexpr;
5015 case A_CNST:
5016 case A_CMPLXC:
5017 case A_ID:
5018 case A_SUBSCR:
5019 return expr;
5020 default:
5021 interr("transform_pure_function: unknown expression", expr, 2);
5022 return expr;
5023 }
5024 }
5025
5026 /*
5027 * return +1 at local mode exit, -1 at local mode entry
5028 * local mode exit is 'pghpf_local_mode = saved_pghpf_local_mode'
5029 * local mode entry is 'pghpf_local_mode = 1'
5030 */
5031 static LOGICAL
at_local_mode(int ast)5032 at_local_mode(int ast)
5033 {
5034 int sptr = getsymbol("pghpf_local_mode");
5035 int mkid = mk_id(sptr);
5036 if (A_DESTG(ast) == mkid) {
5037 int src = A_SRCG(ast);
5038 if (src == astb.i1) {
5039 return -1;
5040 } else {
5041 return +1;
5042 }
5043 }
5044 return 0;
5045 } /* at_local_mode */
5046
5047 /*
5048 * eliminate barrier statements that are followed immediately by another
5049 * barrier statement.
5050 * also, eliminate barrier statements inside a 'private' mode loop.
5051 */
5052 static void
eliminate_barrier(void)5053 eliminate_barrier(void)
5054 {
5055 int std, stdPrev;
5056 int ast, bLocal, at;
5057 LOGICAL bFound;
5058
5059 bFound = FALSE;
5060 bLocal = 0;
5061 for (std = STD_LAST; std; std = stdPrev) {
5062 stdPrev = STD_PREV(std);
5063 ast = STD_AST(std);
5064 switch (A_TYPEG(ast)) {
5065 case A_BARRIER:
5066 if (bLocal) {
5067 /* eliminate all barrier statements in local region, */
5068 delete_stmt(std);
5069 } else if (!bFound) {
5070 bFound = TRUE;
5071 } else if (!STD_LABEL(std)) {
5072 delete_stmt(std);
5073 }
5074 break;
5075 case A_CONTINUE:
5076 /* eliminate useless CONTINUE statements */
5077 if (!STD_LABEL(std)) {
5078 delete_stmt(std);
5079 }
5080 break;
5081 case A_ASN:
5082 /* see if we are at the bottom or
5083 * top of a pghpf_local_mode region */
5084 at = at_local_mode(ast);
5085 bLocal += at;
5086 default:
5087 bFound = FALSE;
5088 break;
5089 }
5090 }
5091 }
5092
5093 static LOGICAL
use_offset(int sptr)5094 use_offset(int sptr)
5095 {
5096 LOGICAL retval;
5097 int dtype;
5098 retval = FALSE;
5099 if (SCG(sptr) == SC_BASED || ALLOCG(sptr) || LNRZDG(sptr)) {
5100 int dty;
5101 dtype = DTYPEG(sptr);
5102 dty = DTYG(dtype);
5103 if (NO_PTR || (NO_CHARPTR && dty == TY_CHAR) ||
5104 (NO_DERIVEDPTR && dty == TY_DERIVED)) {
5105 retval = TRUE;
5106 }
5107 }
5108 return retval;
5109 } /* use_offset */
5110
5111 static LOGICAL
needs_linearization(int sptr)5112 needs_linearization(int sptr)
5113 {
5114 LOGICAL retval, alloc;
5115 int dtype;
5116 retval = FALSE;
5117 alloc = FALSE;
5118 if (F90POINTERG(sptr))
5119 return FALSE;
5120 if (ALLOCG(sptr)) {
5121 alloc = TRUE;
5122 } else if (F77OUTPUT) {
5123 dtype = DTYPEG(sptr);
5124 if ((DTY(dtype) == TY_ARRAY && (ADD_DEFER(dtype) || ADD_NOBOUNDS(dtype))) ||
5125 ALIGNG(sptr)) {
5126 alloc = TRUE;
5127 }
5128 }
5129 if (LNRZDG(sptr)) {
5130 retval = TRUE;
5131 } else if (F77OUTPUT) {
5132 if (alloc || use_offset(sptr)) {
5133 retval = TRUE;
5134 }
5135 } else if (alloc && (SCG(sptr) == SC_BASED || STYPEG(sptr) == ST_MEMBER) &&
5136 (MDALLOCG(sptr) || PTROFFG(sptr))) {
5137 retval = TRUE;
5138 }
5139 return retval;
5140 } /* needs_linearization */
5141
5142 static LOGICAL linearize_any;
5143
5144 static void
_linearize(int ast,int * dummy)5145 _linearize(int ast, int *dummy)
5146 {
5147 /* At an A_SUBSCR? Should it be linearized? */
5148 if (A_TYPEG(ast) == A_SUBSCR && A_SHAPEG(ast) == 0) {
5149 int lop, sptr;
5150
5151 lop = A_LOPG(ast);
5152 if (A_TYPEG(lop) == A_ID) {
5153 sptr = A_SPTRG(lop);
5154 } else if (A_TYPEG(lop) == A_MEM) {
5155 sptr = A_SPTRG(A_MEMG(lop));
5156 } else {
5157 return;
5158 }
5159
5160 if (needs_linearization(sptr)) {
5161 /* replace the subscript by the linearized subscripts */
5162 int asd, ndim, sdsc, ss, subscr[1], dtype, eldtype, newast;
5163 lop = ast_rewrite(lop);
5164 linearize_any = TRUE;
5165 asd = A_ASDG(ast);
5166 ndim = ASD_NDIM(asd);
5167 sdsc = SDSCG(sptr);
5168 dtype = DTYPEG(sptr);
5169 eldtype = DDTG(dtype);
5170 if (sdsc && !NODESCG(sptr)) {
5171 int i, simple;
5172 if (!POINTERG(sptr) && SCG(sptr) != SC_DUMMY) {
5173 simple = 1;
5174 } else {
5175 simple = 0;
5176 }
5177 ss = check_member(lop, get_xbase(sdsc));
5178 for (i = 0; i < ndim; ++i) {
5179 int s, stride;
5180 s = ASD_SUBS(asd, i);
5181 s = ast_rewrite(s);
5182 if (XBIT(58, 0x22) && !POINTERG(sptr)) {
5183 int lw;
5184 lw = ADD_LWAST(dtype, i);
5185 if (lw) {
5186 lw = ast_rewrite(lw);
5187 lw = mk_binop(OP_SUB, lw, astb.i1, DT_INT);
5188 s = mk_binop(OP_SUB, s, lw, DT_INT);
5189 }
5190 }
5191 if (i > 0 || !simple) {
5192 stride = check_member(lop, get_local_multiplier(sdsc, i));
5193 s = mk_binop(OP_MUL, s, stride, DT_INT);
5194 }
5195
5196 if (ss == 0) {
5197 ss = s;
5198 } else {
5199 ss = mk_binop(OP_ADD, ss, s, DT_INT);
5200 }
5201 }
5202 } else {
5203 int dsym, ddtype, i;
5204 dsym = DESCRG(sptr);
5205 if (dsym) {
5206 ddtype = DTYPEG(dsym);
5207 if (DTY(ddtype) == TY_ARRAY) {
5208 dtype = ddtype;
5209 }
5210 }
5211 ss = 0;
5212 for (i = ndim; i > 0; --i) {
5213 int s, lw;
5214 lw = ADD_LWAST(dtype, i - 1);
5215 lw = ast_rewrite(lw);
5216 if (lw == 0) {
5217 lw = astb.i1;
5218 }
5219 if (i < ndim && ss != 0) {
5220 int up, stride;
5221 up = ADD_UPAST(dtype, i - 1);
5222 if (up == 0) {
5223 up = astb.i1;
5224 } else {
5225 up = ast_rewrite(up);
5226 }
5227 if (up == lw) {
5228 stride = astb.i1;
5229 } else if (lw == astb.i1) {
5230 stride = up;
5231 } else {
5232 stride = mk_binop(OP_SUB, up, lw, DT_INT);
5233 stride = mk_binop(OP_ADD, stride, astb.i1, DT_INT);
5234 }
5235 if (stride != astb.i1) {
5236 ss = mk_binop(OP_MUL, ss, stride, DT_INT);
5237 }
5238 }
5239 s = ASD_SUBS(asd, i - 1);
5240 s = ast_rewrite(s);
5241 if (ss == 0) {
5242 ss = s;
5243 } else {
5244 ss = mk_binop(OP_ADD, ss, s, DT_INT);
5245 }
5246 if (lw != astb.i0) {
5247 ss = mk_binop(OP_SUB, ss, lw, DT_INT);
5248 }
5249 }
5250 ss = mk_binop(OP_ADD, ss, astb.i1, DT_INT);
5251 }
5252 if (use_offset(sptr)) {
5253 /* add in the offset variable */
5254 int off;
5255 if ((STYPEG(sptr) != ST_MEMBER || POINTERG(sptr)) && PTROFFG(sptr)) {
5256 off = check_member(lop, mk_id(PTROFFG(sptr)));
5257 } else if (MIDNUMG(sptr)) {
5258 off = check_member(lop, mk_id(MIDNUMG(sptr)));
5259 } else {
5260 off = astb.i1;
5261 }
5262 ss = mk_binop(OP_ADD, ss, off, DT_INT);
5263 ss = mk_binop(OP_SUB, ss, astb.i1, DT_INT);
5264 }
5265 subscr[0] = ss;
5266 newast = mk_subscr(lop, subscr, 1, eldtype);
5267 ast_replace(ast, newast);
5268 }
5269 } else if (A_TYPEG(ast) == A_INTR) {
5270 int arg0, argcnt, argt, argtnew, i, diff, parent;
5271 switch (A_OPTYPEG(ast)) {
5272 case I_LBOUND:
5273 case I_UBOUND:
5274 case I_SIZE:
5275 case I_ALLOCATED:
5276 /* leave first argument as is, take the second argument */
5277 argt = A_ARGSG(ast);
5278 arg0 = ARGT_ARG(argt, 0);
5279 if (A_TYPEG(arg0) == A_MEM) {
5280 parent = ast_rewrite(A_PARENTG(arg0));
5281 diff = 0;
5282 if (parent != A_PARENTG(arg0)) {
5283 arg0 = mk_member(parent, A_MEMG(arg0), A_DTYPEG(arg0));
5284 ++diff;
5285 }
5286 }
5287 argcnt = A_ARGCNTG(ast);
5288 argtnew = mk_argt(argcnt);
5289 ARGT_ARG(argtnew, 0) = arg0;
5290 for (i = 1; i < argcnt; ++i) {
5291 ARGT_ARG(argtnew, i) = ast_rewrite(ARGT_ARG(argt, i));
5292 if (ARGT_ARG(argtnew, i) != ARGT_ARG(argt, i))
5293 ++diff;
5294 }
5295 if (!diff) {
5296 unmk_argt(argcnt);
5297 ast_replace(ast, ast);
5298 } else {
5299 int newast;
5300 newast = mk_func_node(A_TYPEG(ast), A_LOPG(ast), argcnt, argtnew);
5301 A_OPTYPEP(newast, A_OPTYPEG(ast));
5302 A_SHAPEP(newast, A_SHAPEG(ast));
5303 A_DTYPEP(newast, A_DTYPEG(ast));
5304 ast_replace(ast, newast);
5305 }
5306 break;
5307 }
5308 }
5309 } /* _linearize */
5310
5311 static void
_linearize_all(int ast)5312 _linearize_all(int ast)
5313 {
5314 int dummy = 0;
5315 ast_traverse(ast, NULL, _linearize, &dummy);
5316 } /* _linearize_all */
5317
5318 static void
_linearize_sub(int ast)5319 _linearize_sub(int ast)
5320 {
5321 int lop, asd, i;
5322 switch (A_TYPEG(ast)) {
5323 case A_ID:
5324 break;
5325 case A_SUBSCR:
5326 /* look at subscripts, look at parent */
5327 asd = A_ASDG(ast);
5328 for (i = 0; i < ASD_NDIM(asd); ++i) {
5329 _linearize_all(ASD_SUBS(asd, i));
5330 }
5331 lop = A_LOPG(ast);
5332 if (A_TYPEG(lop) == A_MEM) {
5333 _linearize_all(A_PARENTG(lop));
5334 }
5335 break;
5336 case A_MEM:
5337 _linearize_all(A_PARENTG(ast));
5338 break;
5339 default:
5340 _linearize_all(ast);
5341 break;
5342 }
5343 } /* _linearize_sub */
5344
5345 static void
_linearize_func(int ast,int * dummy)5346 _linearize_func(int ast, int *dummy)
5347 {
5348 int argcnt, args, i, dont;
5349 int paramct, dpdsc, sptr, param;
5350 dont = -1;
5351 args = A_ARGSG(ast);
5352 switch (A_TYPEG(ast)) {
5353 case A_CALL:
5354 case A_FUNC:
5355 case A_ICALL:
5356 switch (A_OPTYPEG(ast)) {
5357 case I_NULLIFY:
5358 return;
5359 case I_COPYIN:
5360 if (XBIT(57, 0x80)) {
5361 int arg2, arg4;
5362 arg2 = ARGT_ARG(args, 2);
5363 arg4 = ARGT_ARG(args, 4);
5364 if (arg2 == arg4) {
5365 dont = 4;
5366 } else if (A_TYPEG(arg2) == A_SUBSCR && A_LOPG(arg2) == arg4) {
5367 dont = 4;
5368 }
5369 }
5370 break;
5371 case I_COPYOUT:
5372 if (XBIT(57, 0x80)) {
5373 int arg0, arg1;
5374 arg0 = ARGT_ARG(args, 0);
5375 arg1 = ARGT_ARG(args, 1);
5376 if (arg0 == arg1) {
5377 dont = 0;
5378 } else if (A_TYPEG(arg1) == A_SUBSCR && A_LOPG(arg1) == arg0) {
5379 dont = 0;
5380 }
5381 }
5382 break;
5383 case I_PTR2_ASSIGN:
5384 dont = 0;
5385 break;
5386 case I_PTR_COPYIN:
5387 dont = 3;
5388 break;
5389 case I_PTR_COPYOUT:
5390 dont = 0;
5391 break;
5392 }
5393 break;
5394 case A_INTR:
5395 switch (A_OPTYPEG(ast)) {
5396 case I_SIZE:
5397 case I_LBOUND:
5398 case I_UBOUND:
5399 case I_PRESENT:
5400 return;
5401 }
5402 break;
5403 default:
5404 return;
5405 }
5406 argcnt = A_ARGCNTG(ast);
5407 sptr = A_SPTRG(A_LOPG(ast));
5408 if (STYPEG(sptr) == ST_PROC) {
5409 dpdsc = DPDSCG(sptr);
5410 paramct = PARAMCTG(sptr);
5411 } else {
5412 dpdsc = 0;
5413 paramct = 0;
5414 }
5415 for (i = 0; i < argcnt; ++i) {
5416 int arg, sptr;
5417 if (i == dont)
5418 continue;
5419 arg = ARGT_ARG(args, i);
5420 if (arg != 0) {
5421 param = 0;
5422 if (i < paramct && dpdsc) {
5423 param = aux.dpdsc_base[dpdsc + i];
5424 }
5425 switch (A_TYPEG(arg)) {
5426 case A_ID:
5427 sptr = A_SPTRG(arg);
5428 break;
5429 case A_MEM:
5430 sptr = A_SPTRG(A_MEMG(arg));
5431 /* see if remove_distributed_member will fix this */
5432 if (DTY(DTYPEG(sptr)) != TY_ARRAY && /* scalar */
5433 XBIT(70, 0x08) && /*remove_distributed_member is called*/
5434 ((POINTERG(sptr) && !F90POINTERG(sptr)) || ALIGNG(sptr)))
5435 /* and will replace this with a temp */
5436 continue;
5437 break;
5438 default:
5439 continue;
5440 }
5441 if (needs_linearization(sptr) && use_offset(sptr)) {
5442 int subscr[7];
5443 if (param && POINTERG(param)) {
5444 subscr[0] = astb.i1;
5445 } else if ((STYPEG(sptr) != ST_MEMBER || POINTERG(sptr)) &&
5446 PTROFFG(sptr)) {
5447 subscr[0] = check_member(arg, mk_id(PTROFFG(sptr)));
5448 } else if (MIDNUMG(sptr)) {
5449 subscr[0] = check_member(arg, mk_id(MIDNUMG(sptr)));
5450 } else {
5451 subscr[0] = astb.i1;
5452 }
5453 ARGT_ARG(args, i) = mk_subscr(arg, subscr, 1, DDTG(DTYPEG(sptr)));
5454 }
5455 }
5456 }
5457 } /* _linearize_func */
5458
5459 void
linearize_arrays(void)5460 linearize_arrays(void)
5461 {
5462 int std;
5463 int dummy = 0;
5464 deferred_to_pointer();
5465 /* linearize all subscripts */
5466 for (std = STD_NEXT(0); std; std = STD_NEXT(std)) {
5467 int ast;
5468 linearize_any = FALSE;
5469 ast = STD_AST(std);
5470 ast_visit(1, 1);
5471 switch (A_TYPEG(ast)) {
5472 case A_ALLOC:
5473 /* for ALLOCATEs, don't modify the allocate target directly */
5474 if (A_LOPG(ast) != 0) {
5475 _linearize_all(A_LOPG(ast));
5476 }
5477 if (A_DESTG(ast) != 0) {
5478 _linearize_all(A_DESTG(ast));
5479 }
5480 if (A_M3G(ast) != 0) {
5481 _linearize_all(A_M3G(ast));
5482 }
5483 if (A_STARTG(ast) != 0) {
5484 _linearize_all(A_STARTG(ast));
5485 }
5486 _linearize_sub(A_SRCG(ast));
5487 break;
5488 case A_REDIM: /* skip REDIM statements */
5489 break;
5490 default:
5491 _linearize_all(ast);
5492 break;
5493 }
5494 if (linearize_any) {
5495 ast = ast_rewrite(ast);
5496 STD_AST(std) = ast;
5497 }
5498 ast_unvisit();
5499 ast_visit(1, 1);
5500 ast_traverse(ast, NULL, _linearize_func, &dummy);
5501 ast_unvisit();
5502 }
5503 } /* linearize_arrays */
5504
5505 /*
5506 * head of linked list of DEFs in each STD
5507 */
5508 static int *stddeflist;
5509 /*
5510 * head of linked list of DEFs in each LOOP
5511 */
5512 static int *loopdeflist;
5513
5514 typedef struct syminfostruct {
5515 int loop, defs;
5516 } syminfostruct;
5517
5518 static syminfostruct *syminfo;
5519
5520 static int clean;
5521 static int always_executed;
5522 static int chk_assign;
5523 static int chk_subscr;
5524
5525 /*
5526 * set clean=0 and return immediately (with TRUE value) if
5527 * we find a symbol which was modified in this loop
5528 * we find an operation that is not clean:
5529 * user function call
5530 * divide
5531 * non-integer multiply
5532 *
5533 */
5534 static LOGICAL
_check_clean(int ast,int * pl)5535 _check_clean(int ast, int *pl)
5536 {
5537 int l, o, sptr;
5538 int asd, i;
5539
5540 l = *pl;
5541 switch (A_TYPEG(ast)) {
5542 case A_ID:
5543 sptr = A_SPTRG(ast);
5544 if (syminfo[sptr].loop == l) {
5545 /* must have been a def in this loop */
5546 clean = 0;
5547 } else if (SCG(sptr) == SC_BASED && MIDNUMG(sptr) &&
5548 syminfo[MIDNUMG(sptr)].loop == l) {
5549 /* must have been a def in this loop */
5550 clean = 0;
5551 } else if (SCG(sptr) == SC_BASED && !always_executed) {
5552 /* pointer may be null */
5553 clean = 0;
5554 } else if (POINTERG(sptr) && !always_executed) {
5555 /* pointer may be null */
5556 clean = 0;
5557 } else if (chk_assign && chk_subscr && !always_executed) {
5558 clean = 0;
5559 } else if (LP_CALLFG(l)) {
5560 /*
5561 * The LP_CALLFG check must be last; need to check 'sptr' as above.
5562 * if there is a call in the loop, and this is a COMMON symbol, unclean
5563 */
5564 if (SCG(sptr) == SC_CMBLK || (SCG(sptr) == SC_BASED && MIDNUMG(sptr) &&
5565 SCG(MIDNUMG(sptr)) == SC_CMBLK)) {
5566 clean = 0;
5567 }
5568
5569 if (ALLOCDESCG(sptr)) {
5570 clean = 0;
5571 }
5572 }
5573 break;
5574 case A_SUBSCR:
5575 asd = A_ASDG(ast);
5576 chk_subscr = 1;
5577 for (i = 0; i < (int)ASD_NDIM(asd); i++) {
5578 ast_traverse((int)ASD_SUBS(asd, i), _check_clean, NULL, pl);
5579 if (clean == 0)
5580 break;
5581 }
5582 chk_subscr = 0;
5583 break;
5584 case A_BINOP:
5585 o = A_OPTYPEG(ast);
5586 if (o == OP_DIV) {
5587 clean = 0;
5588 } else if (o == OP_MUL) {
5589 int d;
5590 d = A_DTYPEG(ast);
5591 if (!DT_ISINT(d)) {
5592 clean = 0;
5593 }
5594 }
5595 break;
5596 case A_FUNC:
5597 case A_CALL:
5598 clean = 0;
5599 break;
5600 case A_INTR:
5601 switch (A_OPTYPEG(ast)) {
5602 case I_RAN:
5603 case I_RANDOM_NUMBER:
5604 case I_RANDOM_SEED:
5605 clean = 0;
5606 break;
5607 }
5608 break;
5609 }
5610 if (clean == 0)
5611 return TRUE;
5612 return FALSE;
5613 } /* _check_clean */
5614
5615 /*
5616 * float a statement out of a loop
5617 */
5618 static void
sfloat_stmt(int std,int fg,int l)5619 sfloat_stmt(int std, int fg, int l)
5620 {
5621 int next, prev, head, prehead;
5622 #if DEBUG
5623 if (DBGBIT(43, 0x800)) {
5624 fprintf(gbl.dbgfil, "FLOAT std:%d out of fnode:%d in loop:%d\n", std, fg,
5625 l);
5626 }
5627 #endif
5628
5629 /* remove stmt from std list */
5630 next = STD_NEXT(std);
5631 prev = STD_PREV(std);
5632
5633 STD_PREV(next) = prev;
5634 STD_NEXT(prev) = next;
5635
5636 /* remove stmt from fg's statement list */
5637 if (std == FG_STDFIRST(fg)) {
5638 if (std != FG_STDLAST(fg)) {
5639 FG_STDFIRST(fg) = next;
5640 } else {
5641 /* we've moved the only statement out */
5642 FG_STDFIRST(fg) = 0;
5643 FG_STDLAST(fg) = 0;
5644 }
5645 } else if (std == FG_STDLAST(fg)) {
5646 FG_STDLAST(fg) = prev;
5647 }
5648
5649 /* find FG node into which to insert the statement */
5650 head = LP_HEAD(l);
5651 prehead = FG_LPREV(head);
5652 STD_FG(std) = prehead;
5653
5654 if (FG_STDFIRST(prehead) == 0) {
5655 FG_STDFIRST(prehead) = std;
5656 }
5657 FG_STDLAST(prehead) = std;
5658
5659 do {
5660 /* should iterate only once, DO is the top of the loop */
5661 next = FG_STDFIRST(head);
5662 head = FG_LNEXT(head);
5663 } while (next == 0);
5664
5665 prev = STD_PREV(next);
5666 STD_NEXT(prev) = std;
5667 STD_PREV(next) = std;
5668 STD_NEXT(std) = next;
5669 STD_PREV(std) = prev;
5670 } /* sfloat_stmt */
5671
5672 /*
5673 * move a statement out of a loop downward
5674 *
5675 */
5676 static void
sdrop_stmt(int std,int fg,int l)5677 sdrop_stmt(int std, int fg, int l)
5678 {
5679 int next, prev, tail, nexthead, laststd;
5680 #if DEBUG
5681 if (DBGBIT(43, 0x800)) {
5682 fprintf(gbl.dbgfil, "DROP2 std:%d out of fnode:%d in loop:%d\n", std, fg,
5683 l);
5684 }
5685 #endif
5686
5687 /* remove stmt from std list */
5688 next = STD_NEXT(std);
5689 prev = STD_PREV(std);
5690
5691 STD_PREV(next) = prev;
5692 STD_NEXT(prev) = next;
5693
5694 /* remove stmt from fg's statement list */
5695 if (std == FG_STDFIRST(fg)) {
5696 if (std != FG_STDLAST(fg)) {
5697 FG_STDFIRST(fg) = next;
5698 } else {
5699 /* we've moved the only statement out */
5700 FG_STDFIRST(fg) = 0;
5701 FG_STDLAST(fg) = 0;
5702 }
5703 }
5704 if (std == FG_STDLAST(fg)) {
5705 FG_STDLAST(fg) = prev;
5706 }
5707
5708 STD_NEXT(std) = 0;
5709 STD_PREV(std) = 0;
5710 /* put new std at the end of the list */
5711 if (LP_DSTDF(l)) {
5712 int tstd = LP_DSTDF(l);
5713 while (STD_NEXT(tstd)) {
5714 tstd = STD_NEXT(tstd);
5715 }
5716 STD_NEXT(tstd) = std;
5717 STD_PREV(std) = tstd;
5718
5719 } else {
5720 LP_DSTDF(l) = std;
5721 }
5722 }
5723
5724 static void
sfloat_stmt2(int std,int fg,int l)5725 sfloat_stmt2(int std, int fg, int l)
5726 {
5727 int next, prev, head, prehead;
5728 #if DEBUG
5729 if (DBGBIT(43, 0x800)) {
5730 fprintf(gbl.dbgfil, "FLOAT2 std:%d out of fnode:%d in loop:%d\n", std, fg,
5731 l);
5732 }
5733 #endif
5734
5735 /* remove stmt from std list */
5736 next = STD_NEXT(std);
5737 prev = STD_PREV(std);
5738
5739 STD_PREV(next) = prev;
5740 STD_NEXT(prev) = next;
5741
5742 /* remove stmt from fg's statement list */
5743 if (std == FG_STDFIRST(fg)) {
5744 if (std != FG_STDLAST(fg)) {
5745 FG_STDFIRST(fg) = next;
5746 } else {
5747 /* we've moved the only statement out */
5748 FG_STDFIRST(fg) = 0;
5749 FG_STDLAST(fg) = 0;
5750 }
5751 } else if (std == FG_STDLAST(fg)) {
5752 FG_STDLAST(fg) = prev;
5753 }
5754 STD_NEXT(std) = 0;
5755 STD_PREV(std) = 0;
5756 /* append new std at the end of the list */
5757 if (LP_HSTDF(l)) {
5758 int tstd = LP_HSTDF(l);
5759 while (STD_NEXT(tstd)) {
5760 tstd = STD_NEXT(tstd);
5761 }
5762 STD_NEXT(tstd) = std;
5763 STD_PREV(std) = tstd;
5764 } else {
5765 LP_HSTDF(l) = std;
5766 }
5767 }
5768
5769 void
hoist_stmt(int std,int fg,int l)5770 hoist_stmt(int std, int fg, int l)
5771 {
5772 if (STD_VISIT(std))
5773 return;
5774 /* don't do multiple exits not yet */
5775 if (LP_MEXITS(l))
5776 return;
5777
5778 STD_VISIT(std) = 1;
5779
5780 if (is_dealloc_std(std))
5781 sdrop_stmt(std, STD_FG(std), l);
5782 else
5783 sfloat_stmt2(std, STD_FG(std), l);
5784 }
5785
5786 void
restore_hoist_stmt(int lp)5787 restore_hoist_stmt(int lp)
5788 {
5789 int next, prev, tail, head, nexthead, laststd, posttail, prehead, tstd;
5790
5791 int std = LP_HSTDF(lp);
5792 if (std) {
5793 laststd = std;
5794 STD_VISIT(std) = 0;
5795 while (STD_NEXT(laststd)) {
5796 laststd = STD_NEXT(laststd);
5797 STD_VISIT(laststd) = 0;
5798 }
5799 /* find FG node into which to insert the statement */
5800 head = LP_HEAD(lp);
5801 prehead = FG_LPREV(head);
5802 STD_FG(std) = prehead;
5803
5804 if (FG_STDFIRST(prehead) == 0) {
5805 FG_STDFIRST(prehead) = std;
5806 }
5807 FG_STDLAST(prehead) = laststd;
5808
5809 do {
5810 /* should iterate only once, DO is the top of the loop */
5811 next = FG_STDFIRST(head);
5812 head = FG_LNEXT(head);
5813 } while (next == 0);
5814
5815 prev = STD_PREV(next);
5816 STD_NEXT(prev) = std;
5817 STD_PREV(next) = laststd;
5818 STD_NEXT(laststd) = next;
5819 STD_PREV(std) = prev;
5820 }
5821
5822 std = LP_DSTDF(lp);
5823 if (std) {
5824 STD_VISIT(std) = 0;
5825 laststd = std;
5826 while (STD_NEXT(laststd)) {
5827 laststd = STD_NEXT(laststd);
5828 }
5829
5830 /* find FG node into which to insert the statement */
5831 tail = LP_TAIL(lp);
5832 posttail = FG_LNEXT(tail);
5833 next = FG_STDFIRST(posttail);
5834 while (next == 0) {
5835 posttail = FG_LNEXT(posttail);
5836 next = FG_STDFIRST(posttail);
5837 }
5838
5839 for (tstd = std; tstd; tstd = STD_NEXT(tstd)) {
5840 STD_FG(tstd) = posttail;
5841 STD_VISIT(tstd) = 0;
5842 }
5843
5844 prev = STD_PREV(next);
5845 STD_PREV(std) = prev;
5846 STD_NEXT(prev) = std;
5847 STD_PREV(next) = laststd;
5848 STD_NEXT(laststd) = next;
5849 }
5850 }
5851
5852 /*
5853 * record the def of a symbol; also, record any equivalenced defs.
5854 */
5855 static void
add_def_syminfo(int sptr,int l)5856 add_def_syminfo(int sptr, int l)
5857 {
5858 int socptr;
5859 int ss;
5860
5861 if (syminfo[sptr].loop != l) {
5862 syminfo[sptr].loop = l;
5863 syminfo[sptr].defs = 0;
5864 }
5865 ++syminfo[sptr].defs;
5866
5867 for (socptr = SOCPTRG(sptr); socptr; socptr = SOC_NEXT(socptr)) {
5868 ss = SOC_SPTR(socptr);
5869 if (syminfo[ss].loop != l) {
5870 syminfo[ss].loop = l;
5871 syminfo[ss].defs = 0;
5872 }
5873 ++syminfo[ss].defs;
5874 }
5875 }
5876
5877 /*
5878 * given a loop, look at the loop header node.
5879 * it should have only one non-loop predecessor, which should have only
5880 * one successor, the loop header. That node is then a valid preheader.
5881 */
5882 static LOGICAL
have_preheader(int l)5883 have_preheader(int l)
5884 {
5885 int h, n, ph, v;
5886 PSI_P pred;
5887 PSI_P succ;
5888 h = LP_HEAD(l);
5889 n = 0;
5890 ph = 0;
5891 for (pred = FG_PRED(h); pred; pred = PSI_NEXT(pred)) {
5892 v = PSI_NODE(pred);
5893 if (FG_LOOP(v) != l) {
5894 ++n;
5895 if (n > 1)
5896 return FALSE;
5897 ph = v;
5898 }
5899 }
5900 if (n != 1)
5901 return FALSE;
5902 succ = FG_SUCC(ph);
5903 if (succ == PSI_P_NULL || PSI_NEXT(succ))
5904 return FALSE;
5905 if (PSI_NODE(succ) != h)
5906 return FALSE;
5907 /* only one predecessor outside the loop, it has only one successor */
5908 return TRUE;
5909 } /* have_preheader */
5910
5911 /*
5912 * if 'l' is an inner loop, look at the nodes in the loop
5913 * look at assignments and section descriptor function calls in those nodes
5914 * if this is the only assignment to the LHS and the RHS is loop invariant,
5915 * (for section descriptor functions, LHS is 1st argument, RHS is other args)
5916 * then float the statement out of the loop.
5917 * if the node is not control-equivalent to the loop entry, then require
5918 * the LHS to be a compiler temp, and the RHS to be 'safe'
5919 * safe means no faults (no divides unless denominator is constant)
5920 */
5921 static void
sfloat(int l)5922 sfloat(int l)
5923 {
5924 int lc, fg, std, ast, firstd, lastd;
5925 /* inner loops first */
5926 for (lc = LP_CHILD(l); lc; lc = LP_SIBLING(lc)) {
5927 sfloat(lc);
5928 }
5929
5930 /* count how many defs of each variable in the loop */
5931 /* look at flow graph nodes in this loop */
5932 for (fg = LP_FG(l); fg; fg = FG_NEXT(fg)) {
5933 /* look at statements in this flow graph node */
5934 int std, stdlast;
5935 stdlast = FG_STDLAST(fg);
5936 for (std = FG_STDFIRST(fg); std; std = STD_NEXT(std)) {
5937 int d;
5938 for (d = stddeflist[std]; d; d = DEF_NEXT(d)) {
5939 int nm;
5940 for (nm = DEF_NM(d); nm; nm = NME_NM(nm)) {
5941 int sptr;
5942 sptr = NME_SYM(nm);
5943 if (sptr > NOSYM) {
5944 add_def_syminfo(sptr, l);
5945 }
5946 }
5947 }
5948 if (std == stdlast)
5949 break;
5950 }
5951 }
5952 for (lc = LP_CHILD(l); lc; lc = LP_SIBLING(lc)) {
5953 int d;
5954 for (d = loopdeflist[lc]; d; d = DEF_NEXT(d)) {
5955 int nm;
5956 for (nm = DEF_NM(d); nm; nm = NME_NM(nm)) {
5957 int sptr;
5958 sptr = NME_SYM(nm);
5959 if (sptr > NOSYM) {
5960 add_def_syminfo(sptr, l);
5961 }
5962 }
5963 }
5964 }
5965
5966 /* focus on DO loops */
5967 fg = LP_HEAD(l);
5968 std = FG_STDFIRST(fg);
5969 ast = STD_AST(std);
5970 if (A_TYPEG(ast) == A_DO || (XBIT(70, 0x800) && have_preheader(l))) {
5971 /* look at flow graph nodes in this loop */
5972 for (fg = LP_FG(l); fg; fg = FG_NEXT(fg)) {
5973 /* look at statements in this flow graph node */
5974 int std, nextstd, stdlast;
5975 stdlast = FG_STDLAST(fg);
5976 for (std = FG_STDFIRST(fg); std; std = nextstd) {
5977 /* is this an assignment that can be floated out,
5978 * or is this a template call that can be floated out */
5979 int ast, lhs, rhs, sptr, funcast, ll, nme;
5980 nextstd = STD_NEXT(std);
5981 ast = STD_AST(std);
5982 switch (A_TYPEG(ast)) {
5983 case A_ASN:
5984 lhs = A_DESTG(ast);
5985 rhs = A_SRCG(ast);
5986 if (A_TYPEG(lhs) != A_ID)
5987 break;
5988 sptr = A_SPTRG(lhs);
5989 if (SCG(sptr) != SC_LOCAL || (gbl.internal == 1 && LP_CALLFG(l)))
5990 break;
5991 if (gbl.internal > 1 && !INTERNALG(sptr) && LP_CALLFG(l))
5992 break;
5993 /*
5994 * must be unconditional or dead after the loop.
5995 * the only definition of this symbol in the loop,
5996 * free of side effects or faults,
5997 * loop-invariant RHS
5998 */
5999 nme = add_arrnme(NT_VAR, sptr, 0, (INT)0, 0, FALSE);
6000 if ((!FG_CTLEQUIV(fg) && is_live_out(nme, l)) || is_live_in(nme, l))
6001 break;
6002 if (syminfo[sptr].loop != l || syminfo[sptr].defs != 1)
6003 break;
6004 /* loop invariant, side-effect-free RHS */
6005 clean = 1;
6006 always_executed = FG_CTLEQUIV(fg);
6007 ll = l;
6008 chk_assign = 1;
6009 ast_visit(1, 1);
6010 ast_traverse(rhs, _check_clean, NULL, &ll);
6011 ast_unvisit();
6012 chk_assign = 0;
6013 if (clean) {
6014 /* move this statement to the loop preheader. */
6015 sfloat_stmt(std, fg, l);
6016 }
6017 break;
6018 case A_CALL:
6019 funcast = A_LOPG(ast);
6020 if (A_TYPEG(funcast) == A_ID &&
6021 getF90TmplSectRtn(SYMNAME(A_SPTRG(funcast)))) {
6022 int argcnt, args, i;
6023 argcnt = A_ARGCNTG(ast);
6024 args = A_ARGSG(ast);
6025 lhs = ARGT_ARG(args, 0);
6026 if (A_TYPEG(lhs) != A_ID)
6027 break;
6028 sptr = A_SPTRG(lhs);
6029 if (SCG(sptr) != SC_LOCAL || (gbl.internal == 1 && LP_CALLFG(l)))
6030 break;
6031 if (gbl.internal > 1 && !INTERNALG(sptr) && LP_CALLFG(l))
6032 break;
6033 /* must be unconditional or a compiler temp array for which this
6034 * is a section descriptor,
6035 * the only definition of this descriptor in the loop,
6036 * free of side effects or faults,
6037 * loop-invariant arguments
6038 */
6039 nme = add_arrnme(NT_VAR, sptr, 0, (INT)0, 0, FALSE);
6040 if (!FG_CTLEQUIV(fg) && (is_live_out(nme, l) || is_live_in(nme, l)))
6041 /*if( PUREG(sptr) && !FG_CTLEQUIV(fg) )*/
6042 break;
6043 if (syminfo[sptr].loop != l || syminfo[sptr].defs != 1)
6044 break;
6045 clean = 1;
6046 ll = l;
6047 /*always_executed = FG_CTLEQUIV(fg);*/
6048 /* for now, just assume calls are always executed;
6049 * other checks for side-effects are sufficient ...?
6050 */
6051 always_executed = 1;
6052 ast_visit(1, 1);
6053 for (i = 1; clean && i < argcnt; ++i) {
6054 rhs = ARGT_ARG(args, i);
6055 ast_traverse(rhs, _check_clean, NULL, &ll);
6056 }
6057 ast_unvisit();
6058 if (clean) {
6059 /* move this statement to the loop preheader. */
6060 sfloat_stmt(std, fg, l);
6061 }
6062 }
6063 break;
6064 }
6065 if (std == stdlast)
6066 break;
6067 }
6068 }
6069 }
6070
6071 /* put the DEFs from the statements in the loop
6072 * onto the list of DEFs for this loop */
6073 /* look at flow graph nodes in this loop */
6074 firstd = 0;
6075 lastd = 0;
6076 for (fg = LP_FG(l); fg; fg = FG_NEXT(fg)) {
6077 /* look at statements in this flow graph node */
6078 int std;
6079 for (std = FG_STDFIRST(fg); std; std = STD_NEXT(std)) {
6080 int d;
6081 d = stddeflist[std];
6082 if (d) {
6083 if (firstd == 0) {
6084 firstd = d;
6085 } else {
6086 DEF_NEXT(lastd) = d;
6087 }
6088 for (; d; d = DEF_NEXT(d)) {
6089 lastd = d;
6090 }
6091 /* here, lastd points to the end of the list */
6092 stddeflist[std] = 0; /* no vestigial pointers */
6093 }
6094 if (std == FG_STDLAST(fg))
6095 break;
6096 }
6097 }
6098 for (lc = LP_CHILD(l); lc; lc = LP_SIBLING(lc)) {
6099 int d;
6100 d = loopdeflist[lc];
6101 if (d) {
6102 if (firstd == 0) {
6103 firstd = d;
6104 } else {
6105 DEF_NEXT(lastd) = d;
6106 }
6107 for (; d; d = DEF_NEXT(d)) {
6108 lastd = d;
6109 }
6110 /* here, lastd points to the end of the list */
6111 loopdeflist[lc] = 0; /* no vestigial pointers */
6112 }
6113 }
6114 loopdeflist[l] = firstd;
6115 } /* sfloat */
6116
6117 /*
6118 * look for section descriptor manipulations,
6119 * such as RTE_template, pghpf_sect calls,
6120 * float these out of loops if possible
6121 */
6122 void
sectfloat(void)6123 sectfloat(void)
6124 {
6125 int savex, l, fg, nm, s;
6126 optshrd_init();
6127 induction_init();
6128 optshrd_finit();
6129 savex = flg.x[6]; /* disable flow graph changes here */
6130 flg.x[6] |= 0x80000000;
6131 /* build the flowgraph for the function */
6132 flowgraph();
6133 postdominators();
6134 /* build the loop data structure */
6135 findlooptopsort();
6136 reorderloops();
6137 /* do flow analysis on the loops */
6138 flow();
6139
6140 /* find control-equivalent nodes in loops */
6141 for (fg = 1; fg < opt.num_nodes; ++fg) {
6142 l = FG_LOOP(fg);
6143 if (l) {
6144 int head;
6145 head = LP_HEAD(l);
6146 if (fg == head) {
6147 /* this IS the loop head */
6148 FG_CTLEQUIV(fg) = 1;
6149 } else {
6150 int dom;
6151 dom = FG_DOM(fg);
6152 if (dom && FG_LOOP(dom) == l && FG_CTLEQUIV(dom) &&
6153 FG_PDOM(dom) == fg) {
6154 /* simple case, control equivalent to a control equivalent node */
6155 FG_CTLEQUIV(fg) = 1;
6156 } else if (is_dominator(head, fg) && is_post_dominator(fg, head)) {
6157 /* harder case; see if LP_HEAD dominates this node and this
6158 * node post-dominates LP_HEAD */
6159 FG_CTLEQUIV(fg) = 1;
6160 }
6161 }
6162 }
6163 }
6164
6165 #if DEBUG
6166 if (DBGBIT(56, 2)) {
6167 dumpfgraph();
6168 dumploops();
6169 dumpnmes();
6170 dumpdefs();
6171 dumpuses();
6172 }
6173 #endif
6174 /* unlink DEF_NEXT list from NME, link into a list based on STD */
6175 NEW(stddeflist, int, astb.std.stg_size);
6176 BZERO(stddeflist, int, astb.std.stg_size);
6177 NEW(loopdeflist, int, opt.nloops + 1);
6178 BZERO(loopdeflist, int, opt.nloops + 1);
6179 NEW(syminfo, syminfostruct, stb.stg_avail);
6180 BZERO(syminfo, syminfostruct, stb.stg_avail);
6181 for (nm = 1; nm < nmeb.stg_avail; ++nm) {
6182 int d, nextd;
6183 for (d = NME_DEF(nm); d; d = nextd) {
6184 int std;
6185 nextd = DEF_NEXT(d);
6186 std = DEF_STD(d);
6187 DEF_NEXT(d) = stddeflist[std];
6188 stddeflist[std] = d;
6189 }
6190 }
6191 /* mark those section descriptor arrays that are
6192 * section descriptors for user symbols */
6193 for (s = stb.firstusym; s < stb.stg_avail; ++s) {
6194 switch (STYPEG(s)) {
6195 case ST_ARRAY:
6196 case ST_DESCRIPTOR:
6197 case ST_STRUCT:
6198 case ST_MEMBER:
6199 if (!CCSYMG(s) && !HCCSYMG(s)) {
6200 int sdsc;
6201 sdsc = SDSCG(s);
6202 if (sdsc) {
6203 PUREP(sdsc, 1);
6204 }
6205 }
6206 break;
6207 default:;
6208 }
6209 }
6210 for (l = LP_CHILD(0); l; l = LP_SIBLING(l)) {
6211 sfloat(l);
6212 }
6213
6214 FREE(syminfo);
6215 FREE(loopdeflist);
6216 FREE(stddeflist);
6217 optshrd_fend();
6218 induction_end();
6219 optshrd_end();
6220 flg.x[6] = savex; /* disable flow graph changes here */
6221 } /* sectfloat */
6222