1 /*
2  * Copyright (c) 1994-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 /**
19    \file
20    \brief optimizer submodule responsible for invariant analysis
21    for a given loop.  Used by the optimizer and vectorizer.
22 
23    NOTE: During the detection phase of the analysis, stores are analyzed by
24    traversing the store lists of a loop and its children.  A store is marked by
25    recording the store item in the corresponding name's stl field.  The lifetime
26    of the names' stl fields extends after the analysis phase so that the general
27    query function, is_invariant, can be provided.  The stl fields (and ili
28    marked during the analysis) are cleaned up in unmark/unmarkv.
29  */
30 
31 /* FIXME -- move these to the definition sites
32     void invariant(int)	- do invariant analysis and code motion
33     void invariant_nomotion(int) - just determine which expressions are
34         invariant
35     void invariant_mark(int, int) - mark ili as invariant or not invariant
36     LOGICAL is_invariant(int) - analyze ili for invariancy
37     void invariant_unmark() - unmark ili & nmes which have been marked by the
38         invariant analysis when performing code motion.  The lifetime of
39         marked ili is during invariant and other optimizations (such as
40         induction analysis) which need to know what expressions are invariant.
41         unmarking occurs after the info is no longer needed.
42     void invariant_unmarkv() - unmark ili & nmes which have been marked by the
43         invariant analysis when not performing code motion (i.e., by the
44         vectorizer).
45     static void invar_init(int)
46     static void invar_end(int)
47     static void initnames(*stl)
48     static void cleannames(*stl)
49     static LOGICAL invar_src(int)
50     static void invar_arrnme(int)
51     static void invar_motion(int)
52     static void store_ili(int)
53     LOGICAL is_sym_invariant_safe(int, int)
54 
55 */
56 #include "gbldefs.h"
57 #include "global.h"
58 #include "error.h"
59 #include "symtab.h"
60 #include "ast.h"
61 #include "nme.h"
62 #include "optimize.h"
63 #include "semant.h"
64 
65 static LOGICAL invar_src(int);
66 static void invar_init(int);
67 static void invar_mark(int);
68 static void invar_end(int);
69 static void invar_arrnme(int);
70 static void invar_motion(int);
71 static void store_ili(int);
72 static void initnames(STL *);
73 static void cleannames(STL *);
74 
75 static int lpx, fgx, stdx;
76 static LOGICAL safe;        /* safe to classify an expression invariant */
77 static LOGICAL mark_value;  /* invariant mark (INV) or NOT_INV if in a
78                              * critical section.
79                              */
80 static LOGICAL mark_return; /* TRUE, if mark_value == INV */
81 
82 /*
83  * perform invariant analysis along with code motion.
84  */
85 void
invariant(int lp)86 invariant(int lp)
87 {
88   int pre_bih, stdx, fgx, fg_tail, fg_tailnext;
89   invar_init(lp);
90 
91   invar_mark(lp);
92   LP_HSTDF(lp) = 0;
93   LP_DSTDF(lp) = 0;
94 
95   if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
96     if (!LP_MEXITS(lp) && !LP_PARLOOP(lp) && !LP_CS(lp)) {
97       fg_tail = LP_TAIL(lp);
98       fg_tailnext = FG_LNEXT(fg_tail);
99       for (fgx = LP_HEAD(lp); fgx && fgx != fg_tailnext; fgx = FG_LNEXT(fgx)) {
100         for (stdx = FG_STDFIRST(fgx); stdx; stdx = STD_NEXT(stdx)) {
101           if (STD_ACCEL(stdx) || STD_KERNEL(stdx)) {
102           } else {
103             invar_motion((int)stdx);
104           }
105           if (stdx == FG_STDLAST(fgx))
106             break;
107         }
108         if (fgx == fg_tail)
109           break;
110       }
111     }
112   }
113 
114   invar_end(lp);
115   LP_HSTDF(lp) = 0;
116   LP_DSTDF(lp) = 0;
117 
118 }
119 
120 /*
121  * perform invariant analysis only (no code motion); used by vectorizer
122  * to determine which expressions are invariant in a loop.
123  */
124 void
invariant_nomotion(int lp)125 invariant_nomotion(int lp)
126 {
127   invar_init(lp);
128 
129   invar_mark(lp);
130 
131   invar_end(lp);
132 
133 }
134 
135 void
invariant_mark(int ilix,int mark)136 invariant_mark(int ilix, int mark)
137 {
138   int i;
139 
140   AST_INVP(ilix, mark);
141   i = opt.invb.stg_avail++;
142   OPT_NEED(opt.invb, int, 100);
143   opt.invb.stg_base[i] = ilix;
144 }
145 
146 /*
147  * cleanup invariant table after it's not needed (typically during the last
148  * step in induction analysis, must be used after invariant analysis when
149  * it includes code motion.
150  */
151 void
invariant_unmark(void)152 invariant_unmark(void)
153 {
154   int i, ilix;
155   STL *stl;
156 
157   for (i = opt.invb.stg_avail - 1; i; i--) {
158     ilix = opt.invb.stg_base[i];
159     if (!AST_ISINV_TEMP(ilix))
160       AST_INVP(ilix, 0);
161   }
162   /*
163    * clean up the names entries of the stores in the loop and in any nested
164    * loops
165    */
166   stl = LP_STL(lpx);
167   cleannames(stl);
168 }
169 
170 /*
171  * cleanup invariant table after it's not needed by the vectorize.
172  */
173 void
invariant_unmarkv(void)174 invariant_unmarkv(void)
175 {
176   int i, ilix;
177   STL *stl;
178 
179   for (i = opt.invb.stg_avail - 1; i; i--) {
180     ilix = opt.invb.stg_base[i];
181     AST_INVP(ilix, 0);
182   }
183   /*
184    * clean up the names entries of the stores in the loop and in any nested
185    * loops
186    */
187   stl = LP_STL(lpx);
188   cleannames(stl);
189 }
190 
191 static void
invar_init(int lp)192 invar_init(int lp)
193 {
194   STL *stl;
195 
196   opt.invb.stg_avail = 1;
197   lpx = lp;
198   if (OPTDBG(9, 256))
199     fprintf(gbl.dbgfil, "\n---------- Invariant trace of loop %d\n", lp);
200 
201   stl = LP_STL(lp);
202   /*
203    * initialize the names entries of the stores in the loop and in any
204    * nested loops.  Cleanup occurs in unmark/unmarkv.
205    */
206   initnames(stl);
207 }
208 
209 static void
invar_mark(int lp)210 invar_mark(int lp)
211 {
212   /*
213    * If a loop contains a critical section, first traverse the blocks which
214    * have their FG_CS flags set; this ensures that any ili in the critical
215    * sections will not be considered to be invariant.
216    */
217   if (LP_CS(lp)) {
218     mark_value = NOT_INV;
219     mark_return = FALSE;
220     for (fgx = LP_FG(lp); fgx; fgx = FG_NEXT(fgx)) {
221       safe = TRUE;
222       if (FG_CS(fgx)) {
223         if (OPTDBG(9, 256))
224           fprintf(gbl.dbgfil, "   flow graph node %d (LP_CS)\n", fgx);
225         for (stdx = FG_STDFIRST(fgx); stdx; stdx = STD_NEXT(stdx)) {
226           if (OPTDBG(9, 256))
227             fprintf(gbl.dbgfil, "      ilt %d\n", stdx);
228           (void)invar_src((int)STD_AST(stdx));
229           if (stdx == FG_STDLAST(fgx))
230             break;
231         }
232       }
233     }
234   }
235   mark_value = INV;
236   mark_return = TRUE;
237 
238   /*
239    * Next, traverse the blocks in the loop that are always executed.
240    * i.e, blocks which dominate the tail of the loop.  Otherwise, could
241    * first discover an unsafe invariant expression which appears later
242    * in block that's always executed.
243    */
244   for (fgx = LP_FG(lp); fgx; fgx = FG_NEXT(fgx)) {
245     safe = is_dominator(fgx, (int)LP_TAIL(lp));
246     if (safe) {
247       if (OPTDBG(9, 256))
248         fprintf(gbl.dbgfil, "   flow graph node %d (%s)\n", fgx,
249                 safe ? "safe" : "unsafe");
250       for (stdx = FG_STDFIRST(fgx); stdx; stdx = STD_NEXT(stdx)) {
251         if (OPTDBG(9, 256))
252           fprintf(gbl.dbgfil, "      std %d\n", stdx);
253         (void)invar_src((int)STD_AST(stdx));
254         if (stdx == FG_STDLAST(fgx))
255           break;
256       }
257     }
258   }
259   /*
260    * The last traversal is the blocks in the loop that are not always
261    * executed.
262    */
263   for (fgx = LP_FG(lp); fgx; fgx = FG_NEXT(fgx)) {
264     safe = is_dominator(fgx, (int)LP_TAIL(lp));
265     if (!safe) {
266       if (OPTDBG(9, 256))
267         fprintf(gbl.dbgfil, "   flow graph node %d (%s)\n", fgx,
268                 safe ? "safe" : "unsafe");
269       for (stdx = FG_STDFIRST(fgx); stdx; stdx = STD_NEXT(stdx)) {
270         if (OPTDBG(9, 256))
271           fprintf(gbl.dbgfil, "      std %d\n", stdx);
272         (void)invar_src((int)STD_AST(stdx));
273         if (stdx == FG_STDLAST(fgx))
274           break;
275       }
276     }
277   }
278 
279 }
280 
281 extern void restore_hoist_stmt(int lp);
282 
283 static void
invar_end(int lp)284 invar_end(int lp)
285 {
286   restore_hoist_stmt(lp);
287 }
288 
289 /*
290  * initialize the names entries of the stores in the loop and in any nested
291  * loops
292  */
293 static void
initnames(STL * stlitem)294 initnames(STL *stlitem)
295 {
296   STL *tmp;
297   int i, j, nme;
298 
299   tmp = stlitem;
300   for (i = tmp->store; i; i = STORE_NEXT(i)) {
301     nme = STORE_NM(i);
302     j = NME_STL(nme);
303     if (j)
304       STORE_TYPE(j) |= STORE_TYPE(i);
305     else
306       NME_STL(nme) = i;
307   }
308   /* init names (recursively) for nested loops too. */
309   for (tmp = tmp->childlst; tmp != NULL; tmp = tmp->nextsibl) {
310     initnames(tmp);
311   }
312 }
313 
314 /*
315  * clean up the names entries of the stores in the loop and in any nested
316  * loops
317  */
318 static void
cleannames(STL * stlitem)319 cleannames(STL *stlitem)
320 {
321   STL *tmp;
322   int i;
323 
324   tmp = stlitem;
325   for (i = tmp->store; i; i = STORE_NEXT(i))
326     NME_STL(STORE_NM(i)) = 0;
327 
328   /* clean up (recursively) names of any descendants, too */
329   for (tmp = tmp->childlst; tmp != NULL; tmp = tmp->nextsibl) {
330     cleannames(tmp);
331   }
332 }
333 
334 /*
335  * Determine if given ili is invariant.  WARNING:  this assumes that
336  * the regular analysis has been done; i.e., safe and lpx which are
337  * static have been set.
338  */
339 LOGICAL
is_invariant(int ilix)340 is_invariant(int ilix)
341 {
342   LOGICAL invf;
343   if (OPTDBG(9, 256))
344     fprintf(gbl.dbgfil, "is_invariant of ili %d called\n", ilix);
345   invf = invar_src(ilix);
346   if (OPTDBG(9, 256))
347     fprintf(gbl.dbgfil, "is_invariant of ili %d returns %s\n", ilix,
348             invf ? "TRUE" : "FALSE");
349   return invf;
350 }
351 
352 static void compute_invariant(int, int *);
353 
354 static LOGICAL
invar_src(int ast)355 invar_src(int ast)
356 {
357   ast_visit(1, 1);
358   ast_traverse(ast, NULL, compute_invariant, NULL);
359   ast_unvisit();
360   return AST_ISINV(ast);
361 }
362 
363 static void
compute_invariant(int ast,int * dummy)364 compute_invariant(int ast, int *dummy)
365 {
366   int atype;
367   int sym;
368   int nme;
369   int dtype;
370   int i, asd;
371   int astli;
372   int argt;
373   int cnt;
374   LOGICAL invar_flag;
375 
376   /* already done
377   if (AST_INVG(ast))
378       return;
379   */
380 
381   switch (atype = A_TYPEG(ast)) {
382   case A_NULL:
383   case A_CNST:
384   case A_CMPLXC:
385     break; /* mark invariant */
386   case A_ID:
387     sym = A_SPTRG(ast);
388     if (ST_ISVAR(STYPEG(sym)) || (ST_ARRDSC == STYPEG(sym))) {
389       nme = A_NMEG(ast);
390       if (NME_STL(nme)) {
391         if (OPTDBG(9, 256))
392           fprintf(gbl.dbgfil,
393                   "         ast %5d-%s %s is not invariant--ST_NME %d\n", ast,
394                   astb.atypes[atype], SYMNAME(sym), nme);
395         goto mark_variant;
396       }
397       if (NME_TYPE(nme) != NT_VAR)
398         goto mark_variant;
399       if (!is_sym_invariant_safe(nme, lpx)) {
400         if (OPTDBG(9, 256)) {
401           fprintf(gbl.dbgfil, "         ast %5d-%s not invariant - %s unsafe\n",
402                   ast, astb.atypes[atype], SYMNAME(sym));
403         }
404         goto mark_variant;
405       }
406     }
407     break;
408   case A_MEM:
409     if (!AST_ISINV(A_PARENTG(ast)))
410       goto markd_variant;
411     /* _ast_trav(A_MEMG(ast)) */
412     break;
413   case A_BINOP:
414     invar_flag = AST_ISINV(A_LOPG(ast)) && AST_ISINV(A_ROPG(ast));
415     if (!invar_flag)
416       goto markd_variant;
417     goto chk_fp_safe;
418   case A_UNOP:
419   case A_CONV:
420   case A_PAREN:
421     if (!AST_ISINV(A_LOPG(ast)))
422       goto markd_variant;
423     goto chk_fp_safe;
424   case A_SUBSCR:
425     asd = A_ASDG(ast);
426     if (!AST_ISINV(A_LOPG(ast)))
427       goto markd_variant;
428     for (i = 0; i < (int)ASD_NDIM(asd); i++)
429       if (!AST_ISINV(ASD_SUBS(asd, i)))
430         goto markd_variant;
431     break;
432   case A_SUBSTR:
433     if (!AST_ISINV(A_LOPG(ast)))
434       goto markd_variant;
435     if (A_LEFTG(ast) && !AST_ISINV(A_LEFTG(ast)))
436       goto markd_variant;
437     if (A_RIGHTG(ast) && !AST_ISINV(A_RIGHTG(ast)))
438       goto markd_variant;
439     break;
440   case A_TRIPLE:
441     /* [lb]:[ub][:stride] */
442     if (A_LBDG(ast) && !AST_ISINV(A_LBDG(ast)))
443       goto markd_variant;
444     if (A_UPBDG(ast) && !AST_ISINV(A_UPBDG(ast)))
445       goto markd_variant;
446     if (A_STRIDEG(ast) && !AST_ISINV(A_STRIDEG(ast)))
447       goto markd_variant;
448     break;
449   case A_FUNC:
450     goto markd_variant;
451   case A_ALLOC:
452 
453 /* currently enabled when STD_HSTBLE(stdx) is set , this flag is set
454  * when the allocate/deallocate is for forall temp array.
455  * might need to keep track of allo/deall.
456  */
457     if (flg.opt >= 2 && !XBIT(2, 0x400000)) {
458       if (STD_HSTBLE(stdx) && is_alloc_ast(ast)) {
459         int srcast = A_SRCG(ast);
460         if (A_TYPEG(srcast) == A_SUBSCR)
461           goto markd_variant;
462         compute_invariant(srcast, NULL);
463         if (!AST_ISINV(srcast))
464           goto markd_variant;
465         if (A_SHAPEG(srcast)) {
466           int asd, i, ndim, ss;
467           asd = A_ASDG(srcast);
468           ndim = ASD_NDIM(asd);
469           for (i = 0; i < ndim; ++i) {
470             ss = ASD_SUBS(asd, i);
471             compute_invariant((ss), NULL);
472             if (!AST_ISINV(ss))
473               goto markd_variant;
474           }
475         }
476       }
477       if (STD_HSTBLE(stdx) && is_dealloc_ast(ast)) {
478         int std = STD_HSTBLE(stdx);
479         /* check if ast of std is this ast and it is hoistable and it is
480          * invariant */
481 
482         if (A_TYPEG(A_SRCG(ast)) == A_SUBSCR || !STD_HSTBLE(std))
483           goto markd_variant;
484         if (AST_ISINV(A_SRCG(ast)))
485           break;
486       }
487     }
488     goto markd_variant;
489     break;
490 
491   case A_INTR:
492     switch (A_OPTYPEG(ast)) {
493     case I_RAN:
494     case I_RANDOM_NUMBER:
495     case I_RANDOM_SEED:
496       goto markd_variant;
497     }
498     cnt = A_ARGCNTG(ast);
499     argt = A_ARGSG(ast);
500     if (cnt) {
501       i = 0;
502       while (TRUE) {
503         /* lfm -- optional args */
504         if (ARGT_ARG(argt, i) != 0 && !AST_ISINV(ARGT_ARG(argt, i)))
505           goto markd_variant;
506         if (++i >= cnt)
507           break;
508       }
509     }
510   chk_fp_safe:
511     if (!safe) {
512       dtype = DDTG(A_DTYPEG(ast));
513       if (DT_ISREAL(dtype) || DT_ISCMPLX(dtype))
514         goto unsafe;
515     }
516     break;
517   default:
518     AST_INVP(ast, NOT_INV);
519     return; /* default; don't add to invb list */
520   }
521 
522   invariant_mark(ast, mark_value);
523   if (OPTDBG(9, 256)) {
524     if (mark_value == INV || mark_value == T_INV) {
525       fprintf(gbl.dbgfil, "         ast %5d-%s", ast, astb.atypes[atype]);
526       if (A_TYPEG(ast) == A_ID)
527         fprintf(gbl.dbgfil, " %s", SYMNAME(A_SPTRG(ast)));
528       fprintf(gbl.dbgfil, " is invariant\n");
529     } else
530       fprintf(gbl.dbgfil, "         ast %5d-%s is not invariant -- csec\n", ast,
531               astb.atypes[atype]);
532   }
533   return;
534 
535 unsafe:
536   if (OPTDBG(9, 256))
537     fprintf(gbl.dbgfil, "         ast %5d-%s -- unsafe\n", ast,
538             astb.atypes[atype]);
539 /* fall thru */
540 markd_variant:
541   if (OPTDBG(9, 256))
542     fprintf(gbl.dbgfil, "         ast %5d-%s is not invariant\n", ast,
543             astb.atypes[atype]);
544 mark_variant:
545   invariant_mark(ast, NOT_INV);
546 
547 }
548 
549 /*
550  * for any array nme's in nme, check their subscripts.  Note that this only
551  * marks the ili if necessary.  Detecting an invariant subscript is not
552  * enough for it to be moved; the subscript ili must actually appear in
553  * a tree rooted by an ilt.  There are situations (e.g., a[i+1]) where
554  * the subscript ili does not actually appear in the reference due to
555  * algebraic simplification.
556  */
557 static void
invar_arrnme(int nme)558 invar_arrnme(int nme)
559 {
560   int anme;
561 
562   anme = nme;
563   while (NME_TYPE(anme) == NT_MEM || NME_TYPE(anme) == NT_IND)
564     anme = NME_NM(anme);
565   while (NME_TYPE(anme) == NT_ARR) {
566     if (NME_SUB(anme)) {
567       if (OPTDBG(9, 256))
568         fprintf(gbl.dbgfil, "         arrnme %d, subili %d\n", anme,
569                 NME_SUB(anme));
570       (void)invar_src((int)NME_SUB(anme));
571     }
572     anme = NME_NM(anme);
573   }
574 }
575 
576 static LOGICAL is_std_hoistable(int, int);
577 
578 /* allocate statement to move up, deallocate statement to move down */
579 static void
invar_motion(int std)580 invar_motion(int std)
581 {
582   int opc, i, j;
583   int ast, astd;
584   LOGICAL hstable = FALSE;
585   /* only STD_HSTBLE for now */
586   if (STD_HSTBLE(std)) {
587     ast = STD_AST(std);
588     if (is_alloc_ast(ast)) {
589       hstable = is_std_hoistable(std, lpx);
590       if (hstable) {
591         hoist_stmt(std, LP_FG(lpx), lpx);
592       } else {
593         /* mark not hoistable so that the deallocate will not be hoist */
594         astd = STD_HSTBLE(std);
595         STD_HSTBLE(std) = 0;
596         STD_HSTBLE(astd) = 0;
597       }
598     } else if (is_dealloc_ast(ast) && STD_HSTBLE(std)) {
599       astd = STD_HSTBLE(std);
600       if (STD_VISIT(astd)) {
601         hoist_stmt(std, LP_FG(lpx), lpx);
602 
603         /* only do one level of hoisting for now */
604         STD_HSTBLE(std) = 0;
605         STD_HSTBLE(astd) = 0;
606       }
607     }
608   }
609 }
610 
611 static LOGICAL
def_in_innerlp(int lpx,int def_lp)612 def_in_innerlp(int lpx, int def_lp)
613 {
614   int lp;
615   for (lp = LP_CHILD(lpx); lp; lp = LP_SIBLING(lp)) {
616     if (lp == def_lp)
617       return TRUE;
618   }
619   return FALSE;
620 }
621 
622 /* return a number of def in a loop
623  * relies on LP_STL
624  * for subscript x[3]:
625  *    if there is a whole array ref (x) => no
626  *    if there is a subscript but variable index (x[n]) => no
627  */
628 static LOGICAL
has_def_inlp(int ast,int lp,int std)629 has_def_inlp(int ast, int lp, int std)
630 {
631   int lop, rop, def, nme, def_fg, asd, def_addr, ndim;
632   int def_count = 0;
633 
634   switch (A_TYPEG(ast)) {
635 
636   case A_SUBSCR:
637     lop = A_LOPG(ast);
638     if (A_TYPEG(lop) != A_ID) /* don't handle derived type yet */
639       return FALSE;
640     nme = A_NMEG(ast);
641     if (!nme)
642       return FALSE;
643     if (NME_TYPE(nme) != NT_ARR)
644       return FALSE;
645     nme = NME_NM(nme);
646 
647     for (def = NME_DEF(nme); def; def = DEF_NEXT(def)) {
648       def_fg = DEF_FG(def);
649       def_addr = DEF_ADDR(def);
650       asd = A_ASDG(def_addr);
651       ndim = ASD_NDIM(asd);
652       if (FG_LOOP(def_fg) != lp && !def_in_innerlp(lp, FG_LOOP(def_fg)))
653         continue;
654       if (DEF_STD(def) == std) {
655         ++def_count;
656       } else {
657         if (def_addr == DEF_LHS(def)) /* whole array */
658           ++def_count;
659         else if (A_TYPEG(ASD_SUBS(asd, 0)) != A_CNST)
660           ++def_count;            /* index is variable, don't do further */
661         else if (def_addr == ast) /* same index */
662           ++def_count;
663       }
664       if (def_count > 1)
665         return FALSE;
666     }
667     break;
668   case A_ID:
669     nme = A_NMEG(ast);
670     break;
671   default:
672     return FALSE;
673     break;
674   }
675 
676   if (def_count > 1)
677     return FALSE;
678 
679   return TRUE;
680 }
681 
682 static LOGICAL
683     /* also do the hoist */
is_hoistable(int ast,int std,int lp)684     is_hoistable(int ast, int std, int lp)
685 {
686   int lop, rop, sym, nme, sptr, def_addr, ndim, def_std, i;
687   int asd, du_std;
688   int use_count, def_count;
689   LOGICAL can_hoist;
690   int l, u, s, r, cnme, found_nme, def, def_fg, hoistme;
691   STL *stl;
692   DU *du;
693 
694   switch (A_TYPEG(ast)) {
695   case A_BINOP:
696     r = is_hoistable(A_ROPG(ast), std, lp);
697     l = is_hoistable(A_LOPG(ast), std, lp);
698     if (l & r) {
699       return TRUE;
700     }
701     break;
702   case A_UNOP:
703     l = is_hoistable(A_LOPG(ast), std, lp);
704     if (l)
705       return TRUE;
706     break;
707   case A_TRIPLE:
708     l = is_hoistable(A_LBDG(ast), std, lp);
709     u = is_hoistable(A_UPBDG(ast), std, lp);
710     s = is_hoistable(A_STRIDEG(ast), std, lp);
711 
712     return (l & u & s);
713     break;
714   case A_CNST:
715     return TRUE;
716   case A_ID:
717     return FALSE; /* for now */
718     break;
719   case A_SUBSCR:
720     if (A_SHAPEG(ast)) /* currently don't do too many nested subscripts */
721       return FALSE;
722     lop = A_LOPG(ast);
723     if (A_TYPEG(lop) == A_ID) {
724       sym = A_SPTRG(lop);
725       if (ADDRTKNG(sym) && (LP_CALLFG(lp) || LP_CALLINTERNAL(lp))) {
726         /* to do list: if call is external we can check if this is passed
727          * as an argument
728          * NOTE: should I also check inner loop calls?
729          */
730         return FALSE;
731       }
732       cnme = A_NMEG(lop);
733       if (NME_SYM(cnme) == -1)
734         cnme = NME_NM(cnme);
735       if (STYPEG(sym) == ST_DESCRIPTOR) {
736         stl = LP_STL(lp);
737         /* no need to use store list */
738         found_nme = 0;
739         for (i = stl->store; i; i = STORE_NEXT(i)) {
740           nme = STORE_NM(i);
741           if (NME_SYM(nme) == -1)
742             nme = NME_NM(nme);
743           sptr = NME_SYM(nme);
744           if (cnme != nme)
745             continue;
746           if (NME_TYPE(nme) != NT_VAR)
747             return FALSE;
748 
749           found_nme = 1;
750           use_count = 0;
751           def_count = 0;
752           hoistme = 0;
753           for (def = NME_DEF(nme); def; def = DEF_NEXT(def)) {
754             def_addr = DEF_ADDR(def);
755             def_std = DEF_STD(def);
756 
757             /* check if this def is in a loop or inner loop */
758             def_fg = DEF_FG(def);
759             if (lp != FG_LOOP(def_fg)) {
760               if (LP_CHILD(lp) && !def_in_innerlp(lp, FG_LOOP(def_fg)))
761                 continue;
762             }
763             if (def_addr && A_TYPEG(def_addr) == A_SUBSCR) {
764               asd = A_ASDG(def_addr);
765               ndim = ASD_NDIM(asd);
766               if (ndim > 1)
767                 return FALSE;
768               /* don't want to do more checking if subscript is not constant */
769               if (A_TYPEG(ASD_SUBS(asd, 0)) != A_CNST)
770                 return FALSE;
771 
772               if (def_addr == ast) {
773 
774                 /* handle with 1 def for now */
775                 ++def_count;
776                 if (def_count > 1)
777                   return FALSE;
778 
779                 for (du = DEF_DU(def); du; du = du->next) {
780                   du_std = USE_STD(du->use);
781                   if (USE_STD(du->use) == std) {
782                     use_count++;
783 
784                     /* this check(def_std != std) is unnessary but we
785                      * want to make sure that infinite recursive
786                      * won't happen here.
787                      */
788                     if (def_std != std) {
789                       if (!is_std_hoistable(def_std, lp)) {
790                         return FALSE;
791                       } else {
792                         hoistme = 1;
793                       }
794                     }
795                   }
796                 }
797               }
798 
799             } else {
800               return FALSE;
801             }
802             if (def_count > 1)
803               return FALSE;
804 
805             /* do the hoist of std */
806             if (hoistme) {
807               hoist_stmt(def_std, LP_FG(lp), lp);
808               return TRUE;
809             }
810           }
811 
812           if (found_nme) {
813             return TRUE;
814           }
815           /* found nme */
816           break;
817         }
818         if (found_nme == 0) { /* not found in store list */
819           return TRUE;
820         }
821       }
822     }
823     break;
824   default:
825     break;
826   }
827   return FALSE;
828 }
829 
830 /* currently handle temp alloc/dealloc and assignment of descriptors */
831 static LOGICAL
is_std_hoistable(int std,int lpx)832 is_std_hoistable(int std, int lpx)
833 {
834   LOGICAL canhoist = FALSE;
835   LOGICAL l, r, s, u, all, sym, tmplog;
836   int shape, n, i, astd;
837   int ast = STD_AST(std);
838 
839   switch (A_TYPEG(ast)) {
840   case A_ALLOC:
841     /* assume temp alloc */
842     if (is_alloc_ast(ast) && STD_HSTBLE(std)) {
843       ast = A_SRCG(ast);
844       switch (A_TYPEG(ast)) {
845       case A_SUBSCR:
846         shape = A_SHAPEG(ast);
847         n = SHD_NDIM(shape);
848         tmplog = FALSE;
849         for (i = 0; i < n; ++i) {
850           l = is_hoistable(SHD_LWB(shape, i), std, lpx);
851           u = is_hoistable(SHD_UPB(shape, i), std, lpx);
852           s = is_hoistable(SHD_STRIDE(shape, i), std, lpx);
853           tmplog = l && u && s;
854           if (tmplog) {
855             int fast = A_FIRSTALLOCG(ast);
856             if (fast) {
857               if (!is_hoistable(fast, std, lpx))
858                 return FALSE;
859             }
860           } else {
861             return FALSE;
862           }
863         }
864         return tmplog;
865         break;
866       case A_ID:
867         return FALSE; /* To do list */
868         break;
869       default:
870         return FALSE;
871       }
872     } else if (is_dealloc_ast(ast) && STD_HSTBLE(std)) {
873       /* this assume that allocate statement is already visited */
874       astd = STD_HSTBLE(ast);
875       if (STD_HSTBLE(astd) && STD_VISIT(astd))
876         return TRUE;
877     }
878     return FALSE;
879     break;
880 
881   case A_ASN:
882     l = A_DESTG(ast);
883     r = A_SRCG(ast);
884 
885     if (A_TYPEG(l) == A_SUBSCR) {
886       int a = A_LOPG(l);
887       if (A_TYPEG(a) != A_ID) {
888         return FALSE;
889       }
890     } else if (A_TYPEG(l) == A_ID) {
891       sym = A_SPTRG(ast);
892       if (ADDRTKNG(sym)) {
893         if (LP_CALLFG(lpx) || LP_CALLINTERNAL(lpx))
894           return FALSE;
895       }
896     } else {
897       return FALSE;
898     }
899 
900     if (has_def_inlp(l, lpx, std) <= 1) {
901       /* only hoist this std if the lhs has only one def,
902        * address taken ok but no call
903        */
904       if (is_hoistable(r, std, lpx)) {
905         return TRUE;
906       } else {
907         return FALSE;
908       }
909     }
910 
911     break;
912 
913   /* everything else is not hoistable for now */
914   case A_FUNC:
915   case A_INTR:
916   case A_CALL:
917   case A_ICALL:
918   case A_ASNGOTO:
919   default:
920     return FALSE;
921     break;
922   }
923 
924 not_hoistable:
925 
926   return canhoist;
927 }
928 
929 static void
store_ili(int ilix)930 store_ili(int ilix)
931 {
932   int temp;
933 
934   /* assign temp; routine marks ILI with candidate entry */
935 }
936 
937 static LOGICAL
is_nme_loop_safe(int ldnme,int lpx)938 is_nme_loop_safe(int ldnme, int lpx)
939 {
940   if (flg.opt < 2)
941     return FALSE; /* copy from front end, why false? */
942 
943   /*
944       int stl = LP_STL(lpx);
945       if( stl ){
946           int store;
947           for( store = stl->store; store; store = STORE_NEXT(store) ){
948               int stnme = STORE_NM(store);
949               if( conflict( ldnme, stnme ) != NOCONFLICT ){
950                   return FALSE;
951               }
952           }
953       }
954       if (!is_call_safe(ldnme)) {
955               return FALSE;
956       }
957 
958       for( inner = LP_CHILD(lpx); inner; inner = LP_SIBLING(inner) ){
959           if( !is_nme_loop_safe( ldnme, inner ) )
960               return FALSE;
961       }
962 
963   */
964   return TRUE;
965 }
966 
967 LOGICAL
is_sym_invariant_safe(int nme,int lpx)968 is_sym_invariant_safe(int nme, int lpx)
969 {
970   int sym, sflag;
971   sflag = 0;
972 
973   /*
974    * a symbol is not safe (potential "side-effect" conflicts exist) if:
975    * 1.  for c and fortran, the symbol is volatile
976    *
977    * 2.  for fortran, the symbol is equivalenced
978    *
979    * 3.  loop contains a call AND
980    *     a.  sym's address has been taken, or
981    *     b.  sym's storage class is not auto (it is static or extern).
982    *     c.  or for pascal- sym is used in two or more nested scope levels
983    *
984    * 4.  loop contains a store via a pointer AND the sym could
985    *     conflict with a pointer (see optutil.c:is_sym_ptrsafe()).
986    *
987    * 5.  the symbol is private and the loop is not a parallel region.
988    *
989    * 6.  the symbol is not a private variable and is stored while in a
990    *     critical section in this loop or any enclosed loop, or in a
991    *     parallel region.
992    *
993    * 7.  the symbol is not a private variable and the loop contains
994    *     a parallel section.
995    *
996    * 8.  for Fortran, the loop contains a call to an internal subprogram
997    *     and this is a noninternal variable.
998    *
999    * NOTE that this differs from is_sym_optsafe in that a load via a pointer
1000    * does not rule out loads of certain symbols as being invariant. This is
1001    * because the symbol cannot be redefined with a load via a pointer.
1002    */
1003   sym = NME_SYM(nme);
1004   if (VOLG(sym))
1005     return (FALSE);
1006 
1007   if (SOCPTRG(sym))
1008     return (FALSE);
1009   if (LP_CALLFG(lpx) && (!IS_LCL_OR_DUM(sym)
1010                              )) {
1011     return (FALSE);
1012   }
1013 
1014   if (SOCPTRG(sym))
1015     return (FALSE);
1016 
1017   if (LP_CALLINTERNAL(lpx) && !INTERNALG(sym))
1018     return FALSE;
1019 
1020   if (IS_PRIVATE(sym) && !LP_PARREGN(lpx))
1021     return (FALSE);
1022 
1023   if ((LP_CSECT(lpx) || LP_PARREGN(lpx)) && !IS_PRIVATE(sym)) {
1024     Q_ITEM *q;
1025     for (q = LP_STL_PAR(lpx); q != NULL; q = q->next)
1026       if (q->info == nme)
1027         return (FALSE);
1028   }
1029 
1030   if (LP_PARSECT(lpx) && !IS_PRIVATE(sym)) {
1031     return (FALSE);
1032   }
1033 
1034   if (!sflag && LP_PTR_STORE(lpx) && !is_sym_ptrsafe(sym))
1035     /* check ptr before argument */
1036     /*    if (flg.opt >= 2 && XBIT (xxx)) {
1037             is_sym_invar_inlp();
1038         }*/
1039     return (FALSE);
1040 
1041   if (!sflag && LP_CALLFG(lpx) && ADDRTKNG(sym)) {
1042     /* check argument in a call, if it is in then it is safe  */
1043     return (FALSE);
1044   }
1045 
1046   return (TRUE);
1047 }
1048