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