1 /*
2 * Copyright (c) 1995-2018, 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 Rewrite subscript vectors for lhs and rhs, etc.
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 "gramtk.h"
32 #include "comm.h"
33 #include "extern.h"
34 #include "hpfutl.h"
35 #include "commopt.h"
36 #include "rte.h"
37
38 static int reference_for_temp_lhs_indirection(int, int, int);
39 static int newforall_list(int arr, int forall);
40 static int forall_semantic(int std);
41 static void forall_with_mask(int std);
42 static void forall_loop_interchange(int std);
43 static void forall_with_shape(int std);
44 static void forall_list_call(int std);
45 static void forall_bound_dependence(int std);
46 static void forall_bound_dependence_fix(int prevstd, int nextstd);
47 static LOGICAL is_mask_for_rhs(int std, int ast);
48 static LOGICAL is_legal_lhs_for_mask(int, int);
49 static int make_dos(int std);
50 static void make_enddos(int n, int std);
51 static void scalar_lhs_dependency(int std);
52 static void scatter_dependency(int std);
53 static void scatter_dependency_assumsz(int std);
54 static int take_out_assumsz_array(int expr, int std, int sptr);
55 static LOGICAL is_one_idx_for_dim(int, int);
56 static LOGICAL is_sequentialize_pure(int std);
57 static LOGICAL is_ugly_pure(int ast);
58 static LOGICAL find_scatter_rhs(int expr, int forall, int *rhs);
59 static LOGICAL is_all_idx_in_subscript(int list, int a);
60
61 static LOGICAL ptr_subs_olap(int, int);
62 static LOGICAL can_ptr_olap(int, int);
63
64 /** \brief This routine rewrites foralls
65
66 1. forall with shape sec as A(i,:)
67 2. forall with dependency,
68 3. forall with distributed indirection array at rhs.
69 */
70 void
rewrite_forall(void)71 rewrite_forall(void)
72 {
73 int std, stdnext;
74 int ast;
75 int parallel_depth, task_depth;
76
77 parallel_depth = 0;
78 task_depth = 0;
79 for (std = STD_NEXT(0); std; std = stdnext) {
80 stdnext = STD_NEXT(std);
81 gbl.lineno = STD_LINENO(std);
82 arg_gbl.std = std;
83 arg_gbl.lhs = 0;
84 arg_gbl.used = FALSE;
85 arg_gbl.inforall = FALSE;
86 ast = STD_AST(std);
87 switch (A_TYPEG(ast)) {
88 case A_MP_PARALLEL:
89 ++parallel_depth;
90 /*symutl.sc = SC_PRIVATE;*/
91 set_descriptor_sc(SC_PRIVATE);
92 break;
93 case A_MP_ENDPARALLEL:
94 --parallel_depth;
95 if (parallel_depth == 0 && task_depth == 0) {
96 /*symutl.sc = SC_LOCAL;*/
97 set_descriptor_sc(SC_LOCAL);
98 }
99 break;
100 case A_MP_TASKLOOPREG:
101 case A_MP_ETASKLOOPREG:
102 break;
103 case A_MP_TASK:
104 case A_MP_TASKLOOP:
105 ++task_depth;
106 set_descriptor_sc(SC_PRIVATE);
107 break;
108 case A_MP_ENDTASK:
109 --task_depth;
110 if (parallel_depth == 0 && task_depth == 0) {
111 set_descriptor_sc(SC_LOCAL);
112 }
113 break;
114 case A_FORALL:
115 process_forall(std);
116 break;
117 }
118 }
119 }
120
121 static int process_forall_recursion = 0;
122
123 int
process_forall(int std)124 process_forall(int std)
125 {
126 int forall, asn, lhs, rhs, save_process_forall_recursion;
127 int prevstd, nextstd;
128
129 forall = STD_AST(std);
130 assert(A_TYPEG(forall) == A_FORALL, "process_forall: not a FORALL", forall,
131 3);
132 asn = A_IFSTMTG(forall);
133 if (A_TYPEG(asn) != A_ASN) {
134 sequentialize(std, STD_AST(std), FALSE);
135 return 0;
136 }
137 lhs = A_DESTG(asn);
138 rhs = A_SRCG(asn);
139 if (A_TYPEG(lhs) == A_MEM && !A_SHAPEG(lhs) && A_TYPEG(rhs) == A_ID &&
140 HCCSYMG(A_SPTRG(rhs)) && !A_SRCG(forall)) {
141 sequentialize(std, STD_AST(std), FALSE);
142 return 0;
143 }
144 /* sequentialize string forall */
145 if (A_TYPEG(lhs) == A_SUBSTR) {
146 /*scalarize(std,STD_AST(std),FALSE);*/
147 sequentialize(std, STD_AST(std), FALSE);
148 return 0;
149 }
150 rhs = A_SRCG(asn);
151 if (A_TYPEG(rhs) == A_FUNC && SEQUENTG(A_SPTRG(A_LOPG(rhs)))) {
152 sequentialize(std, STD_AST(std), FALSE);
153 return 0;
154 }
155 save_process_forall_recursion = process_forall_recursion;
156 process_forall_recursion = 1;
157 (void)forall_semantic(std);
158 if (!save_process_forall_recursion) {
159 forall_bound_dependence(std);
160 prevstd = STD_PREV(std);
161 nextstd = STD_NEXT(std);
162 }
163 forall_loop_interchange(std);
164 forall_with_shape(std);
165 /* forall_list_normalize(std); */
166 forall_with_mask(std);
167 forall_lhs_indirection(std);
168 /* forall_rhs_indirection(std); */
169 if (!save_process_forall_recursion) {
170 forall_bound_dependence_fix(prevstd, nextstd);
171 }
172 process_forall_recursion = save_process_forall_recursion;
173 return 0;
174 }
175
176 static int
forall_semantic(int std)177 forall_semantic(int std)
178 {
179 int forall;
180 int asn;
181 int list;
182 int first_lhs;
183 int j;
184
185 forall = STD_AST(std);
186 assert(A_TYPEG(forall) == A_FORALL, "forall_semantic: not a FORALL", forall,
187 3);
188 list = A_LISTG(forall);
189 asn = A_IFSTMTG(forall);
190 if (A_TYPEG(asn) != A_ASN)
191 return 0;
192
193 first_lhs = A_DESTG(asn);
194 for (j = list; j != 0; j = ASTLI_NEXT(j)) {
195 LOGICAL found;
196 int isptr, lhs;
197 isptr = ASTLI_SPTR(j);
198 lhs = first_lhs;
199 found = FALSE;
200 while (!found && A_TYPEG(lhs) != A_ID) {
201 if (A_TYPEG(lhs) == A_MEM) {
202 lhs = A_PARENTG(lhs);
203 } else if (A_TYPEG(lhs) == A_SUBSCR) {
204 int asd;
205 int i, ndim;
206 asd = A_ASDG(lhs);
207 ndim = ASD_NDIM(asd);
208 for (i = 0; i < ndim; i++)
209 if (is_name_in_expr(ASD_SUBS(asd, i), isptr))
210 found = TRUE;
211 /* see if there's a subscripted parent */
212 lhs = A_LOPG(lhs);
213
214 } else if (A_TYPEG(lhs) == A_SUBSTR) {
215 if (is_name_in_expr(A_RIGHTG(lhs), isptr) ||
216 is_name_in_expr(A_LEFTG(lhs), isptr)) {
217 scalarize(std, STD_AST(std), FALSE);
218 if (A_TYPEG(STD_AST(std)) == A_COMMENT)
219 return 1;
220 found = TRUE;
221 }
222 lhs = A_LOPG(lhs);
223 } else {
224 interr("forall_semantic: LHS not subscr or member", lhs, 3);
225 return 0;
226 }
227 }
228 if (!found && (A_TYPEG(lhs) != A_ID || !HCCSYMG(A_SPTRG(lhs)))) {
229 error(487, 4, STD_LINENO(std), SYMNAME(isptr), CNULL);
230 /* NOTREACHED */
231 return 0;
232 }
233 }
234
235 return 0;
236 }
237
238 int
assign_scalar(int std,int ast)239 assign_scalar(int std, int ast)
240 {
241 int sptr;
242 int asn, dest;
243
244 sptr = sym_get_scalar("ii", "s", A_DTYPEG(ast));
245 asn = mk_stmt(A_ASN, 0);
246 dest = mk_id(sptr);
247 A_DESTP(asn, dest);
248 A_SRCP(asn, ast);
249 add_stmt_before(asn, std);
250 return mk_id(sptr);
251 }
252
253 static void
forall_list_call(int std)254 forall_list_call(int std)
255 {
256 int forall;
257 int asn;
258 int list;
259 int j;
260 int isptr;
261 int triple;
262 int l, u, s;
263
264 forall = STD_AST(std);
265 list = A_LISTG(forall);
266 for (j = list; j != 0; j = ASTLI_NEXT(j)) {
267 triple = ASTLI_TRIPLE(j);
268 l = A_LBDG(triple);
269 u = A_UPBDG(triple);
270 s = A_STRIDEG(triple);
271 if (l && contains_call(l))
272 l = assign_scalar(std, l);
273 if (u && contains_call(u))
274 u = assign_scalar(std, u);
275 if (s && contains_call(s))
276 u = assign_scalar(std, s);
277 triple = mk_triple(l, u, s);
278 ASTLI_TRIPLE(j) = triple;
279 }
280 }
281
282 static void
forall_with_mask(int std)283 forall_with_mask(int std)
284 {
285
286 int forall;
287 int asn;
288 int lhs;
289 int src;
290 int temp_ast, sptr;
291 int newforall, newlist;
292 int newasn;
293 int tempast;
294 int asd;
295 int subs[MAXDIMS];
296 int ndim;
297 int i;
298 int mask;
299 int stdf;
300 int align;
301 int list;
302
303 forall = STD_AST(std);
304 asn = A_IFSTMTG(forall);
305 src = A_SRCG(asn);
306 lhs = A_DESTG(asn);
307 mask = A_IFEXPRG(forall);
308 if (!mask)
309 return;
310 if (A_TYPEG(mask) == A_SUBSCR)
311 return;
312 if (!is_legal_lhs_for_mask(lhs, forall))
313 return;
314 if (!is_indirection_in_it(lhs) && !is_mask_for_rhs(std, src))
315 return;
316
317 list = A_LISTG(forall);
318 if (is_multiple_idx_in_list(list))
319 return;
320 if (!is_one_idx_for_dim(lhs, list))
321 return;
322
323 align = ALIGNG(left_array_symbol(lhs));
324 if (!align)
325 return;
326 /* split forall */
327 sptr = get_temp_forall(forall, lhs, std, std, DT_LOG, 0);
328 temp_ast = reference_for_temp_lhs_indirection(sptr, lhs, forall);
329 newforall = mk_stmt(A_FORALL, 0);
330 A_LISTP(newforall, A_LISTG(forall));
331 A_SRCP(newforall, A_SRCG(forall));
332 newasn = mk_stmt(A_ASN, 0);
333 A_DESTP(newasn, temp_ast);
334 A_SRCP(newasn, mask);
335 A_IFSTMTP(newforall, newasn);
336 A_IFEXPRP(newforall, 0);
337 stdf = add_stmt_before(newforall, std);
338 process_forall(stdf);
339
340 A_IFEXPRP(forall, temp_ast);
341 STD_AST(std) = forall;
342 }
343
344 static LOGICAL
is_mask_for_rhs(int std,int ast)345 is_mask_for_rhs(int std, int ast)
346 {
347 int shape;
348 int l, r;
349 int tmp_array;
350 int dtype;
351 int args;
352 int asd;
353 int numdim;
354 int i;
355 int subs[MAXDIMS];
356 int astnew;
357 int temp_sclr;
358 int asn;
359 int forall;
360 int lhs;
361
362 if (ast == 0)
363 return 0;
364 shape = A_SHAPEG(ast);
365 dtype = A_DTYPEG(ast);
366 switch (A_TYPEG(ast)) {
367 case A_CMPLXC:
368 case A_CNST:
369 case A_ID:
370 case A_SUBSTR:
371 case A_MEM:
372 return FALSE;
373 case A_BINOP:
374 l = is_mask_for_rhs(std, A_LOPG(ast));
375 r = is_mask_for_rhs(std, A_ROPG(ast));
376 return (l || r);
377 case A_UNOP:
378 l = is_mask_for_rhs(std, A_LOPG(ast));
379 return l;
380 case A_PAREN:
381 case A_CONV:
382 l = is_mask_for_rhs(std, A_LOPG(ast));
383 return l;
384 case A_SUBSCR:
385 forall = STD_AST(std);
386 asn = A_IFSTMTG(forall);
387 lhs = A_DESTG(asn);
388 if (is_indirection_in_it(ast) && is_legal_rhs(lhs, ast, forall))
389 return TRUE;
390 return FALSE;
391 case A_TRIPLE:
392 l = is_mask_for_rhs(std, A_LBDG(ast));
393 r = is_mask_for_rhs(std, A_UPBDG(ast));
394 i = is_mask_for_rhs(std, A_STRIDEG(ast));
395 return (l || r || i);
396 case A_INTR:
397 case A_FUNC:
398 case A_LABEL:
399 default:
400 return FALSE;
401 }
402 }
403
404 /* This is routine does some transformations if lhs array has an indirection
405 * subscript. There are two transformations.
406 * 1-) Bring indirection array section into form which will be acceptable
407 * by pghpf_scatter such as A(V(V(i))) is not acceptable.
408 * - no indirection of indirection
409 * - it has to be one dimension vector
410 * 2-) assign rhs of original assignment into TMP such that
411 * TMP has the same shape as lhs and the same distribution as lhs.
412 * optz.: if rhs has one array and rhs does not have indirection
413 * don't create TMP for rhs.
414 * For example:
415 * forall(i=,j=) A(V(i),j) = rhs + ..
416 * will be
417 * forall(i=,j=) TMP(i,j) = rhs + ...
418 * forall(i=,j=) A(V(i),j) = TMP(i,j)
419 */
420
421 void
forall_lhs_indirection(int std)422 forall_lhs_indirection(int std)
423 {
424 int forall;
425 int asn;
426 int lhs;
427 int src;
428 int temp_ast, sptr;
429 int newforall, newlist;
430 int newasn;
431 int tempast;
432 int asd;
433 int subs[MAXDIMS];
434 int ndim;
435 int i;
436 int optype;
437 int align;
438 int stdf;
439 int list;
440 int home;
441
442 scalar_lhs_dependency(std);
443 scatter_dependency(std);
444 forall = STD_AST(std);
445 list = A_LISTG(forall);
446 asn = A_IFSTMTG(forall);
447 src = A_SRCG(asn);
448 lhs = A_DESTG(asn);
449 align = ALIGNG(left_array_symbol(lhs));
450 if (!align)
451 return;
452 /* if(!is_indirection_in_it(lhs)) return; */
453 if (!is_vector_indirection_in_it(lhs, list))
454 return;
455 if (!is_legal_lhs(lhs, forall))
456 return;
457 if (is_duplicate(lhs, list))
458 return;
459 if (!is_one_idx_for_dim(lhs, list))
460 return;
461 if (is_multiple_idx_in_list(list))
462 return;
463 /* if there is mask find a home array from rhs */
464 home = 0;
465 if (A_IFEXPRG(forall)) {
466 if (!find_scatter_rhs(src, forall, &home))
467 return;
468 } else
469 home = lhs;
470
471 optype = -1;
472 if (!scatter_class(std)) {
473 /* split forall */
474 sptr = get_temp_forall(forall, home, std, std, 0, left_subscript_ast(home));
475 temp_ast = reference_for_temp_lhs_indirection(sptr, home, forall);
476 newforall = mk_stmt(A_FORALL, 0);
477 A_LISTP(newforall, A_LISTG(forall));
478 A_IFEXPRP(newforall, A_IFEXPRG(forall));
479 A_SRCP(newforall, A_SRCG(forall));
480
481 newasn = mk_stmt(A_ASN, 0);
482 A_DESTP(newasn, temp_ast);
483 A_SRCP(newasn, src);
484 A_IFSTMTP(newforall, newasn);
485 stdf = add_stmt_before(newforall, std);
486 process_forall(stdf);
487 A_SRCP(asn, temp_ast);
488 }
489
490 A_DESTP(asn, lhs);
491 A_IFSTMTP(forall, asn);
492 STD_AST(std) = forall;
493 }
494
495 /* This routine checks is whether lhs is in parallizibale form:
496 * We can distribute iteration only lhs subscript are:
497 * - forall index,
498 * - scalar,
499 * - vector subscript,
500 * - no indirection of indirection.
501 * - can be legal array section.
502 */
503
504 LOGICAL
is_legal_lhs(int a,int forall)505 is_legal_lhs(int a, int forall)
506 {
507 int list;
508 int i;
509 int ndim;
510 int asd;
511 ADSC *ad;
512 int lb;
513 int sptr;
514
515 list = A_LISTG(forall);
516 do {
517 if (A_TYPEG(a) == A_MEM) {
518 a = A_PARENTG(a);
519 } else if (A_TYPEG(a) == A_SUBSCR) {
520 sptr = sptr_of_subscript(a);
521 assert(is_array_type(sptr), "is_legal_lhs: must be array", sptr, 4);
522 asd = A_ASDG(a);
523 ndim = ASD_NDIM(asd);
524 for (i = 0; i < ndim; i++) {
525 if (!is_scalar(ASD_SUBS(asd, i), list) &&
526 !is_idx(ASD_SUBS(asd, i), list) &&
527 !is_vector_subscript(ASD_SUBS(asd, i), list))
528 return FALSE;
529 /* don't let LBOUND(A, i) != 1, if there is indirection
530 * This will be optimized later, */
531 if (is_vector_subscript(ASD_SUBS(asd, i), list)) {
532 ad = AD_DPTR(DTYPEG(sptr));
533 lb = AD_LWBD(ad, i);
534 if (lb != 0 && lb != astb.i1)
535 return FALSE;
536 }
537 }
538 a = A_LOPG(a);
539 } else {
540 interr("is_legal_lhs: must be array or member", a, 4);
541 }
542 } while (A_TYPEG(a) != A_ID);
543 return TRUE;
544 }
545
546 static LOGICAL
is_legal_lhs_for_mask(int a,int forall)547 is_legal_lhs_for_mask(int a, int forall)
548 {
549 int ast, list;
550
551 list = A_LISTG(forall);
552 ast = a;
553 do {
554 if (A_TYPEG(ast) == A_MEM) {
555 ast = A_PARENTG(ast);
556 } else if (A_TYPEG(ast) == A_SUBSCR) {
557 int i;
558 int ndim;
559 int asd;
560 asd = A_ASDG(ast);
561 ndim = ASD_NDIM(asd);
562 for (i = 0; i < ndim; ++i) {
563 if (!is_scalar(ASD_SUBS(asd, i), list) &&
564 !is_idx(ASD_SUBS(asd, i), list) &&
565 !is_vector_subscript(ASD_SUBS(asd, i), list))
566 return FALSE;
567 }
568 ast = A_LOPG(ast);
569 } else {
570 interr("is_legal_lhs_for_mask: not subscr or member", A_TYPEG(ast), 3);
571 }
572 } while (A_TYPEG(ast) != A_ID);
573 if (is_duplicate(a, list))
574 return FALSE;
575 return TRUE;
576 }
577
578 /* don't allow forall(i=1:n,j=istart(i):istop(i) */
579 LOGICAL
is_multiple_idx_in_list(int list)580 is_multiple_idx_in_list(int list)
581 {
582 int triplet, triplet1;
583 int list0, list1;
584 int isptr;
585
586 list0 = list;
587 for (; list; list = ASTLI_NEXT(list)) {
588 triplet = ASTLI_TRIPLE(list);
589 isptr = ASTLI_SPTR(list);
590 list1 = list0;
591 for (; list1; list1 = ASTLI_NEXT(list1)) {
592 triplet1 = ASTLI_TRIPLE(list1);
593 if (is_name_in_expr(triplet1, isptr))
594 return TRUE;
595 }
596 }
597 return FALSE;
598 }
599
600 /* This will return FALSE cases like u(nodes(i,j))
601 * Each dimension should have less than equal 1 idx
602 * Othervise return false.
603 */
604 static LOGICAL
is_one_idx_for_dim(int a,int list)605 is_one_idx_for_dim(int a, int list)
606 {
607 while (A_TYPEG(a) != A_ID) {
608 if (A_TYPEG(a) == A_MEM) {
609 a = A_PARENTG(a);
610 } else if (A_TYPEG(a) == A_SUBSCR) {
611 int i, ndim, asd;
612 asd = A_ASDG(a);
613 ndim = ASD_NDIM(asd);
614 for (i = 0; i < ndim; ++i) {
615 int astli, nidx;
616 astli = 0;
617 nidx = 0;
618 search_forall_idx(ASD_SUBS(asd, i), list, &astli, &nidx);
619 if (astli == 0)
620 continue;
621 if (nidx > 1)
622 return FALSE;
623 }
624 a = A_LOPG(a);
625 } else {
626 interr("is_one_idx_for_dim: not subscript or member", A_TYPEG(a), 3);
627 }
628 }
629 return TRUE;
630 }
631
632 LOGICAL
is_duplicate(int a,int list)633 is_duplicate(int a, int list)
634 {
635 for (; list > 0; list = ASTLI_NEXT(list)) {
636 int sptr, found, ast;
637 sptr = ASTLI_SPTR(list);
638 found = 0;
639 ast = a;
640 while (A_TYPEG(ast) != A_ID) {
641 if (A_TYPEG(ast) == A_MEM) {
642 ast = A_PARENTG(ast);
643 } else if (A_TYPEG(ast) == A_SUBSCR) {
644 int i, k;
645 int ndim;
646 int asd;
647
648 asd = A_ASDG(ast);
649 ndim = ASD_NDIM(asd);
650 for (i = 0; i < ndim; ++i) {
651 if (is_name_in_expr(ASD_SUBS(asd, i), sptr))
652 ++found;
653 }
654 ast = A_LOPG(ast);
655 } else {
656 interr("is_duplicate: not member or subscript", A_TYPEG(ast), 3);
657 return FALSE;
658 }
659 }
660 if (found > 1)
661 return TRUE;
662 }
663 return FALSE;
664 }
665
666 LOGICAL
is_scalar(int a,int list)667 is_scalar(int a, int list)
668 {
669 int astli;
670 int nidx;
671
672 astli = 0;
673 nidx = 0;
674 search_forall_idx(a, list, &astli, &nidx);
675 if (nidx == 0 && astli == 0)
676 return TRUE;
677 return FALSE;
678 }
679
680 LOGICAL
is_idx(int a,int list)681 is_idx(int a, int list)
682 {
683 int astli;
684 int nidx;
685
686 astli = 0;
687 nidx = 0;
688 search_forall_idx(a, list, &astli, &nidx);
689 if (nidx == 1 && astli) {
690 if (mk_id(ASTLI_SPTR(astli)) == a)
691 return TRUE;
692 }
693 return FALSE;
694 }
695
696 static LOGICAL
is_triplet(int a,int list)697 is_triplet(int a, int list)
698 {
699 int astli;
700 int nidx;
701 int base, stride;
702
703 astli = 0;
704 nidx = 0;
705 search_idx(a, list, &astli, &base, &stride);
706 if (base && stride && astli)
707 return TRUE;
708 return FALSE;
709 }
710 LOGICAL
is_vector_subscript(int a,int list)711 is_vector_subscript(int a, int list)
712 {
713 int astli;
714 int nidx;
715 int count;
716 int i;
717 int asd;
718 int ndim;
719
720 if (A_TYPEG(a) != A_SUBSCR)
721 return FALSE;
722 asd = A_ASDG(a);
723 ndim = ASD_NDIM(asd);
724 count = 0;
725 for (i = 0; i < ndim; i++) {
726 if (!is_scalar(ASD_SUBS(asd, i), list) && !(is_idx(ASD_SUBS(asd, i), list)))
727 return FALSE;
728 }
729
730 if (is_scalar(a, list))
731 return FALSE;
732 return TRUE;
733 }
734
735 /* order2: used for pghpf_permute_section */
736 /* no: number of elements returned in order2 */
737 LOGICAL
is_ordered(int lhs,int rhs,int list,int order2[],int * no)738 is_ordered(int lhs, int rhs, int list, int order2[], int *no)
739 {
740 int asd, ndim;
741 int i, j, r, l;
742 int count, count1;
743 int order[MAXDIMS], order1[MAXDIMS];
744 LOGICAL found;
745 int astli, nidx;
746
747 /* rhs */
748 count = 0;
749 for (r = rhs; A_TYPEG(r) != A_ID;) {
750 switch (A_TYPEG(r)) {
751 case A_MEM:
752 r = A_PARENTG(r);
753 break;
754 case A_SUBSCR:
755 asd = A_ASDG(r);
756 ndim = ASD_NDIM(asd);
757 for (j = 0; j < ndim; ++j) {
758 astli = 0;
759 nidx = 0;
760 search_forall_idx(ASD_SUBS(asd, j), list, &astli, &nidx);
761 if (nidx == 1 && astli) {
762 assert(count < MAXDIMS, "is_ordered: dimensions > MAXDIMS", count, 4);
763 order[count] = ASTLI_SPTR(astli);
764 ++count;
765 }
766 }
767 r = A_LOPG(r);
768 break;
769 default:
770 interr("LHS is not subscript, id, or member", r, 4);
771 }
772 }
773
774 /* lhs */
775 count1 = 0;
776 for (l = lhs; A_TYPEG(l) != A_ID;) {
777 switch (A_TYPEG(l)) {
778 case A_MEM:
779 l = A_PARENTG(l);
780 break;
781 case A_SUBSCR:
782 asd = A_ASDG(l);
783 ndim = ASD_NDIM(asd);
784 for (j = 0; j < ndim; ++j) {
785 astli = 0;
786 nidx = 0;
787 search_forall_idx(ASD_SUBS(asd, j), list, &astli, &nidx);
788 if (nidx == 1 && astli) {
789 assert(count1 < MAXDIMS, "is_ordered: dimensions > MAXDIMS", count1,
790 4);
791 order1[count1] = ASTLI_SPTR(astli);
792 count1++;
793 }
794 }
795 l = A_LOPG(l);
796 }
797 }
798
799 for (j = 0; j < count1; ++j)
800 for (i = 0; i < count; i++)
801 if (order1[j] == order[i])
802 order2[j] = i;
803 *no = count1;
804
805 /* no transpose accesses between lhs and rhs */
806 /* Algorithm:
807 * lhs(i,j,k) = rhs(k,i),
808 * start with rhs indices,
809 * kill lhs indices upto rhs indices you are looking for.
810 * if you can not find rhs, this means you are ready to kill it
811 * that means it appears before previous rhs index.
812 * that is a transpose access.
813 */
814
815 for (i = 0; i < count; i++) {
816 found = FALSE;
817 for (j = 0; j < count1; j++) {
818 if (order[i] != order1[j]) {
819 order1[j] = 0;
820 } else {
821 order1[j] = 0;
822 found = TRUE;
823 break;
824 }
825 }
826 if (!found)
827 return FALSE;
828 }
829 *no = 0;
830 return TRUE;
831 }
832
833 /* This routine finds out the dimension of sptr.
834 * It takes subscript a(f(i),5,f(j)). It eliminates scalar dimension.
835 * It makes an ast for reference sptr.
836 * a(f(i),5,f(j)) --> sptr(f(i),f(j))
837 */
838
839 static int
reference_for_temp_lhs_indirection(int sptr,int a,int forall)840 reference_for_temp_lhs_indirection(int sptr, int a, int forall)
841 {
842 int subs[MAXDIMS];
843 int list;
844 int i, j;
845 int asd;
846 int ndim;
847 int astnew;
848 int astli;
849 int nidx;
850 int index_var;
851 int triple;
852 ADSC *ad;
853 int l, u, s;
854 int lb, t;
855
856 list = A_LISTG(forall);
857 asd = A_ASDG(a);
858 ndim = ASD_NDIM(asd);
859 j = 0;
860 /* array will be referenced after communication as follows */
861 for (i = 0; i < ndim; i++) {
862 astli = 0;
863 nidx = 0;
864 search_forall_idx(ASD_SUBS(asd, i), list, &astli, &nidx);
865 if (nidx == 1 && astli) {
866 index_var = ASTLI_SPTR(astli);
867 subs[j] = mk_id(index_var);
868 /* normalize astli according to new tmp*/
869 /* integer ind(6); integer A(3,6); tmp for A(ind(3:6),3) */
870 if (is_vector_subscript(ASD_SUBS(asd, i), list)) {
871 triple = ASTLI_TRIPLE(astli);
872 l = A_LBDG(triple);
873 u = A_UPBDG(triple);
874 s = A_STRIDEG(triple);
875 ad = AD_DPTR(DTYPEG(sptr));
876 lb = AD_LWBD(ad, j);
877 if (!lb)
878 lb = astb.i1;
879 if (!s)
880 s = astb.i1;
881 t = opt_binop(OP_SUB, subs[j], l, DT_INT);
882 t = opt_binop(OP_DIV, t, s, DT_INT);
883 t = opt_binop(OP_ADD, t, lb, DT_INT);
884 subs[j] = t;
885 }
886 j++;
887 }
888 }
889 assert(j == rank_of_sym(sptr), "reference_for_temp: rank mismatched", sptr,
890 4);
891 astnew = mk_subscr(mk_id(sptr), subs, j, DDTG(DTYPEG(sptr)));
892 return astnew;
893 }
894
895 /* ast to search */
896 /* list = pointer of forall indices */
897 void
search_forall_idx(int ast,int list,int * astli,int * nidx)898 search_forall_idx(int ast, int list, int *astli, int *nidx)
899 {
900 int argt, n, i;
901 int asd;
902
903 if (!ast)
904 return;
905 switch (A_TYPEG(ast)) {
906 case A_BINOP:
907 search_forall_idx(A_LOPG(ast), list, astli, nidx);
908 search_forall_idx(A_ROPG(ast), list, astli, nidx);
909 break;
910 case A_CONV:
911 case A_UNOP:
912 case A_PAREN:
913 search_forall_idx(A_LOPG(ast), list, astli, nidx);
914 break;
915 case A_CMPLXC:
916 case A_CNST:
917 break;
918
919 case A_INTR:
920 case A_FUNC:
921 argt = A_ARGSG(ast);
922 n = A_ARGCNTG(ast);
923 for (i = 0; i < n; ++i)
924 search_forall_idx(ARGT_ARG(argt, i), list, astli, nidx);
925 break;
926 case A_TRIPLE:
927 search_forall_idx(A_LBDG(ast), list, astli, nidx);
928 search_forall_idx(A_UPBDG(ast), list, astli, nidx);
929 if (A_STRIDEG(ast))
930 search_forall_idx(A_STRIDEG(ast), list, astli, nidx);
931 break;
932 case A_SUBSCR:
933 asd = A_ASDG(ast);
934 n = ASD_NDIM(asd);
935 for (i = 0; i < n; ++i)
936 search_forall_idx(ASD_SUBS(asd, i), list, astli, nidx);
937 search_forall_idx(A_LOPG(ast), list, astli, nidx);
938 break;
939 case A_SUBSTR:
940 search_forall_idx(A_LEFTG(ast), list, astli, nidx);
941 search_forall_idx(A_RIGHTG(ast), list, astli, nidx);
942 search_forall_idx(A_LOPG(ast), list, astli, nidx);
943 break;
944 case A_MEM:
945 search_forall_idx(A_PARENTG(ast), list, astli, nidx);
946 break;
947 case A_ID:
948 for (i = list; i != 0; i = ASTLI_NEXT(i)) {
949 if (A_SPTRG(ast) == ASTLI_SPTR(i)) {
950 if (*astli != i) {
951 *astli = i;
952 (*nidx)++;
953 }
954 }
955 }
956 break;
957 default:
958 interr("search_forall_idx: bad ast type", A_TYPEG(ast), 3);
959 break;
960 }
961 }
962
963 LOGICAL
is_legal_rhs(int lhs,int rhs,int forall)964 is_legal_rhs(int lhs, int rhs, int forall)
965 {
966 int list;
967 int i;
968 int ndim;
969 int asd;
970 int order2[MAXDIMS];
971 int no;
972
973 list = A_LISTG(forall);
974 asd = A_ASDG(rhs);
975 ndim = ASD_NDIM(asd);
976 for (i = 0; i < ndim; i++) {
977 if (!is_scalar(ASD_SUBS(asd, i), list) &&
978 !is_triplet(ASD_SUBS(asd, i), list) &&
979 !is_vector_subscript(ASD_SUBS(asd, i), list))
980 return FALSE;
981 }
982 /*
983 if (is_duplicate(rhs, list)) return FALSE;
984 if (!is_ordered(lhs, rhs, list, order2, &no)) return FALSE;
985 */
986 return TRUE;
987 }
988
989 /* This routine takes an array and forall,
990 * It returns a list which only has forall index appears
991 * in the array subscripts. A(i), forall(i=,j=), return i=..
992 */
993 static int
newforall_list(int arr,int forall)994 newforall_list(int arr, int forall)
995 {
996 int astli, base, stride;
997 int list;
998 int numdim;
999 int asd;
1000 int i;
1001 int newlist;
1002
1003 list = A_LISTG(forall);
1004 asd = A_ASDG(arr);
1005 numdim = ASD_NDIM(asd);
1006 start_astli();
1007 for (i = 0; i < numdim; ++i) {
1008 astli = 0;
1009 search_idx(ASD_SUBS(asd, i), list, &astli, &base, &stride);
1010 if (astli) {
1011 newlist = add_astli();
1012 ASTLI_SPTR(newlist) = ASTLI_SPTR(astli);
1013 ASTLI_TRIPLE(newlist) = ASTLI_TRIPLE(astli);
1014 }
1015 }
1016 return ASTLI_HEAD;
1017 }
1018
1019 static void
forall_loop_interchange(int std)1020 forall_loop_interchange(int std)
1021 {
1022 int forall, list;
1023 int asn, lhs;
1024
1025 forall = STD_AST(std);
1026 list = A_LISTG(forall);
1027 if (is_multiple_idx_in_list(list))
1028 return;
1029
1030 asn = A_IFSTMTG(forall);
1031 lhs = A_DESTG(asn);
1032 if (A_SHAPEG(lhs))
1033 return;
1034 start_astli();
1035 do {
1036 if (A_TYPEG(lhs) == A_MEM) {
1037 lhs = A_PARENTG(lhs);
1038 } else if (A_TYPEG(lhs) == A_SUBSCR) {
1039 int asd, ndim, i;
1040 asd = A_ASDG(lhs);
1041 ndim = ASD_NDIM(asd);
1042 for (i = ndim - 1; i >= 0; --i) {
1043 int astli, base, stride;
1044 /* must look like: c2 +/- c1 * i where i is an index. */
1045 /* search for an index & do the recursion */
1046 astli = 0;
1047 search_idx(ASD_SUBS(asd, i), list, &astli, &base, &stride);
1048 if (base == 0) {
1049 /* hopeless */
1050 return;
1051 }
1052 if (astli) {
1053 int newlist;
1054 list = delete_astli(list, astli); /* a(i,i) */
1055 newlist = add_astli();
1056 ASTLI_SPTR(newlist) = ASTLI_SPTR(astli);
1057 ASTLI_TRIPLE(newlist) = ASTLI_TRIPLE(astli);
1058 }
1059 }
1060 lhs = A_LOPG(lhs);
1061 } else if (A_TYPEG(lhs) == A_SUBSTR) {
1062 return;
1063 } else {
1064 interr("forall_loop_interchange: not member/subscript", lhs, 3);
1065 }
1066 } while (A_TYPEG(lhs) != A_ID);
1067
1068 A_LISTP(forall, ASTLI_HEAD);
1069 A_STDP(forall, std);
1070 STD_AST(std) = forall;
1071 }
1072
1073 /* this will delete astli from list */
1074 int
delete_astli(int list,int astli)1075 delete_astli(int list, int astli)
1076 {
1077 int newlist;
1078 int listp;
1079
1080 start_astli();
1081 for (listp = list; listp != 0; listp = ASTLI_NEXT(listp))
1082 if (listp != astli) {
1083 newlist = add_astli();
1084 ASTLI_SPTR(newlist) = ASTLI_SPTR(listp);
1085 ASTLI_TRIPLE(newlist) = ASTLI_TRIPLE(listp);
1086 }
1087 return ASTLI_HEAD;
1088 }
1089
1090 /* This routine changes forall whose has a sahpe.
1091 * For example, forall (j=0:my, k=0:mz) dXc(1,:,j,k) = dXc(1,:,0,0)
1092 * It uses the same routine with array assignment conversion into forall.
1093 * That is, fist change A_ASN of forall into forall
1094 * and then first add original forall indices
1095 * and then the second forall indices. This makes,
1096 * forall (j=0:my, k=0:mz, i_1=0:mz) dXc(1,i_1,j,k) = dXc(1,i_1,0,0)
1097 * OPTIMIZATION:
1098 * The above algorithm may not access the array with column major order.
1099 * The order of indices does not effect the semantic of forall but
1100 * may effect the performance in some systems.
1101 */
1102
1103 static void
forall_with_shape(int std)1104 forall_with_shape(int std)
1105 {
1106 int shape;
1107 int asn;
1108 int src, dest;
1109 int ast1, ast2;
1110 int mask;
1111 int ast;
1112 int lc;
1113 int list;
1114
1115 ast = STD_AST(std);
1116 asn = A_IFSTMTG(ast);
1117 src = A_SRCG(asn);
1118 dest = A_DESTG(asn);
1119 shape = A_SHAPEG(dest);
1120 mask = A_IFEXPRG(ast);
1121 list = A_LISTG(ast);
1122 lc = 0;
1123 for (; list; list = ASTLI_NEXT(list))
1124 lc++;
1125
1126 if (shape) {
1127 /* this is an array assignment */
1128 /* need to create a forall */
1129 int list;
1130 ast1 = make_forall(shape, dest, 0, lc);
1131 ast2 = normalize_forall(ast1, asn, 0);
1132 A_IFSTMTP(ast1, ast2);
1133 if (mask)
1134 mask = normalize_forall(ast1, mask, 0);
1135 A_IFEXPRP(ast1, mask);
1136 /* add original forall indices */
1137 list = concatenate_list(A_LISTG(ast), A_LISTG(ast1));
1138 A_LISTP(ast1, list);
1139 A_STDP(ast1, std);
1140 STD_AST(std) = ast1;
1141 A_SRCP(ast1, A_SRCG(ast));
1142 A_OPT1P(ast1, A_OPT1G(ast));
1143 A_ARRASNP(ast1, A_ARRASNG(ast));
1144 A_STARTP(ast1, A_STARTG(ast));
1145 A_NCOUNTP(ast1, A_NCOUNTG(ast));
1146 }
1147 }
1148
1149 /* this routine take two lists and concatenates them and make a new list */
1150 int
concatenate_list(int list1,int list2)1151 concatenate_list(int list1, int list2)
1152 {
1153 int listp, newlist;
1154
1155 start_astli();
1156 for (listp = list1; listp != 0; listp = ASTLI_NEXT(listp)) {
1157 newlist = add_astli();
1158 ASTLI_SPTR(newlist) = ASTLI_SPTR(listp);
1159 ASTLI_TRIPLE(newlist) = ASTLI_TRIPLE(listp);
1160 }
1161
1162 /* add new forall indices */
1163 for (listp = list2; listp != 0; listp = ASTLI_NEXT(listp)) {
1164 newlist = add_astli();
1165 ASTLI_SPTR(newlist) = ASTLI_SPTR(listp);
1166 ASTLI_TRIPLE(newlist) = ASTLI_TRIPLE(listp);
1167 }
1168 return ASTLI_HEAD;
1169 }
1170
1171 /* This routine rewrites those foralls with transformational intrinsics,
1172 * It takes intrinsic outside of forall and but inside do loop which
1173 * is constructed from forall statement.
1174 */
1175
1176 static struct {
1177 int first;
1178 int lhs;
1179 int n;
1180 int std;
1181 int pre_std;
1182 } intr_info;
1183
1184 void
rewrite_forall_pure(void)1185 rewrite_forall_pure(void)
1186 {
1187 int std, ast, asn;
1188 int stdnext, src;
1189 int newast, expr;
1190
1191 for (std = STD_NEXT(0); std; std = stdnext) {
1192 stdnext = STD_NEXT(std);
1193 gbl.lineno = STD_LINENO(std);
1194 ast = STD_AST(std);
1195 if (A_TYPEG(ast) == A_ASN)
1196 scatter_dependency_assumsz(std);
1197 if (A_TYPEG(ast) == A_FORALL) {
1198 int sclrzd;
1199 forall_list_call(std);
1200 sclrzd = forall_semantic(std);
1201 if (sclrzd) {
1202 continue;
1203 }
1204 if (A_TYPEG(A_IFSTMTG(STD_AST(std))) != A_ASN) {
1205 scalarize(std, STD_AST(std), FALSE);
1206 continue;
1207 }
1208
1209 init_ftb();
1210 forall_opt1(ast);
1211 put_forall_pcalls(std);
1212
1213 asn = A_IFSTMTG(ast);
1214 expr = A_IFEXPRG(ast);
1215 intr_info.first = 1;
1216 intr_info.lhs = A_DESTG(asn);
1217 intr_info.std = std;
1218 intr_info.pre_std = STD_PREV(std);
1219 if (is_sequentialize_pure(std)) {
1220 report_comm(std, UGLYPURE_CAUSE);
1221 scalarize(std, STD_AST(std), FALSE);
1222 }
1223 A_OPT1P(ast, 0);
1224 FREE(ftb.base);
1225 }
1226 }
1227 }
1228
1229 static LOGICAL
is_sequentialize_pure(int std)1230 is_sequentialize_pure(int std)
1231 {
1232 int forall;
1233 int asn;
1234 int dest, src;
1235 int expr;
1236 int pstd, past;
1237 int nd;
1238 int i;
1239
1240 forall = STD_AST(std);
1241 asn = A_IFSTMTG(forall);
1242 dest = A_DESTG(asn);
1243 src = A_SRCG(asn);
1244 expr = A_IFEXPRG(forall);
1245
1246 if (is_ugly_pure(src) || is_ugly_pure(dest) || is_ugly_pure(expr))
1247 return TRUE;
1248
1249 nd = A_OPT1G(forall);
1250 for (i = 0; i < FT_NPCALL(nd); i++) {
1251 pstd = glist(FT_PCALL(nd), i);
1252 STD_PURE(pstd) = FALSE;
1253 past = STD_AST(pstd);
1254 if (is_ugly_pure(past))
1255 return TRUE;
1256 }
1257 return FALSE;
1258 }
1259
1260 /*
1261 * This routine takes transformational intrinsics out of forall stmt. and
1262 * puts into do loops. func will returns a A_ASN which has transformation
1263 * intrinsic.
1264 */
1265
1266 static LOGICAL
is_ugly_pure(int ast)1267 is_ugly_pure(int ast)
1268 {
1269 int lhs;
1270 int std;
1271 int shape;
1272 LOGICAL l, r;
1273 int dtype;
1274 int asd;
1275 int numdim;
1276 int i, j;
1277 int subs[MAXDIMS];
1278 int asn;
1279 int sptr;
1280 int iface;
1281 int forall_ast;
1282 int list;
1283 LOGICAL has_vector_subs;
1284 int alloc_std;
1285 int expr;
1286 int newast;
1287 int argt, nargs;
1288 int arg;
1289
1290 if (ast == 0)
1291 return FALSE;
1292 lhs = intr_info.lhs;
1293 std = intr_info.std;
1294 shape = A_SHAPEG(ast);
1295 dtype = A_DTYPEG(ast);
1296 switch (A_TYPEG(ast)) {
1297 case A_CMPLXC:
1298 case A_CNST:
1299 case A_ID:
1300 case A_SUBSTR:
1301 case A_MEM:
1302 return FALSE;
1303 case A_BINOP:
1304 l = is_ugly_pure(A_LOPG(ast));
1305 if (l)
1306 return TRUE;
1307 r = is_ugly_pure(A_ROPG(ast));
1308 if (r)
1309 return TRUE;
1310 return FALSE;
1311 case A_UNOP:
1312 case A_PAREN:
1313 case A_CONV:
1314 l = is_ugly_pure(A_LOPG(ast));
1315 if (l)
1316 return TRUE;
1317 return FALSE;
1318 case A_SUBSCR:
1319 asd = A_ASDG(ast);
1320 numdim = ASD_NDIM(asd);
1321 assert(numdim > 0 && numdim <= MAXDIMS, "is_ugly_pure: bad numdim", ast, 4);
1322 for (i = 0; i < numdim; ++i) {
1323 l = is_ugly_pure(ASD_SUBS(asd, i));
1324 if (l)
1325 return TRUE;
1326 }
1327 return FALSE;
1328 case A_TRIPLE:
1329 l = is_ugly_pure(A_LBDG(ast));
1330 if (l)
1331 return TRUE;
1332 r = is_ugly_pure(A_UPBDG(ast));
1333 if (r)
1334 return TRUE;
1335 l = is_ugly_pure(A_STRIDEG(ast));
1336 if (l)
1337 return TRUE;
1338 return FALSE;
1339 case A_CALL:
1340 case A_INTR:
1341 case A_FUNC:
1342 sptr = procsym_of_ast(A_LOPG(ast));
1343 if (A_TYPEG(ast) == A_INTR && INKINDG(sptr) == IK_ELEMENTAL) {
1344 argt = A_ARGSG(ast);
1345 nargs = A_ARGCNTG(ast);
1346 for (i = 0; i < nargs; ++i) {
1347 l = is_ugly_pure(ARGT_ARG(argt, i));
1348 if (l)
1349 return TRUE;
1350 }
1351 return FALSE;
1352 }
1353 proc_arginfo(sptr, NULL, NULL, &iface);
1354 if (A_TYPEG(ast) == A_FUNC && iface && is_impure(iface))
1355 error(488, ERR_Severe, STD_LINENO(std), "subprogram call in FORALL",
1356 SYMNAME(sptr));
1357
1358 argt = A_ARGSG(ast);
1359 nargs = A_ARGCNTG(ast);
1360 for (i = 0; i < nargs; ++i) {
1361 arg = ARGT_ARG(argt, i);
1362 l = is_ugly_pure(arg);
1363 if (l)
1364 return TRUE;
1365
1366 shape = A_SHAPEG(arg);
1367 /* does not like pure(A(1:n) + b(1:n)) */
1368 if (shape) {
1369 if (A_TYPEG(arg) != A_ID && A_TYPEG(arg) != A_SUBSCR &&
1370 A_TYPEG(arg) != A_MEM && A_TYPEG(arg) != A_INTR &&
1371 A_TYPEG(arg) != A_FUNC)
1372 return TRUE;
1373 /* don't like elemental arg with shape, pure(abs(a(:,i))) */
1374 if (A_TYPEG(arg) == A_INTR &&
1375 INKINDG(A_SPTRG(A_LOPG(arg))) == IK_ELEMENTAL)
1376 return TRUE;
1377 }
1378 }
1379 return FALSE;
1380 default:
1381 interr("is_ugly_pure: unexpected ast", ast, 2);
1382 return TRUE;
1383 }
1384 }
1385
1386 static int lhsComm; /* Lhs of assignment */
1387
1388 /* This is to calculate how many DO statements have to be made
1389 from forall statement and add those before std */
1390
1391 static int
make_dos(int std)1392 make_dos(int std)
1393 {
1394 int forall;
1395 int stmt;
1396 int newast;
1397 int stdnext;
1398 int triplet_list;
1399 int triplet;
1400 int index_var;
1401 int n;
1402 int expr;
1403
1404 forall = STD_AST(std);
1405 stdnext = STD_NEXT(std);
1406
1407 n = 0;
1408 triplet_list = A_LISTG(forall);
1409 for (; triplet_list; triplet_list = ASTLI_NEXT(triplet_list)) {
1410 int dovar;
1411 n++;
1412 index_var = ASTLI_SPTR(triplet_list);
1413 triplet = ASTLI_TRIPLE(triplet_list);
1414 newast = mk_stmt(A_DO, 0);
1415 dovar = mk_id(index_var);
1416 A_DOVARP(newast, dovar);
1417 A_M1P(newast, A_LBDG(triplet));
1418 A_M2P(newast, A_UPBDG(triplet));
1419 A_M3P(newast, A_STRIDEG(triplet));
1420 A_M4P(newast, 0);
1421 add_stmt_before(newast, std);
1422 }
1423 return n;
1424 }
1425
1426 /* this is to add n enddo statements before std */
1427
1428 static void
make_enddos(int n,int std)1429 make_enddos(int n, int std)
1430 {
1431 int newast;
1432 int i;
1433
1434 for (i = 0; i < n; i++) {
1435 newast = mk_stmt(A_ENDDO, 0);
1436 add_stmt_before(newast, std);
1437 }
1438 }
1439
1440 static LOGICAL
_contains_call(int astx,LOGICAL * pflag)1441 _contains_call(int astx, LOGICAL *pflag)
1442 {
1443 int opc;
1444
1445 if (A_TYPEG(astx) == A_INTR &&
1446 INKINDG(A_SPTRG(A_LOPG(astx))) != IK_ELEMENTAL) {
1447 *pflag = TRUE;
1448 return TRUE;
1449 }
1450 return FALSE;
1451 }
1452
1453 /* Return TRUE if AST astx contains an intrinsic or external call. */
1454 LOGICAL
contains_call(int astx)1455 contains_call(int astx)
1456 {
1457 LOGICAL flag = FALSE;
1458
1459 if (A_CALLFGG(astx))
1460 return TRUE;
1461
1462 ast_visit(1, 1);
1463 ast_traverse(astx, _contains_call, NULL, &flag);
1464 ast_unvisit();
1465 return flag;
1466 }
1467
1468 static LOGICAL
appears_in_expr(int sptr,int expr)1469 appears_in_expr(int sptr, int expr)
1470 {
1471 int asd;
1472 int numdim, i;
1473 int nargs, argt;
1474
1475 switch (A_TYPEG(expr)) {
1476 case A_CMPLXC:
1477 case A_CNST:
1478 return FALSE;
1479 case A_ID:
1480 if (A_SPTRG(expr) == sptr)
1481 return TRUE;
1482 if (is_pointer_dependent(sptr, A_SPTRG(expr)))
1483 return TRUE;
1484 if (is_equivalence(sptr, A_SPTRG(expr)))
1485 return TRUE;
1486 return FALSE;
1487 case A_MEM:
1488 return appears_in_expr(sptr, A_PARENTG(expr));
1489 case A_BINOP:
1490 if (appears_in_expr(sptr, A_LOPG(expr)))
1491 return TRUE;
1492 if (appears_in_expr(sptr, A_ROPG(expr)))
1493 return TRUE;
1494 return FALSE;
1495 case A_SUBSTR:
1496 case A_UNOP:
1497 case A_PAREN:
1498 case A_CONV:
1499 return appears_in_expr(sptr, A_LOPG(expr));
1500 case A_SUBSCR:
1501 if (appears_in_expr(sptr, A_LOPG(expr)))
1502 return TRUE;
1503 asd = A_ASDG(expr);
1504 numdim = ASD_NDIM(asd);
1505 assert(numdim > 0 && numdim <= MAXDIMS, "is_dependent: bad numdim", expr,
1506 4);
1507 for (i = 0; i < numdim; ++i) {
1508 if (appears_in_expr(sptr, ASD_SUBS(asd, i)))
1509 return TRUE;
1510 }
1511 return FALSE;
1512 case A_TRIPLE:
1513 if (appears_in_expr(sptr, A_LBDG(expr)))
1514 return TRUE;
1515 if (appears_in_expr(sptr, A_UPBDG(expr)))
1516 return TRUE;
1517 if (A_STRIDEG(expr))
1518 return appears_in_expr(sptr, A_STRIDEG(expr));
1519 return FALSE;
1520 case A_INTR:
1521 case A_FUNC:
1522 nargs = A_ARGCNTG(expr);
1523 argt = A_ARGSG(expr);
1524 for (i = 0; i < nargs; ++i) {
1525 if (appears_in_expr(sptr, ARGT_ARG(argt, i)))
1526 return TRUE;
1527 }
1528 return FALSE;
1529 case A_LABEL:
1530 default:
1531 interr("appears_in_expr: unexpected ast", expr, 2);
1532 return FALSE;
1533 }
1534 } /* appears_in_expr */
1535
1536 /* recursive traversal; removes scalar subscripts (assigns to temp)
1537 * that contain no forall indices and do contain reference to 'sptr' */
1538 static int
remove_scalar_lhs_dependency(int ast,int list,int sptr,int std)1539 remove_scalar_lhs_dependency(int ast, int list, int sptr, int std)
1540 {
1541 int asd, ndim, i, lop, nlop, nast, changes, subscr[MAXDIMS];
1542 switch (A_TYPEG(ast)) {
1543 default:
1544 return ast;
1545 case A_SUBSTR:
1546 lop = A_LOPG(ast);
1547 nlop = remove_scalar_lhs_dependency(lop, list, sptr, std);
1548 if (nlop == lop)
1549 return ast;
1550 nast = mk_substr(nlop, A_LEFTG(ast), A_RIGHTG(ast), A_DTYPEG(ast));
1551 return nast;
1552 case A_MEM:
1553 lop = A_PARENTG(ast);
1554 nlop = remove_scalar_lhs_dependency(lop, list, sptr, std);
1555 if (nlop == lop)
1556 return ast;
1557 nast = mk_member(nlop, A_MEMG(ast), A_DTYPEG(ast));
1558 return nast;
1559 case A_SUBSCR:
1560 lop = A_LOPG(ast);
1561 nlop = remove_scalar_lhs_dependency(lop, list, sptr, std);
1562 changes = 0;
1563 if (nlop != lop)
1564 ++changes;
1565 asd = A_ASDG(ast);
1566 ndim = ASD_NDIM(asd);
1567 for (i = 0; i < ndim; ++i) {
1568 int ss;
1569 ss = ASD_SUBS(asd, i);
1570 subscr[i] = ss;
1571 /* is this a 'scalar' subscript? */
1572 if (A_SHAPEG(ss) == 0) {
1573 int astli, nidx;
1574 astli = nidx = 0;
1575 search_forall_idx(ss, list, &astli, &nidx);
1576 if (nidx == 0) {
1577 /* truly a scalar subscript, no FORALL indices either */
1578 if (appears_in_expr(sptr, ss)) {
1579 int temp, tempast, asn;
1580 temp = sym_get_scalar(SYMNAME(sptr), "ss", DT_INT);
1581 asn = mk_stmt(A_ASN, 0);
1582 tempast = mk_id(temp);
1583 A_DESTP(asn, tempast);
1584 A_SRCP(asn, ss);
1585 add_stmt_before(asn, std);
1586 subscr[i] = tempast;
1587 ++changes;
1588 }
1589 }
1590 }
1591 }
1592 if (changes == 0)
1593 return ast;
1594 nast = mk_subscr(nlop, subscr, ndim, A_DTYPEG(ast));
1595 return nast;
1596 }
1597 } /* remove_scalar_lhs_dependency */
1598
1599 /* This routine removes any scalar subscripts that might
1600 * depend on the LHS variable
1601 * For example,
1602 * forall(j=1:N) i(i(1,2),j) = 0
1603 * or
1604 * forall(j=1:N) i(i(1)%m(1))%m(j) = 0
1605 * will be rewritten
1606 * temp = i(1,2)
1607 * forall(j=1:N) i(temp,j) = 0
1608 * or
1609 * temp = i(1)%m(1)
1610 * forall(j=1:N) i(temp)%m(j) = 0
1611 */
1612
1613 static void
scalar_lhs_dependency(int std)1614 scalar_lhs_dependency(int std)
1615 {
1616 int forall, list, asn, lhs, sptrlhs, newlhs;
1617 forall = STD_AST(std);
1618 list = A_LISTG(forall);
1619 asn = A_IFSTMTG(forall);
1620 lhs = A_DESTG(asn);
1621 sptrlhs = sym_of_ast(lhs);
1622 newlhs = remove_scalar_lhs_dependency(lhs, list, sptrlhs, std);
1623 A_DESTP(asn, newlhs);
1624 } /* scalar_lhs_dependency */
1625
1626
1627 /* This routine is to check whether forall has scatter dependency.
1628 * Scatter dependency means that same lhs array used as subscript of lhs
1629 * If it has, it creates temp which is shape array with lhs.
1630 * For example,
1631 * forall(j=1:N) i(i(j)) = 0
1632 * or
1633 * forall(j=1:N) i(i(j)%m)%m = 0
1634 * will be rewritten
1635 * temp(:) = i(:)
1636 * forall(j=1:N) temp(i(j)) = 0
1637 * i(:) = temp(:)
1638 * or
1639 * temp(:) = i(:)%m
1640 * forall(j=1:N) temp(i(j)%m) = 0
1641 * i(:)%m = temp(:)
1642 * or (for SMP)
1643 * forall(j=1:N) temp(i(j)%m) = i(i(j)%m)
1644 * forall(j=1:N) temp(i(j)%m) = 0
1645 * forall(j=1:N) i(i(j)%m) = temp(i(j)%m)
1646 * * where j is Openmp do loop index, we cannot
1647 * copy the whole array temp back to array i
1648 * because it may overwrite other thread
1649 * work-sharing
1650 */
1651
1652 static int scatter_dependency_recursion = 0;
1653
1654 static void
scatter_dependency(int std)1655 scatter_dependency(int std)
1656 {
1657 int lhs, leftlhs, newleftlhs, l;
1658 int ast, ast1, ast2;
1659 int asn;
1660 int asd;
1661 int subs[MAXDIMS];
1662 int i;
1663 int ndim;
1664 int sptr;
1665 int temp_ast;
1666 int newforall, newasn;
1667 int expr;
1668 int src, dest;
1669 int destsptr;
1670 int eledtype;
1671 int forall;
1672 int subscr[MAXDIMS];
1673 int shape;
1674 int nd;
1675 int std1, forall1, forall2, orig_lhs;
1676 LOGICAL pointer_dependent;
1677
1678 if (scatter_dependency_recursion)
1679 return;
1680
1681 forall = STD_AST(std);
1682 asn = A_IFSTMTG(forall);
1683 lhs = A_DESTG(asn);
1684 l = lhs;
1685 leftlhs = 0;
1686 do {
1687 switch (A_TYPEG(l)) {
1688 case A_ID:
1689 l = 0;
1690 break;
1691 case A_MEM:
1692 l = A_PARENTG(l);
1693 break;
1694 case A_SUBSTR:
1695 l = A_LOPG(l);
1696 break;
1697 case A_SUBSCR:
1698 leftlhs = l;
1699 l = A_LOPG(l);
1700 break;
1701 default:
1702 interr("scatter_dependency: unexpected ast", l, 4);
1703 l = 0;
1704 break;
1705 }
1706 } while (l > 0);
1707 if (leftlhs == 0)
1708 return;
1709
1710 sptr = sptr_of_subscript(leftlhs);
1711 pointer_dependent = FALSE;
1712 /* this can be improved such that
1713 only POINTER indirection in LHS */
1714 if (POINTERG(sptr) && ptr_subs_olap(sptr, lhs))
1715 pointer_dependent = TRUE;
1716
1717 if (pointer_dependent || subscr_dependent(lhs, lhs, std, std)) {
1718 src = A_LOPG(leftlhs);
1719 eledtype = DDTG(DTYPEG(sptr));
1720 dest = 0;
1721 scatter_dependency_recursion = 1;
1722 /* assume size array must be handled earlier
1723 */
1724 if (ASUMSZG(sptr))
1725 return;
1726 destsptr = mk_assign_sptr(src, "sc", subscr, eledtype, &dest);
1727 mk_mem_allocate(mk_id(destsptr), subscr, std, src);
1728
1729 temp_ast = 0;
1730 if (STD_PAR(std)) {
1731 int asn1;
1732
1733 /* We must keep triplet the same as the index might be omp loop index.
1734 * The transformation is similar to non-SMP but we must keep the
1735 * loop indexes the same as original.
1736 */
1737 asd = A_ASDG(leftlhs);
1738 ndim = ASD_NDIM(asd);
1739 for (i = 0; i < ndim; i++) {
1740 subs[i] = ASD_SUBS(asd, i);
1741 }
1742 temp_ast = mk_subscr(mk_id(destsptr), subs, ndim,
1743 DDTG(DTYPEG(destsptr)));
1744 temp_ast = replace_ast_subtree(lhs, leftlhs, temp_ast);
1745 forall1 = mk_stmt(A_FORALL, 0);
1746 A_LISTP(forall1, A_LISTG(forall));
1747 asn1 = mk_stmt(A_ASN,0);
1748 A_DESTP(asn1, temp_ast);
1749 A_SRCP(asn1, lhs);
1750 A_IFSTMTP(forall1, asn1);
1751 add_stmt_before(forall1, std);
1752 orig_lhs = lhs;
1753 } else {
1754 /* tmp = leftlhs */
1755 ast = mk_assn_stmt(dest, src, eledtype);
1756
1757 /* need to create a forall */
1758 shape = A_SHAPEG(dest);
1759 forall1 = make_forall(shape, dest, 0, 0);
1760 ast2 = normalize_forall(forall1, ast, 0);
1761 A_IFSTMTP(forall1, ast2);
1762 A_IFEXPRP(forall1, 0);
1763 std1 = add_stmt_before(forall1, std);
1764 process_forall(std1);
1765
1766 }
1767
1768 /* change original forall */
1769 asd = A_ASDG(leftlhs);
1770 ndim = ASD_NDIM(asd);
1771 for (i = 0; i < ndim; i++)
1772 subs[i] = ASD_SUBS(asd, i);
1773 newleftlhs = mk_subscr(mk_id(destsptr), subs, ndim, DDTG(DTYPEG(destsptr)));
1774 lhs = replace_ast_subtree(lhs, leftlhs, newleftlhs);
1775 A_DESTP(asn, lhs);
1776
1777 if (temp_ast) {
1778 int asn2;
1779 forall2 = mk_stmt(A_FORALL, 0);
1780 A_LISTP(forall2, A_LISTG(forall1));
1781 asn2 = mk_stmt(A_ASN,0);
1782 A_DESTP(asn2, orig_lhs);
1783 A_SRCP(asn2, temp_ast);
1784 A_IFSTMTP(forall2, asn2);
1785 std1 = add_stmt_after(forall2, std);
1786 } else {
1787 /* leftlhs = TMP */
1788 ast = mk_assn_stmt(src, dest, eledtype);
1789 /* need to create a forall */
1790 shape = A_SHAPEG(src);
1791 forall2 = make_forall(shape, src, 0, 0);
1792 ast2 = normalize_forall(forall2, ast, 0);
1793 A_IFSTMTP(forall2, ast2);
1794 A_IFEXPRP(forall2, 0);
1795 std1 = add_stmt_after(forall2, std);
1796 process_forall(std1);
1797 }
1798 mk_mem_deallocate(mk_id(destsptr), std1);
1799 scatter_dependency_recursion = 0;
1800 }
1801 }
1802
1803 /* this function is to take scatter_dependency for only assumed size array
1804 * The other arrays are handle at scatter_dependency()
1805 * because it is impossible to find upper bound of assumed size array
1806 * For example,
1807 * IVEC1(IVEC1(1:5)) = 0 will be
1808 * allocate(tmp(1:5)
1809 * tmp = ivec1(1:5)
1810 * ivec1(tmp) = 0
1811 */
1812 static void
scatter_dependency_assumsz(int std)1813 scatter_dependency_assumsz(int std)
1814 {
1815 int asn;
1816 int sptr;
1817 int shape;
1818 int lhs, l, leftlhs, newleftlhs;
1819 int asd;
1820 int ndim;
1821 int subs[MAXDIMS];
1822 int i;
1823
1824 asn = STD_AST(std);
1825 lhs = A_DESTG(asn);
1826 l = lhs;
1827 leftlhs = 0;
1828 do {
1829 switch (A_TYPEG(l)) {
1830 case A_ID:
1831 l = 0;
1832 break;
1833 case A_MEM:
1834 l = A_PARENTG(l);
1835 break;
1836 case A_SUBSTR:
1837 l = A_LOPG(l);
1838 break;
1839 case A_SUBSCR:
1840 leftlhs = l;
1841 l = A_LOPG(l);
1842 break;
1843 default:
1844 interr("scatter_dependency_assumsz: unexpected ast", l, 4);
1845 l = 0;
1846 break;
1847 }
1848 } while (l > 0);
1849 if (leftlhs == 0)
1850 return;
1851 shape = A_SHAPEG(leftlhs);
1852 if (shape == 0)
1853 return;
1854 sptr = sptr_of_subscript(leftlhs);
1855 if (!ASUMSZG(sptr))
1856 return;
1857 asd = A_ASDG(leftlhs);
1858 ndim = ASD_NDIM(asd);
1859 for (i = 0; i < ndim; i++) {
1860 subs[i] = ASD_SUBS(asd, i);
1861 subs[i] = take_out_assumsz_array(subs[i], std, sptr);
1862 }
1863 newleftlhs = mk_subscr(A_LOPG(leftlhs), subs, ndim, A_DTYPEG(leftlhs));
1864 lhs = replace_ast_subtree(lhs, leftlhs, newleftlhs);
1865 A_DESTP(asn, lhs);
1866 }
1867
1868 static int
take_out_assumsz_array(int expr,int std,int sptr)1869 take_out_assumsz_array(int expr, int std, int sptr)
1870 {
1871 int l, r, d, o;
1872 int l1, l2, l3;
1873 int i, nargs, argt, j;
1874 int lhs;
1875 int sptr1;
1876 int eledtype;
1877 int dest, destsptr;
1878 int subscr[MAXDIMS];
1879 int shape;
1880 int ast;
1881
1882 if (expr == 0)
1883 return expr;
1884 switch (A_TYPEG(expr)) {
1885 /* expressions */
1886 case A_BINOP:
1887 o = A_OPTYPEG(expr);
1888 d = A_DTYPEG(expr);
1889 l = take_out_assumsz_array(A_LOPG(expr), std, sptr);
1890 r = take_out_assumsz_array(A_ROPG(expr), std, sptr);
1891 return mk_binop(o, l, r, d);
1892 case A_UNOP:
1893 o = A_OPTYPEG(expr);
1894 d = A_DTYPEG(expr);
1895 l = take_out_assumsz_array(A_LOPG(expr), std, sptr);
1896 return mk_unop(o, l, d);
1897 case A_CONV:
1898 d = A_DTYPEG(expr);
1899 l = take_out_assumsz_array(A_LOPG(expr), std, sptr);
1900 return mk_convert(l, d);
1901 case A_PAREN:
1902 d = A_DTYPEG(expr);
1903 l = take_out_assumsz_array(A_LOPG(expr), std, sptr);
1904 return mk_paren(l, d);
1905 case A_SUBSTR:
1906 return expr;
1907 case A_INTR:
1908 case A_FUNC:
1909 nargs = A_ARGCNTG(expr);
1910 argt = A_ARGSG(expr);
1911 for (i = 0; i < nargs; ++i) {
1912 ARGT_ARG(argt, i) = take_out_assumsz_array(ARGT_ARG(argt, i), std, sptr);
1913 }
1914 return expr;
1915 case A_CNST:
1916 case A_CMPLXC:
1917 case A_ID:
1918 return expr;
1919 case A_MEM:
1920 case A_SUBSCR:
1921 shape = A_SHAPEG(expr);
1922 if (!shape)
1923 return expr;
1924 if (sptr != sym_of_ast(expr)) {
1925 int e;
1926 /* check any subscripts */
1927 for (e = expr; e;) {
1928 int asd, ndim, i, ch;
1929 switch (A_TYPEG(e)) {
1930 case A_MEM:
1931 e = A_PARENTG(e);
1932 break;
1933 case A_SUBSCR:
1934 asd = A_ASDG(e);
1935 ndim = ASD_NDIM(asd);
1936 ch = 0;
1937 for (i = 0; i < ndim; ++i) {
1938 int ss = ASD_SUBS(asd, i);
1939 subscr[i] = take_out_assumsz_array(ss, std, sptr);
1940 if (subscr[i] != ss)
1941 ch = 1;
1942 }
1943 if (ch) {
1944 int ne;
1945 ne = mk_subscr(A_LOPG(e), subscr, ndim, A_DTYPEG(e));
1946 expr = replace_ast_subtree(expr, e, ne);
1947 }
1948 e = A_LOPG(e);
1949 break;
1950 case A_ID:
1951 e = 0;
1952 break;
1953 default:
1954 interr("take_out_assumsz_array: unexpected ast", e, 3);
1955 e = 0;
1956 break;
1957 }
1958 }
1959 return expr;
1960 }
1961 sptr1 = memsym_of_ast(expr);
1962
1963 eledtype = DDTG(A_DTYPEG(expr));
1964 destsptr = mk_assign_sptr(expr, "sc", subscr, eledtype, &dest);
1965 mk_mem_allocate(mk_id(destsptr), subscr, std, expr);
1966 /* tmp = lhs */
1967 ast = mk_assn_stmt(dest, expr, eledtype);
1968 add_stmt_before(ast, std);
1969 mk_mem_deallocate(mk_id(destsptr), std);
1970 return dest;
1971
1972 default:
1973 return expr;
1974 }
1975 }
1976
1977 /* This routine is to find an array from expr
1978 * such that it is going to be used as a rhs for scatter communication.
1979 * all forall index must appear on rhs arra
1980 */
1981
1982 static LOGICAL
find_scatter_rhs(int expr,int forall,int * rhs)1983 find_scatter_rhs(int expr, int forall, int *rhs)
1984 {
1985 int i, nargs, argt;
1986 int asd;
1987 int ndim;
1988 int list;
1989 LOGICAL find1, find2;
1990
1991 if (expr == 0)
1992 return FALSE;
1993
1994 switch (A_TYPEG(expr)) {
1995 /* expressions */
1996 case A_BINOP:
1997 find1 = find_scatter_rhs(A_LOPG(expr), forall, rhs);
1998 if (find1)
1999 return TRUE;
2000 return find_scatter_rhs(A_ROPG(expr), forall, rhs);
2001 case A_UNOP:
2002 return find_scatter_rhs(A_LOPG(expr), forall, rhs);
2003 case A_CONV:
2004 return find_scatter_rhs(A_LOPG(expr), forall, rhs);
2005 case A_PAREN:
2006 return find_scatter_rhs(A_LOPG(expr), forall, rhs);
2007 case A_MEM:
2008 return FALSE;
2009 case A_SUBSTR:
2010 return FALSE;
2011 case A_INTR:
2012 nargs = A_ARGCNTG(expr);
2013 argt = A_ARGSG(expr);
2014 for (i = 0; i < nargs; ++i) {
2015 find1 = find_scatter_rhs(ARGT_ARG(argt, i), forall, rhs);
2016 if (find1)
2017 return TRUE;
2018 }
2019 return FALSE;
2020 case A_FUNC:
2021 nargs = A_ARGCNTG(expr);
2022 argt = A_ARGSG(expr);
2023 for (i = 0; i < nargs; ++i) {
2024 find1 = find_scatter_rhs(ARGT_ARG(argt, i), forall, rhs);
2025 if (find1)
2026 return TRUE;
2027 }
2028 return TRUE;
2029 case A_CNST:
2030 case A_CMPLXC:
2031 case A_ID:
2032 return FALSE;
2033 case A_SUBSCR:
2034 list = A_LISTG(forall);
2035 if (is_one_idx_for_dim(expr, list) && is_all_idx_in_subscript(list, expr)) {
2036 *rhs = expr;
2037 return TRUE;
2038 }
2039
2040 asd = A_ASDG(expr);
2041 ndim = ASD_NDIM(asd);
2042 for (i = 0; i < ndim; i++) {
2043 find1 = find_scatter_rhs(ASD_SUBS(asd, i), forall, rhs);
2044 if (find1)
2045 return TRUE;
2046 }
2047 return FALSE;
2048 case A_TRIPLE:
2049 return FALSE;
2050 default:
2051 interr("find_scatter_rhs: unknown expression", expr, 2);
2052 return FALSE;
2053 }
2054 }
2055
2056 static LOGICAL
is_all_idx_in_subscript(int list,int a)2057 is_all_idx_in_subscript(int list, int a)
2058 {
2059 int ndim;
2060 int asd;
2061 int i, j;
2062 int isptr;
2063 LOGICAL found;
2064
2065 assert(A_TYPEG(a) == A_SUBSCR, "is_all_idx_in_subscript:must be subscript", a,
2066 3);
2067 asd = A_ASDG(a);
2068 ndim = ASD_NDIM(asd);
2069 for (j = list; j != 0; j = ASTLI_NEXT(j)) {
2070 isptr = ASTLI_SPTR(j);
2071 found = FALSE;
2072 for (i = 0; i < ndim; i++)
2073 if (is_name_in_expr(ASD_SUBS(asd, i), isptr))
2074 found = TRUE;
2075 if (!found)
2076 return FALSE;
2077 }
2078 return TRUE;
2079 }
2080
2081 static int
copy_to_scalar(int ast,int std,int sym)2082 copy_to_scalar(int ast, int std, int sym)
2083 {
2084 int nsym, nsymast, asn, nstd;
2085 if (ast == 0)
2086 return 0;
2087 nsym = sym_get_scalar(SYMNAME(sym), "ss", DT_INT);
2088 nsymast = mk_id(nsym);
2089 asn = mk_stmt(A_ASN, DT_INT);
2090 A_DESTP(asn, nsymast);
2091 A_SRCP(asn, ast);
2092 add_stmt_before(asn, std);
2093 return nsymast;
2094 } /* copy_to_scalar */
2095
2096 /* check whether the forall bounds might be changed by the forall LHS.
2097 * if so, copy them to TEMPs */
2098 static int save_list = 0;
2099 static void
forall_bound_dependence(int std)2100 forall_bound_dependence(int std)
2101 {
2102 int forall, list, asn, lhs, sptrlhs, astli, li;
2103 forall = STD_AST(std);
2104 list = A_LISTG(forall);
2105 asn = A_IFSTMTG(forall);
2106 lhs = A_DESTG(asn);
2107 sptrlhs = sym_of_ast(lhs);
2108 li = 0;
2109 for (astli = list; astli != 0; astli = ASTLI_NEXT(astli)) {
2110 int triple, lw, up, st, ntriple, nlw, nup, nst;
2111 triple = ASTLI_TRIPLE(astli);
2112 nlw = lw = A_LBDG(triple);
2113 start_astli();
2114 if (lw != 0 && appears_in_expr(sptrlhs, lw)) {
2115 /* assign lw to temp */
2116 nlw = copy_to_scalar(lw, std, ASTLI_SPTR(astli));
2117 li = add_astli();
2118 ASTLI_AST(li) = nlw;
2119 ASTLI_PT(li) = lw;
2120 }
2121 nup = up = A_UPBDG(triple);
2122 if (up != 0 && appears_in_expr(sptrlhs, up)) {
2123 /* assign up to temp */
2124 nup = copy_to_scalar(up, std, ASTLI_SPTR(astli));
2125 li = add_astli();
2126 ASTLI_AST(li) = nup;
2127 ASTLI_PT(li) = up;
2128 }
2129 nst = st = A_STRIDEG(triple);
2130 if (st != 0 && appears_in_expr(sptrlhs, st)) {
2131 /* assign st to temp */
2132 nst = copy_to_scalar(st, std, ASTLI_SPTR(astli));
2133 li = add_astli();
2134 ASTLI_AST(li) = nst;
2135 ASTLI_PT(li) = st;
2136 }
2137 if (nlw != lw || nup != up || nst != st) {
2138 ntriple = mk_triple(nlw, nup, nst);
2139 ASTLI_TRIPLE(astli) = ntriple;
2140 }
2141 }
2142 if (li == 0) {
2143 save_list = 0;
2144 } else {
2145 save_list = ASTLI_HEAD;
2146 }
2147 } /* forall_bound_dependence */
2148
2149 extern int rewrite_opfields;
2150 static void
forall_bound_dependence_fix(int prevstd,int nextstd)2151 forall_bound_dependence_fix(int prevstd, int nextstd)
2152 {
2153 /* visit statements between prevstd and nextstd.
2154 * replace any appearances of the forall limits by the temps created */
2155 int std, li;
2156 ast_visit(1, 1);
2157 rewrite_opfields = 0x3; /* copy opt1 and opt2 fields */
2158 for (li = save_list; li; li = ASTLI_NEXT(li)) {
2159 ast_replace(ASTLI_PT(li), ASTLI_AST(li));
2160 }
2161 for (std = STD_NEXT(prevstd); std != nextstd; std = STD_NEXT(std)) {
2162 int ast;
2163 ast = STD_AST(std);
2164 ast = ast_rewrite(ast);
2165 A_STDP(ast, std);
2166 STD_AST(std) = ast;
2167 }
2168 ast_unvisit();
2169 } /* forall_bound_dependence_fix */
2170
2171 /* inquire whether a pointer array has subscripts which may overlap */
2172
2173 static LOGICAL
ptr_subs_olap(int parr,int a)2174 ptr_subs_olap(int parr, int a)
2175 {
2176 do {
2177 if (A_TYPEG(a) == A_MEM) {
2178 a = A_PARENTG(a);
2179 } else if (A_TYPEG(a) == A_SUBSCR) {
2180 int asd;
2181 int ndim, i;
2182 asd = A_ASDG(a);
2183 ndim = ASD_NDIM(asd);
2184 for (i = 0; i < ndim; ++i)
2185 if (can_ptr_olap(parr, ASD_SUBS(asd, i)))
2186 return TRUE;
2187 a = A_LOPG(a);
2188 } else if (A_TYPEG(a) == A_ID) {
2189 return FALSE;
2190 } else {
2191 interr("ptr_subs_olap: LHS not subscript or member", a, 4);
2192 }
2193 } while (1);
2194 }
2195
2196 /* inquire whether expression has array */
2197 static LOGICAL
can_ptr_olap(int parr,int ast)2198 can_ptr_olap(int parr, int ast)
2199 {
2200
2201 int argt, n, i;
2202 int sptr, lop;
2203 int rank;
2204 int dtype;
2205
2206 if (ast == 0)
2207 return FALSE;
2208 switch (A_TYPEG(ast)) {
2209 case A_BINOP:
2210 if (can_ptr_olap(parr, A_LOPG(ast)))
2211 return TRUE;
2212 return can_ptr_olap(parr, A_ROPG(ast));
2213 case A_CONV:
2214 case A_UNOP:
2215 case A_PAREN:
2216 return can_ptr_olap(parr, A_LOPG(ast));
2217 case A_CMPLXC:
2218 case A_CNST:
2219 break;
2220 case A_MEM:
2221 if (can_ptr_olap(parr, A_MEMG(ast)))
2222 return TRUE;
2223 return can_ptr_olap(parr, A_PARENTG(ast));
2224 case A_INTR:
2225 case A_FUNC:
2226 argt = A_ARGSG(ast);
2227 n = A_ARGCNTG(ast);
2228 for (i = 0; i < n; ++i) {
2229 if (can_ptr_olap(parr, ARGT_ARG(argt, i)))
2230 return TRUE;
2231 }
2232 break;
2233
2234 case A_TRIPLE:
2235 if (can_ptr_olap(parr, A_LBDG(ast)))
2236 return TRUE;
2237 if (can_ptr_olap(parr, A_UPBDG(ast)))
2238 return TRUE;
2239 if (can_ptr_olap(parr, A_STRIDEG(ast)))
2240 return TRUE;
2241 break;
2242 case A_SUBSCR:
2243 lop = A_LOPG(ast);
2244 switch (A_TYPEG(lop)) {
2245 case A_ID:
2246 sptr = A_SPTRG(lop);
2247 break;
2248 case A_MEM:
2249 sptr = A_SPTRG(A_MEMG(lop));
2250 break;
2251 default:
2252 return FALSE;
2253 }
2254 if (STYPEG(sptr) == ST_DESCRIPTOR || DESCARRAYG(sptr))
2255 /* set in rte.c */
2256 return FALSE;
2257 if (sptr == parr)
2258 return TRUE;
2259 if (XBIT(58, 0x80000000))
2260 return TRUE;
2261 dtype = DTYPEG(sptr);
2262 if (DTY(dtype) == TY_ARRAY) {
2263 rank = ADD_NUMDIM(DTYPEG(parr));
2264 if (POINTERG(sptr)) {
2265 if (rank == ADD_NUMDIM(dtype))
2266 return TRUE;
2267 }
2268 }
2269 break;
2270 case A_ID:
2271 sptr = A_SPTRG(ast);
2272 if (sptr == parr)
2273 return TRUE;
2274 dtype = DTYPEG(sptr);
2275 if (DTY(dtype) == TY_ARRAY) {
2276 if (XBIT(58, 0x80000000))
2277 return TRUE;
2278 rank = ADD_NUMDIM(DTYPEG(parr));
2279 if (POINTERG(sptr)) {
2280 if (rank == ADD_NUMDIM(dtype))
2281 return TRUE;
2282 }
2283 }
2284 break;
2285 default:
2286 interr("can_ptr_olap: bad opc", ast, 3);
2287 return TRUE;
2288 }
2289 return FALSE;
2290 }
2291