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