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