1 /*-
2 * Copyright (c) 1980 The Regents of the University of California.
3 * All rights reserved.
4 *
5 * %sccs.include.proprietary.c%
6 */
7
8 #ifndef lint
9 static char sccsid[] = "@(#)optim.c 5.5 (Berkeley) 04/12/91";
10 #endif /* not lint */
11
12 /*
13 * optim.c
14 *
15 * Miscellaneous optimizer routines, f77 compiler pass 1.
16 *
17 * UCSD Chemistry modification history:
18 *
19 * $Log: optim.c,v $
20 * Revision 5.2 86/03/04 17:47:08 donn
21 * Change buffcat() and buffct1() analogously to putcat and putct1() --
22 * ensure that memoffset is evaluated before vleng. Take care not to
23 * screw up and return something other than an expression.
24 *
25 * Revision 5.1 85/08/10 03:48:42 donn
26 * 4.3 alpha
27 *
28 * Revision 2.12 85/06/08 22:57:01 donn
29 * Prevent core dumps -- bug in optinsert was causing lastslot to be wrong
30 * when a slot was inserted at the end of the buffer.
31 *
32 * Revision 2.11 85/03/18 08:05:05 donn
33 * Prevent warnings about implicit conversions.
34 *
35 * Revision 2.10 85/02/12 20:13:00 donn
36 * Resurrected the hack in 2.6.1.1 to avoid creating a temporary when
37 * there is a concatenation on the rhs of an assignment, and threw out
38 * all the code dealing with starcat(). It seems that we can't use a
39 * temporary because the lhs as well as the rhs may have nonconstant length.
40 *
41 * Revision 2.9 85/01/18 00:53:52 donn
42 * Missed a call to free() in the last change...
43 *
44 * Revision 2.8 85/01/18 00:50:03 donn
45 * Fixed goof made when modifying buffmnmx() to explicitly call expand().
46 *
47 * Revision 2.7 85/01/15 18:47:35 donn
48 * Changes to allow character*(*) variables to appear in concatenations in
49 * the rhs of an assignment statement.
50 *
51 * Revision 2.6 84/12/16 21:46:27 donn
52 * Fixed bug that prevented concatenations from being run together. Changed
53 * buffpower() to not touch exponents greater than 64 -- let putpower do them.
54 *
55 * Revision 2.5 84/10/29 08:41:45 donn
56 * Added hack to flushopt() to prevent the compiler from trying to generate
57 * intermediate code after an error.
58 *
59 * Revision 2.4 84/08/07 21:28:00 donn
60 * Removed call to p2flush() in putopt() -- this allows us to make better use
61 * of the buffering on the intermediate code file.
62 *
63 * Revision 2.3 84/08/01 16:06:24 donn
64 * Forced expand() to expand subscripts.
65 *
66 * Revision 2.2 84/07/19 20:21:55 donn
67 * Decided I liked the expression tree algorithm after all. The algorithm
68 * which repeatedly squares temporaries is now checked in as rev. 2.1.
69 *
70 * Revision 1.3.1.1 84/07/10 14:18:18 donn
71 * I'm taking this branch off the trunk -- it works but it's not as good as
72 * the old version would be if it worked right.
73 *
74 * Revision 1.5 84/07/09 22:28:50 donn
75 * Added fix to buffpower() to prevent it chasing after huge exponents.
76 *
77 * Revision 1.4 84/07/09 20:13:59 donn
78 * Replaced buffpower() routine with a new one that generates trees which can
79 * be handled by CSE later on.
80 *
81 * Revision 1.3 84/05/04 21:02:07 donn
82 * Added fix for a bug in buffpower() that caused func(x)**2 to turn into
83 * func(x) * func(x). This bug had already been fixed in putpower()...
84 *
85 * Revision 1.2 84/03/23 22:47:21 donn
86 * The subroutine argument temporary fixes from Bob Corbett didn't take into
87 * account the fact that the code generator collects all the assignments to
88 * temporaries at the start of a statement -- hence the temporaries need to
89 * be initialized once per statement instead of once per call.
90 *
91 */
92
93 #include "defs.h"
94 #include "optim.h"
95
96
97
98 /*
99 * Information buffered for each slot type
100 *
101 * slot type expptr integer pointer
102 *
103 * IFN expr label -
104 * GOTO - label -
105 * LABEL - label -
106 * EQ expr - -
107 * CALL expr - -
108 * CMGOTO expr num labellist*
109 * STOP expr - -
110 * DOHEAD [1] - ctlframe*
111 * ENDDO [1] - ctlframe*
112 * ARIF expr - labellist*
113 * RETURN expr label -
114 * ASGOTO expr - labellist*
115 * PAUSE expr - -
116 * ASSIGN expr label -
117 * SKIOIFN expr label -
118 * SKFRTEMP expr - -
119 *
120 * Note [1]: the nullslot field is a pointer to a fake slot which is
121 * at the end of the slots which may be replaced by this slot. In
122 * other words, it looks like this:
123 * DOHEAD slot
124 * slot \
125 * slot > ordinary IF, GOTO, LABEL slots which implement the DO
126 * slot /
127 * NULL slot
128 */
129
130
131 expptr expand();
132
133 Slotp firstslot = NULL;
134 Slotp lastslot = NULL;
135 int numslots = 0;
136
137
138 /*
139 * turns off optimization option
140 */
141
optoff()142 optoff()
143
144 {
145 flushopt();
146 optimflag = 0;
147 }
148
149
150
151 /*
152 * initializes the code buffer for optimization
153 */
154
setopt()155 setopt()
156
157 {
158 register Slotp sp;
159
160 for (sp = firstslot; sp; sp = sp->next)
161 free ( (charptr) sp);
162 firstslot = lastslot = NULL;
163 numslots = 0;
164 }
165
166
167
168 /*
169 * flushes the code buffer
170 */
171
172 LOCAL int alreadycalled = 0;
173
flushopt()174 flushopt()
175 {
176 register Slotp sp;
177 int savelineno;
178
179 if (alreadycalled) return; /* to prevent recursive call during errors */
180 alreadycalled = 1;
181
182 if (debugflag[1])
183 showbuffer ();
184
185 frtempbuff ();
186
187 savelineno = lineno;
188 for (sp = firstslot; sp; sp = sp->next)
189 {
190 if (nerr == 0)
191 putopt (sp);
192 else
193 frexpr (sp->expr);
194 if(sp->ctlinfo) free ( (charptr) sp->ctlinfo);
195 free ( (charptr) sp);
196 numslots--;
197 }
198 firstslot = lastslot = NULL;
199 numslots = 0;
200 clearbb();
201 lineno = savelineno;
202
203 alreadycalled = 0;
204 }
205
206
207
208 /*
209 * puts out code for the given slot (from the code buffer)
210 */
211
putopt(sp)212 LOCAL putopt (sp)
213 register Slotp sp;
214 {
215 lineno = sp->lineno;
216 switch (sp->type) {
217 case SKNULL:
218 break;
219 case SKIFN:
220 case SKIOIFN:
221 putif(sp->expr, sp->label);
222 break;
223 case SKGOTO:
224 putgoto(sp->label);
225 break;
226 case SKCMGOTO:
227 putcmgo(sp->expr, sp->label, sp->ctlinfo);
228 break;
229 case SKCALL:
230 putexpr(sp->expr);
231 break;
232 case SKSTOP:
233 putexpr (call1 (TYSUBR, "s_stop", sp->expr));
234 break;
235 case SKPAUSE:
236 putexpr (call1 (TYSUBR, "s_paus", sp->expr));
237 break;
238 case SKASSIGN:
239 puteq (sp->expr,
240 intrconv(sp->expr->headblock.vtype, mkaddcon(sp->label)));
241 break;
242 case SKDOHEAD:
243 case SKENDDO:
244 break;
245 case SKEQ:
246 putexpr(sp->expr);
247 break;
248 case SKARIF:
249 #define LM ((struct Labelblock * *)sp->ctlinfo)[0]->labelno
250 #define LZ ((struct Labelblock * *)sp->ctlinfo)[1]->labelno
251 #define LP ((struct Labelblock * *)sp->ctlinfo)[2]->labelno
252 prarif(sp->expr, LM, LZ, LP);
253 break;
254 case SKASGOTO:
255 putbranch((Addrp) sp->expr);
256 break;
257 case SKLABEL:
258 putlabel(sp->label);
259 break;
260 case SKRETURN:
261 if (sp->expr)
262 {
263 putforce(TYINT, sp->expr);
264 putgoto(sp->label);
265 }
266 else
267 putgoto(sp->label);
268 break;
269 case SKFRTEMP:
270 templist = mkchain (sp->expr,templist);
271 break;
272 default:
273 badthing("SKtype", "putopt", sp->type);
274 break;
275 }
276
277 /*
278 * Recycle argument temporaries here. This must get done on a
279 * statement-by-statement basis because the code generator
280 * makes side effects happen at the start of a statement.
281 */
282 argtemplist = hookup(argtemplist, activearglist);
283 activearglist = CHNULL;
284 }
285
286
287
288 /*
289 * copies one element of the control stack
290 */
291
cpframe(p)292 LOCAL struct Ctlframe *cpframe(p)
293 register char *p;
294 {
295 static int size = sizeof (struct Ctlframe);
296 register int n;
297 register char *q;
298 struct Ctlframe *q0;
299
300 q0 = ALLOC(Ctlframe);
301 q = (char *) q0;
302 n = size;
303 while(n-- > 0)
304 *q++ = *p++;
305 return( q0);
306 }
307
308
309
310 /*
311 * copies an array of labelblock pointers
312 */
313
cplabarr(n,arr)314 LOCAL struct Labelblock **cplabarr(n,arr)
315 struct Labelblock *arr[];
316 int n;
317 {
318 struct Labelblock **newarr;
319 register char *in, *out;
320 register int i,j;
321
322 newarr = (struct Labelblock **) ckalloc (n * sizeof (char *));
323 for (i = 0; i < n; i++)
324 {
325 newarr[i] = ALLOC (Labelblock);
326 out = (char *) newarr[i];
327 in = (char *) arr[i];
328 j = sizeof (struct Labelblock);
329 while (j-- > 0)
330 *out++ = *in++;
331 }
332 return (newarr);
333 }
334
335
336
337 /*
338 * creates a new slot in the code buffer
339 */
340
newslot()341 LOCAL Slotp newslot()
342 {
343 register Slotp sp;
344
345 ++numslots;
346 sp = ALLOC( slt );
347 sp->next = NULL ;
348 if (lastslot)
349 {
350 sp->prev = lastslot;
351 lastslot = lastslot->next = sp;
352 }
353 else
354 {
355 firstslot = lastslot = sp;
356 sp->prev = NULL;
357 }
358 sp->lineno = lineno;
359 return (sp);
360 }
361
362
363
364 /*
365 * removes (but not deletes) the specified slot from the code buffer
366 */
367
removeslot(sl)368 removeslot (sl)
369 Slotp sl;
370
371 {
372 if (sl->next)
373 sl->next->prev = sl->prev;
374 else
375 lastslot = sl->prev;
376 if (sl->prev)
377 sl->prev->next = sl->next;
378 else
379 firstslot = sl->next;
380 sl->next = sl->prev = NULL;
381
382 --numslots;
383 }
384
385
386
387 /*
388 * inserts slot s1 before existing slot s2 in the code buffer;
389 * appends to end of list if s2 is NULL.
390 */
391
insertslot(s1,s2)392 insertslot (s1,s2)
393 Slotp s1,s2;
394
395 {
396 if (s2)
397 {
398 if (s2->prev)
399 s2->prev->next = s1;
400 else
401 firstslot = s1;
402 s1->prev = s2->prev;
403 s2->prev = s1;
404 }
405 else
406 {
407 s1->prev = lastslot;
408 lastslot->next = s1;
409 lastslot = s1;
410 }
411 s1->next = s2;
412
413 ++numslots;
414 }
415
416
417
418 /*
419 * deletes the specified slot from the code buffer
420 */
421
delslot(sl)422 delslot (sl)
423 Slotp sl;
424
425 {
426 removeslot (sl);
427
428 if (sl->ctlinfo)
429 free ((charptr) sl->ctlinfo);
430 frexpr (sl->expr);
431 free ((charptr) sl);
432 numslots--;
433 }
434
435
436
437 /*
438 * inserts a slot before the specified slot; if given NULL, it is
439 * inserted at the end of the buffer
440 */
441
optinsert(type,p,l,c,currslot)442 Slotp optinsert (type,p,l,c,currslot)
443 int type;
444 expptr p;
445 int l;
446 int *c;
447 Slotp currslot;
448
449 {
450 Slotp savelast,new;
451
452 savelast = lastslot;
453 if (currslot)
454 lastslot = currslot->prev;
455 new = optbuff (type,p,l,c);
456 new->next = currslot;
457 if (currslot)
458 currslot->prev = new;
459 new->lineno = -1; /* who knows what the line number should be ??!! */
460 if (currslot)
461 lastslot = savelast;
462 return (new);
463 }
464
465
466
467 /*
468 * buffers the FRTEMP slots which have been waiting
469 */
470
frtempbuff()471 frtempbuff ()
472
473 {
474 chainp ht;
475 register Slotp sp;
476
477 for (ht = holdtemps; ht; ht = ht->nextp)
478 {
479 sp = newslot();
480 /* this slot actually belongs to some previous source line */
481 sp->lineno = sp->lineno - 1;
482 sp->type = SKFRTEMP;
483 sp->expr = (expptr) ht->datap;
484 sp->label = 0;
485 sp->ctlinfo = NULL;
486 }
487 holdtemps = NULL;
488 }
489
490
491
492 /*
493 * puts the given information into a slot at the end of the code buffer
494 */
495
optbuff(type,p,l,c)496 Slotp optbuff (type,p,l,c)
497 int type;
498 expptr p;
499 int l;
500 int *c;
501
502 {
503 register Slotp sp;
504
505 if (debugflag[1])
506 {
507 fprintf (diagfile,"-----optbuff-----"); showslottype (type);
508 showexpr (p,0); fprintf (diagfile,"\n");
509 }
510
511 p = expand (p);
512 sp = newslot();
513 sp->type = type;
514 sp->expr = p;
515 sp->label = l;
516 sp->ctlinfo = NULL;
517 switch (type)
518 {
519 case SKCMGOTO:
520 sp->ctlinfo = (int*) cplabarr (l, (struct Labelblock**) c);
521 break;
522 case SKARIF:
523 sp->ctlinfo = (int*) cplabarr (3, (struct Labelblock**) c);
524 break;
525 case SKDOHEAD:
526 case SKENDDO:
527 sp->ctlinfo = (int*) cpframe ((struct Ctlframe*) c);
528 break;
529 default:
530 break;
531 }
532
533 frtempbuff ();
534
535 return (sp);
536 }
537
538
539
540 /*
541 * expands the given expression, if possible (e.g., concat, min, max, etc.);
542 * also frees temporaries when they are indicated as being the last use
543 */
544
545 #define APPEND(z) \
546 res = res->exprblock.rightp = mkexpr (OPCOMMA, z, newtemp)
547
expand(p)548 LOCAL expptr expand (p)
549 tagptr p;
550
551 {
552 Addrp t;
553 expptr q;
554 expptr buffmnmx(), buffpower(), buffcat();
555
556 if (!p)
557 return (ENULL);
558 switch (p->tag)
559 {
560 case TEXPR:
561 switch (p->exprblock.opcode)
562 {
563 case OPASSIGN: /* handle a = b // c */
564 if (p->exprblock.vtype != TYCHAR)
565 goto standard;
566 q = p->exprblock.rightp;
567 if (!(q->tag == TEXPR &&
568 q->exprblock.opcode == OPCONCAT))
569 goto standard;
570 t = (Addrp) expand(p->exprblock.leftp);
571 frexpr(p->exprblock.vleng);
572 free( (charptr) p );
573 p = (tagptr) q;
574 goto cat;
575 case OPCONCAT:
576 t = mktemp (TYCHAR, ICON(lencat(p)));
577 cat:
578 q = (expptr) cpexpr (p->exprblock.vleng);
579 p = (tagptr) buffcat (t, p);
580 frexpr (p->headblock.vleng);
581 p->headblock.vleng = q;
582 break;
583 case OPMIN:
584 case OPMAX:
585 p = (tagptr) buffmnmx (p);
586 break;
587 case OPPOWER:
588 p = (tagptr) buffpower (p);
589 break;
590 default:
591 standard:
592 p->exprblock.leftp =
593 expand (p->exprblock.leftp);
594 if (p->exprblock.rightp)
595 p->exprblock.rightp =
596 expand (p->exprblock.rightp);
597 break;
598 }
599 break;
600
601 case TLIST:
602 {
603 chainp t;
604 for (t = p->listblock.listp; t; t = t->nextp)
605 t->datap = (tagptr) expand (t->datap);
606 }
607 break;
608
609 case TTEMP:
610 if (p->tempblock.istemp)
611 frtemp(p);
612 break;
613
614 case TADDR:
615 p->addrblock.memoffset = expand( p->addrblock.memoffset );
616 break;
617
618 default:
619 break;
620 }
621 return ((expptr) p);
622 }
623
624
625
626 /*
627 * local version of routine putcat in putpcc.c, called by expand
628 */
629
buffcat(lhs,rhs)630 LOCAL expptr buffcat(lhs, rhs)
631 register Addrp lhs;
632 register expptr rhs;
633 {
634 int n;
635 Addrp lp, cp;
636 expptr ep, buffct1();
637
638 n = ncat(rhs);
639 lp = (Addrp) mkaltmpn(n, TYLENG, PNULL);
640 cp = (Addrp) mkaltmpn(n, TYADDR, PNULL);
641
642 n = 0;
643 ep = buffct1(rhs, lp, cp, &n);
644
645 ep = mkexpr(OPCOMMA, ep,
646 call4(TYSUBR, "s_cat", lhs, cp, lp, mkconv(TYLONG, ICON(n))));
647
648 return (ep);
649 }
650
651
652
653 /*
654 * local version of routine putct1 in putpcc.c, called by expand
655 */
656
buffct1(q,lp,cp,ip)657 LOCAL expptr buffct1(q, lp, cp, ip)
658 register expptr q;
659 register Addrp lp, cp;
660 int *ip;
661 {
662 int i;
663 Addrp lp1, cp1;
664 expptr eleft, eright;
665
666 if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
667 {
668 eleft = buffct1(q->exprblock.leftp, lp, cp, ip);
669 eright = buffct1(q->exprblock.rightp, lp, cp, ip);
670 frexpr(q->exprblock.vleng);
671 free( (charptr) q );
672 }
673 else
674 {
675 i = (*ip)++;
676 cp1 = (Addrp) cpexpr(cp);
677 cp1->memoffset = mkexpr(OPPLUS, cp1->memoffset, ICON(i*SZADDR));
678 lp1 = (Addrp) cpexpr(lp);
679 lp1->memoffset = mkexpr(OPPLUS, lp1->memoffset, ICON(i*SZLENG));
680 eleft = mkexpr(OPASSIGN, cp1, addrof(expand(cpexpr(q))));
681 eright = mkexpr(OPASSIGN, lp1, cpexpr(q->headblock.vleng));
682 frexpr(q);
683 }
684 return (mkexpr(OPCOMMA, eleft, eright));
685 }
686
687
688
689 /*
690 * local version of routine putmnmx in putpcc.c, called by expand
691 */
692
buffmnmx(p)693 LOCAL expptr buffmnmx(p)
694 register expptr p;
695 {
696 int op, type;
697 expptr qp;
698 chainp p0, p1;
699 Addrp sp, tp;
700 Addrp newtemp;
701 expptr result, res;
702
703 if(p->tag != TEXPR)
704 badtag("buffmnmx", p->tag);
705
706 type = p->exprblock.vtype;
707 op = (p->exprblock.opcode==OPMIN ? OPLT : OPGT );
708 qp = expand(p->exprblock.leftp);
709 if(qp->tag != TLIST)
710 badtag("buffmnmx list", qp->tag);
711 p0 = qp->listblock.listp;
712 free( (charptr) qp );
713 free( (charptr) p );
714
715 sp = mktemp(type, PNULL);
716 tp = mktemp(type, PNULL);
717 qp = mkexpr(OPCOLON, cpexpr(tp), cpexpr(sp));
718 qp = mkexpr(OPQUEST, mkexpr(op, cpexpr(tp),cpexpr(sp)), qp);
719 qp = fixexpr(qp);
720
721 newtemp = mktemp (type,PNULL);
722
723 result = res = mkexpr (OPCOMMA,
724 mkexpr( OPASSIGN, cpexpr(sp), p0->datap ), cpexpr(newtemp));
725
726 for(p1 = p0->nextp ; p1 ; p1 = p1->nextp)
727 {
728 APPEND (mkexpr( OPASSIGN, cpexpr(tp), p1->datap ));
729 if(p1->nextp)
730 APPEND (mkexpr (OPASSIGN, cpexpr(sp), cpexpr(qp)) );
731 else
732 APPEND (mkexpr (OPASSIGN, cpexpr(newtemp), qp));
733 }
734
735 frtemp(sp);
736 frtemp(tp);
737 frtemp(newtemp);
738 frchain( &p0 );
739
740 return (result);
741 }
742
743
744
745 /*
746 * Called by expand() to eliminate exponentiations to integer constants.
747 */
buffpower(p)748 LOCAL expptr buffpower( p )
749 expptr p;
750 {
751 expptr base;
752 Addrp newtemp;
753 expptr storetemp = ENULL;
754 expptr powtree();
755 expptr result;
756 ftnint exp;
757
758 if ( ! ISICON( p->exprblock.rightp ) )
759 fatal( "buffpower: bad non-integer exponent" );
760
761 base = expand(p->exprblock.leftp);
762 exp = p->exprblock.rightp->constblock.constant.ci;
763 if ( exp < 2 )
764 fatal( "buffpower: bad exponent less than 2" );
765
766 if ( exp > 64 ) {
767 /*
768 * Let's be reasonable, here... Let putpower() do the job.
769 */
770 p->exprblock.leftp = base;
771 return ( p );
772 }
773
774 /*
775 * If the base is not a simple variable, evaluate it and copy the
776 * result into a temporary.
777 */
778 if ( ! (base->tag == TADDR && ISCONST( base->addrblock.memoffset )) ) {
779 newtemp = mktemp( base->headblock.vtype, PNULL );
780 storetemp = mkexpr( OPASSIGN,
781 cpexpr( (expptr) newtemp ),
782 cpexpr( base ) );
783 base = (expptr) newtemp;
784 }
785
786 result = powtree( base, exp );
787
788 if ( storetemp != ENULL )
789 result = mkexpr( OPCOMMA, storetemp, result );
790 frexpr( p );
791
792 return ( result );
793 }
794
795
796
797 /*
798 * powtree( base, exp ) -- Create a tree of multiplications which computes
799 * base ** exp. The tree is built so that CSE will compact it if
800 * possible. The routine works by creating subtrees that compute
801 * exponents which are powers of two, then multiplying these
802 * together to get the result; this gives a log2( exp ) tree depth
803 * and lots of subexpressions which can be eliminated.
804 */
powtree(base,exp)805 LOCAL expptr powtree( base, exp )
806 expptr base;
807 register ftnint exp;
808 {
809 register expptr r = ENULL, r1;
810 register int i;
811
812 for ( i = 0; exp; ++i, exp >>= 1 )
813 if ( exp & 1 )
814 if ( i == 0 )
815 r = (expptr) cpexpr( base );
816 else {
817 r1 = powtree( base, 1 << (i - 1) );
818 r1 = mkexpr( OPSTAR, r1, cpexpr( r1 ) );
819 r = (r ? mkexpr( OPSTAR, r1, r ) : r1);
820 }
821
822 return ( r );
823 }
824