xref: /csrg-svn/usr.bin/f77/pass1.tahoe/optcse.c (revision 47951)

/*-
 * Copyright (c) 1980 The Regents of the University of California.
 * All rights reserved.
 *
 * %sccs.include.proprietary.c%
 */

#ifndef lint
static char sccsid[] = "@(#)optcse.c	5.3 (Berkeley) 04/12/91";
#endif /* not lint */

/*
 * optcse.c
 *
 * Common subexpression elimination routines, F77 compiler pass 1.
 *
 * University of Utah CS Dept modification history:
 *
 * $Log:	optcse.c,v $
 * Revision 2.4  84/10/29  04:40:48  donn
 * Problem with conversions -- two expressions headed by a conversion may be
 * identical in structure but different in type, thus type must be checked in
 * findnode().  This was causing a subscript to become REAL*8 type...
 *
 * Revision 2.3  84/08/04  20:38:53  donn
 * Added fix from Jerry Berkman for an earlier fix from Alastair Fyfe --
 * samebase() should treat EQUIVALENCEd variables just as daintily as
 * COMMON variables.
 *
 * Revision 2.2  84/08/01  16:04:33  donn
 * Changed rmcommaop so that it does subscripts too.
 *
 * Revision 2.1  84/07/19  12:03:44  donn
 * Changed comment headers for UofU.
 *
 * Revision 1.5  84/07/09  14:43:05  donn
 * Added changes to make OPPLUSEQ and OPSTAREQ expressions ineligible for
 * CSE, since I can't think of a simple way to handle them and they are broken
 * in the previous version, where they were treated like OPASSIGN -- this
 * fails because CSE would think that the value of the lhs and rhs were equal.
 *
 * Revision 1.4  84/06/08  11:43:35  donn
 * Yet another way of handling the bug with COMMON -- this one is from Alastair
 * Fyfe at Sun.  I backed out the old fix.
 *
 * Revision 1.3  84/03/07  19:25:14  donn
 * Changed method of handling COMMON bug -- COMMON variables are now treated
 * like array elements and hence are ineligible for CSE.
 *
 * Revision 1.2  84/02/26  03:30:47  donn
 * Fixed bug in evaluation graph construction that caused two variables in
 * common to be considered identical if they were merely in the same common,
 * rather than in the same common at the same offset.
 *
 */

#include "defs.h"
#include "optim.h"

#define FALSE	0
#define TRUE	1

LOCAL Bblockp	current_BB;
LOCAL int	cse1count;	/* count of number of cse uses eliminated */
LOCAL int	cse2count;	/* count of number of cse def's eliminated */




LOCAL dumpstacks()
{
	duplptr dl;
	valuen p;
	idlptr idl;
	idptr idp;
	nodelptr nl;
	int i;

	fprintf(diagfile,"\n *** IDblocks ***\n");
	for(idp=current_BB->headid;idp;idp=idp->next)
	{
		fprintf(diagfile,
			"idp= %d idaddr= %d initval= %d assgnval= %d \n",
			idp, idp->idaddr, idp->initval, idp->assgnval);
		fprintf(diagfile,"nodes: ");
		i=0;
		for (nl=idp->headnodelist;nl;nl=nl->next) {
			if(++i>20){
				fprintf(diagfile,"\n");
				i=0;
			}
			fprintf(diagfile," %d ",nl->nodep);
		}
		fprintf(diagfile,"\n");
	}

	fprintf(diagfile,"\n *** VALUE NODES *** \n");
	for(p=current_BB->headnode;p;p=p->next) {
		fprintf(diagfile,
		   "\np= %d opp= %d lc= %d rc= %d rs= %d is_dead= %d n_dups %d",
		   p, p->opp,p->lc,p->rc, p->rs, p->is_dead, p->n_dups);
		if (p->rs){
			fprintf(diagfile,"tag= %d ",p->opp->tag);
			if(p->opp->tag==TEXPR)
				fprintf(diagfile,"opco= %d ",
				    p->opp->exprblock.opcode);
		}
		fprintf(diagfile,"\n");
		fprintf(diagfile,"parent= %d dups:  ",p->parent);
		i=0;
		for(dl=p->headduplist;dl;dl=dl->next) {
			if(++i>20){
				fprintf(diagfile,"\n");
				i=0;
			}
			fprintf(diagfile," %d ",dl->parent);
		}

		fprintf(diagfile,"\ndeps IDs");
		i=0;
		for(idl=p->headdeplist;idl;idl=idl->next) {
			if(++i>20){
				fprintf(diagfile,"\n");
				i=0;
			}
			fprintf(diagfile," %d ",idl->idp);
		}
	}
}



LOCAL idlptr mergedeps(lnode,rnode)
valuen lnode,rnode;
/* Given two value nodes, merge the lists of identifiers on which they
** depend to produce a new list incorporating both dependencies. Lists
** are assumed to be ordered by increasing idp address. No duplicate identifiers
** are generated in the output list.
*/
{
	register idlptr lp,lp1,lp2;
	idlptr head;

	lp = lp1 = lp2 = head = NULL;
	if(lnode) lp1 = lnode->headdeplist;
	if(rnode) lp2 = rnode->headdeplist;

	while (lp1 || lp2) {
		if (lp) {
			lp->next = ALLOC(IDlist);
			lp = lp->next;
		}
		else lp = head = ALLOC(IDlist);
		lp->next = 0;
		if (lp1 == 0) {
			lp->idp = lp2->idp;
			lp2 = lp2->next;
		}
		else if (lp2 == 0) {
			lp->idp = lp1->idp;
			lp1 = lp1->next;
		}
		else if (lp1->idp < lp2->idp) {
			lp->idp = lp1->idp;
			lp1 = lp1->next;
		}
		else if (lp1->idp > lp2->idp) {
			lp->idp = lp2->idp;
			lp2 = lp2->next;
		}
		else {
			lp->idp = lp1->idp;
			lp1 = lp1->next;
			lp2 = lp2->next;
		}
	}
	return(head);
}



LOCAL removenode(nodep)
valuen nodep;
/*  Removes a value node from every IDblock on the node's list of identifiers.
*/
{
	register idlptr idl;
	register nodelptr nl;
	register nodelptr *addrnl;

	if(nodep == NULL) return ;

	/* loop through all identifiers */
	for(idl=nodep->headdeplist;idl;idl=idl->next)
	{
		addrnl = &(idl->idp->headnodelist);
		/* for each identifier loop through all nodes until match is found */
		for(nl = *addrnl; nl; nl = *addrnl)
		{
			if(nl->nodep == nodep) {
				*addrnl = nl->next;
				free ( (charptr) nl );
				break;
			}
			addrnl = &nl->next;
		}
	}
	nodep->is_dead = TRUE;
}



LOCAL killid(idp)
idptr idp;
/* Kill all nodes on one identifier's list of dependent nodes, i.e. remove
** all calculations that depend on this identifier from the available
** values stack.  Free the list of records pointing at the dependent nodes.
*/
{
	nodelptr nl1,nl2;

	for (nl1 = idp->headnodelist; nl1; nl1=nl2)
	{
		nl2 = nl1->next;
		removenode(nl1->nodep);
	}
	/* the above call frees the node list record pointed at by nl1 since it frees
	** all the node list records that reference the value node being killed
	*/
	idp->headnodelist = NULL;

}



LOCAL killdepnodes(idp)
idptr idp;
/* Kill all value nodes that represent calculations which depend on
** this identifier. If the identifier is in COMMON or EQUIVALENCE storage,
** kill all values that depend on identifiers in COMMON or EQUIVALENCE
*/
{
	int thismemno;

	if(idp->idaddr->addrblock.vstg == STGCOMMON)
	{
		for(idp=current_BB->headid;idp;idp=idp->next)
			if(idp->idaddr->addrblock.vstg == STGCOMMON)
				killid(idp);
	}
	else if(idp->idaddr->addrblock.vstg == STGEQUIV)
	{
		thismemno=idp->idaddr->addrblock.memno;
		for(idp=current_BB->headid;idp;idp=idp->next)
			if(idp->idaddr->addrblock.vstg == STGEQUIV
			    && idp->idaddr->addrblock.memno == thismemno)
				killid(idp);
	}
	else killid(idp);

}



LOCAL appendnode(nodep)
valuen nodep;
/* Append a value node to all the IDblocks on that node's list of
** dependent identifiers i.e., since this computation depends on
** all the identifiers on its list then each of those identifiers should
** include this node in their list of dependent nodes.
*/
{
	register idlptr idl;
	register nodelptr nl;

	for(idl=nodep->headdeplist;idl;idl=idl->next)
		if(idl->idp->idaddr->tag == TADDR ||
		   idl->idp->idaddr->tag == TTEMP)
			{
			nl=ALLOC(NODElist);
			nl->nodep = nodep;
			nl->next = idl->idp->headnodelist;
			idl->idp->headnodelist = nl;
			}
}



LOCAL idlptr addadep(idp,nodep)
idptr idp;
valuen nodep;
/* Add an identifier to the dependents list of a value node.  Dependents
** lists are ordered by increasing idp value
*/
{
	register idlptr lp1,lp2;

	lp2 = ALLOC(IDlist);
	lp2->idp = idp;
	if(nodep->headdeplist == 0) {
		lp2->next = 0;
		nodep->headdeplist = lp2;
	}
	else if(idp <= nodep->headdeplist->idp) {
		lp2->next = nodep->headdeplist;
		nodep->headdeplist = lp2;
	}
	else for(lp1 = nodep->headdeplist; lp1; lp1 = lp1->next)
		if( (lp1->next == 0) || (idp <= lp1->next->idp) )
		{
			lp2->next = lp1->next;
			lp1->next = lp2;
			break;
		}
	return(lp2);
}



LOCAL valuen newnode(expr,left,right,rslt)
expptr expr;
valuen left,right,rslt;
/* Build a new value node
*/
{
	register valuen p;

	p= ALLOC(VALUEnode);
	p->opp = expr ;
	p->parent = NULL ;
	p->lc = left;
	p->rc = right;
	p->rs = rslt;
	p->n_dups = 0;
	p->is_dead = FALSE;
	p->next=NULL;
	p->headdeplist = mergedeps(left,right);
	p->headduplist=NULL;
	if(current_BB->headnode == 0) current_BB->headnode=p;
	else if(current_BB->tailnode) current_BB->tailnode->next=p;
	current_BB->tailnode=p;

	return(p);
}



LOCAL newid(idaddr,addrof_idptr)
expptr idaddr;
idptr *addrof_idptr;
/* Build a new IDblock and hook it on the current BB's ID list
*/
{
	register idptr p;

	p= ALLOC(IDblock);

/* build a leaf value node for the identifier and put the ID on the leaf node's
** list of dependent identifiers
*/
	p->initval =  newnode(idaddr,NULL,NULL,NULL);
	p->initval->rs = p->initval;
	addadep(p,p->initval);

	p->idaddr = idaddr;
	*addrof_idptr = p;
	p->headnodelist=NULL;
	p->next=NULL;

}



LOCAL addadup(parent,nodep)
expptr *parent;
valuen nodep;

/* A subtree has been found that duplicates the calculation represented
** by the value node referenced by nodep : add the root of the reduntant
** tree to the value node's list of duplicates.
*/

{
	register duplptr dp;
	valuen child;

	dp = ALLOC(DUPlist);
	dp->parent = parent;
	dp->next = nodep->headduplist;
	nodep->headduplist = dp;
	++nodep->n_dups;

/* Check whether either of nodep's children is also a duplicate calculation
** and if so peel off it's most recent dup record
*/

	if ( (child = nodep->lc) && (child->n_dups) )
	{
		dp = child->headduplist;
		child->headduplist = dp->next;
		free ( (charptr) dp );
		--child->n_dups;
	}
	if ( (child = nodep->rc) && (child->n_dups) )
	{
		dp = child->headduplist;
		child->headduplist = dp->next;
		free ( (charptr) dp );
		--child->n_dups;
	}

}



LOCAL samebase(ep1,ep2)
expptr ep1,ep2;
{
    if ( ep1->tag == ep2->tag  )
	switch (ep2->tag) {
	    case TTEMP :
		if (ep1->tempblock.memalloc == ep2->tempblock.memalloc)
			return (TRUE);
		break;
	    case TADDR :
		if (ep1->addrblock.vstg == ep2->addrblock.vstg) {
		    switch(ep1->addrblock.vstg) {
			case STGEQUIV:
			case STGCOMMON:
			    if (ep1->addrblock.memno == ep2->addrblock.memno &&
				ISCONST(ep1->addrblock.memoffset) &&
				ISCONST(ep2->addrblock.memoffset) &&
				ep1->addrblock.memoffset->constblock.constant.ci ==
				ep2->addrblock.memoffset->constblock.constant.ci ) {
				    return(TRUE);
			    }
			    break;

			default:
			    if (ep1->addrblock.memno == ep2->addrblock.memno ) {
				return(TRUE);
			    }
		    }
		}
		break;
	    case TCONST :
		if( (ep1->constblock.vtype) ==
		    (ep2->constblock.vtype)  )
		{
			union Constant *ap,*bp;
			ap= &ep1->constblock.constant;
			bp= &ep2->constblock.constant;
			switch(ep1->constblock.vtype)

			{
			case TYSHORT:
			case TYLONG:
				if(ap->ci == bp->ci) return(TRUE);
				break;
			case TYREAL:
			case TYDREAL:
				if(ap->cd[0] == bp->cd[0]) return(TRUE);
				break;
			case TYCOMPLEX:
			case TYDCOMPLEX:
				if(ap->cd[0] == bp->cd[0] &&
				    ap->cd[1] == bp->cd[1] )
					return(TRUE);
				break;
			}
		}
		break;

	    default :
		badtag ("samebase",ep2->tag);
	}
    return(FALSE);
}



LOCAL idptr findid(idaddr)
expptr idaddr;

/* Find an identifier's IDblock given its idaddr. If the identifier has no
** IBblock build one
*/

{
	register idptr idp;
	if(current_BB->headid == 0) newid(idaddr,&current_BB->headid);
	idp=current_BB->headid;

	do {
		if (samebase(idp->idaddr,idaddr) )  break;
		if (idp->next == 0) {
			newid(idaddr,&idp->next);
			idp = idp->next;
			break;
		}
		idp = idp->next;
	}
	while(TRUE);

	return(idp);
}



LOCAL valuen findnode(ep,leftc,rightc)
expptr ep;
valuen leftc,rightc;
{
	/* Look for a matching value node in the available computations stack
	*/
	register valuen p;

	for ( p=current_BB->headnode; p ; p=p->next)  {
		if( ( ! p->is_dead)   &&
		    (p->lc == leftc)  &&
		    (p->rc == rightc) &&
		    ( (ep->tag == TEXPR && p->opp->tag == TEXPR
		      && p->opp->exprblock.opcode == ep->exprblock.opcode
		      && p->opp->exprblock.vtype == ep->exprblock.vtype
		      )
		    || (ep->tag == TADDR) || (ep->tag == TTEMP)
		    )
		  )
			return(p);
	}
	return(NULL);
}



LOCAL valuen scanchain(listp,p_parent)
expptr listp;
chainp *p_parent;

/* Make value nodes from the chain hanging off a LISTBLOCK
*/

{
	valuen lnode,rnode,new,scantree();
	chainp p;

	p= *p_parent;
	if (p == NULL) return(NULL);
	lnode = scantree( &p->datap);
	rnode = scanchain(listp, &p->nextp);
	new = newnode(listp,lnode,rnode,0);
	new->rs = new;
	return(new->rs);
}



LOCAL valuen scantree(p_parent)
expptr *p_parent;

/* build a value node and return its address. p must point to an
** exprblock an addrblock a listblock  or a constblock.
*/

{
valuen lnode, rnode,rsltnode,new;
expptr opp,p;
Exprp ep1,ep2;
idptr idp;

p = *p_parent;
if(p == NULL) return(NULL);

switch (p->tag) {
	case TCONST :
		return( findid(p)->initval );

	case TTEMP :
		idp = findid(p);
		if(idp->assgnval) return(idp->assgnval);

		lnode = idp->initval;
		rnode = scantree( &p->tempblock.memalloc);

		rsltnode = findnode(p,lnode,rnode);
		if(rsltnode)
			return(rsltnode);
		else {
			new = newnode(p,lnode,rnode,0);
			new->rs = new;
			new->parent = p_parent;
			return(new->rs);
		}

	case TADDR :
		idp = findid(p);
		if(idp->assgnval) return(idp->assgnval);

		lnode = idp->initval;
		rnode = scantree( &p->addrblock.memoffset);

		rsltnode = findnode(p,lnode,rnode);
		if(rsltnode) {
#ifdef	notdef
			/*
			 * This code is broken until OPINDIRECT is implemented.
			 */
			if(p->addrblock.memoffset != NULL &&
			    p->addrblock.memoffset->tag == TEXPR)
				addadup(p_parent,rsltnode);
#endif	notdef
			return(rsltnode);
		}
		else {
			new = newnode(p,lnode,rnode,0);
			new->rs = new;
			new->parent = p_parent;
			return(new->rs);
		}

	case TLIST :
		return(scanchain(p->listblock.listp,&p->listblock.listp));

	default :
		badtag ("scantree",p->tag);

	case TEXPR  :
		lnode = scantree(&p->exprblock.leftp);
		rnode = scantree(&p->exprblock.rightp);

		switch (p->exprblock.opcode) {
			case OPASSIGN :
				{
				Addrp ap;

				ap = (Addrp) p->exprblock.leftp;
				idp = findid(ap);
				killdepnodes(idp);
				if( ! ap->isarray ) {
					if(rnode->is_dead)idp->assgnval=idp->initval;
					else idp->assgnval = rnode;
				}
				new = newnode(p,idp->initval,NULL,NULL);
				appendnode(new);
				new->rs = new;
				return(new->rs);
				}

			/*
			 * Don't optimize these...  they're a real hassle.
			 */
			case OPPLUSEQ :
			case OPSTAREQ :
				{
				Addrp ap;

				ap = (Addrp) p->exprblock.leftp;
				idp = findid(ap);
				killdepnodes(idp);
				idp->assgnval = NULL;
				new = newnode(p,lnode,rnode,NULL);
				new->rs = new;
				return(new->rs);
				}

			case OPCALL :
				{
				chainp cp;

				if(p->exprblock.rightp)

	/* pretend that all variables on the arglist have just
	** been assigned to i.e. kill of calculations that
	** depend on them. Not necessary for CCALL(by value)
	*/

				for(cp=p->exprblock.rightp->listblock.listp;
                                cp;cp=cp->nextp)
					if (cp->datap->tag == TADDR ||
					    cp->datap->tag == TTEMP){
						idp = findid(cp->datap);
						killdepnodes(idp);
						idp->assgnval = NULL;
				}

				new = newnode(p,lnode,rnode,NULL);
				new->rs = new;
				return(new->rs);
				}

			case OPCONCAT:
			case OPADDR:
			case OPCOLON:
			case OPINDIRECT:
		/*
		 * For now, do not optimize LSHIFT until OPINDIRECT
		 * implemented.
		 */
			case OPLSHIFT:
				new = newnode(p,lnode,rnode,NULL);
				new->rs = new;
				return(new->rs);

			case OPCOMMA:
				badop ("scantree",OPCOMMA);
				break;

			default :
				rsltnode = findnode(p,lnode,rnode);
				if (rsltnode) {
					addadup(p_parent,rsltnode);
					return(rsltnode);
				}
				else {
					new = newnode(p,lnode,rnode,NULL);
					new->rs = new;
					new->parent = p_parent;
					appendnode(new);
					return(new->rs);
				}
			}
	}
}



LOCAL prunetrees()

/* The only optcse.c routine that does any real work: go through the available
** computations stack and eliminate redundant subtrees.
*/

{
Addrp tempv;
register duplptr dl;
register valuen p;
expptr t;
int is_addrnode;
expptr *addr_tree1 = NULL ;
expptr tree2 = NULL ;

for(p=current_BB->headnode;p;p=p->next)
{
	if(p->rs == NULL) {
		if( addr_tree1 && tree2 )
		     *addr_tree1 = fixtype(mkexpr(OPCOMMA,tree2,*addr_tree1));
		addr_tree1 = (expptr*) p->opp;
		tree2 = NULL;
	}
	if (p->n_dups ) {

		if (p->opp->tag == TTEMP)
			fprintf(diagfile,"TTEMP in prunetrees - cbb\n");
		if(p->opp->tag == TADDR) is_addrnode = TRUE;
		else is_addrnode = FALSE;

		if (is_addrnode)
			tempv = mktemp(TYADDR,NULL);
		else
			tempv = mktemp(p->opp->exprblock.vtype,
			    p->opp->exprblock.vleng);
		cse2count++;

		if(tree2)
			tree2 = fixtype(mkexpr(OPCOMMA,tree2,
				fixtype(mkexpr(OPASSIGN,cpexpr(tempv),
				(is_addrnode ? addrof(p->opp) :  p->opp)
				))));
		else
			tree2 = fixtype(mkexpr(OPASSIGN,cpexpr(tempv),
				(is_addrnode ? addrof(p->opp) :  p->opp)
				));

		if(is_addrnode)
			*(p->parent) = fixtype(mkexpr(OPINDIRECT,cpexpr(tempv), NULL));
		else
			*(p->parent) = (expptr) cpexpr(tempv);

/* then replaces all future instances of the calculation by references to
   the temporary */

		for(dl=p->headduplist;dl->next;dl=dl->next) {
			cse1count++;
			frexpr(*dl->parent);
			if(is_addrnode)
				*(dl->parent) = fixtype(
					mkexpr(OPINDIRECT,cpexpr(tempv), NULL));
			else
				*(dl->parent) = (expptr) cpexpr(tempv);
		}

/* the last reference does not use a copy since the temporary can
   now be freed */

		cse1count++;
		frexpr(*dl->parent);
		if(is_addrnode)
			*(dl->parent) = fixtype(mkexpr(OPINDIRECT,tempv, NULL));
		else
			*(dl->parent) = (expptr) tempv;

		frtemp (tempv);
	}
}
if(addr_tree1 && tree2)
	*addr_tree1 = fixtype(mkexpr(OPCOMMA,tree2,*addr_tree1));
}



LOCAL rewritebb (bb)
Bblockp bb;
{
	Slotp sp;
	expptr p;

	if (bb == NULL)
		return;
	else
		current_BB = bb;
	sp = current_BB->first;

	/* loop trough all BB slots and scan candidate expr trees when found */

	for (sp = current_BB->first; ; sp = sp->next)
		{
		switch (sp->type)
		    {
		    case SKEQ :
		    case SKIFN :
		    case SKCMGOTO :
		    case SKCALL :
			newnode((expptr) &sp->expr,NULL,NULL,NULL);
			scantree(&sp->expr);
			break;

		    default  :
			break;
		    }
		if (sp == current_BB->last) break;
		}

/* use the information built up by scantree to prune reduntant subtrees */
	prunetrees();

	current_BB = NULL;
}



/*
 *  removes all instances of OPCOMMA from the given subexpression of
 *  the given buffer slot
 */

expptr rmcommaop (p,sl)
expptr	p;
Slotp	sl;

{
expptr	leftp,rightp;
chainp	cp;

if (!p)
	return (ENULL);
switch (p->tag)
	{
	case TEXPR:
		leftp = p->exprblock.leftp;
		rightp = p->exprblock.rightp;
		leftp = rmcommaop (leftp,sl);
		if (p->exprblock.opcode == OPCOMMA)
			{
			optinsert (SKEQ,leftp,0,0,sl);
			if (p->exprblock.vleng)
				free ((charptr) p->exprblock.vleng);
			free ((charptr) p);
			p = rmcommaop (rightp,sl);
			return (p);
			}
		p->exprblock.leftp = leftp;
		p->exprblock.rightp = rmcommaop (rightp,sl);
		return (p);

	case TLIST:
		for (cp = p->listblock.listp; cp; cp = cp->nextp)
			cp->datap = (tagptr) rmcommaop (cp->datap,sl);
		return (p);

	case TADDR:
		p->addrblock.memoffset = rmcommaop (p->addrblock.memoffset,sl);
		return (p);

	default:
		return (p);
	}
}



/*
 *  scans the code buffer, performing common subexpression elimination
 */

optcse ()

{
Slotp	sl;
Bblockp	bb;

if (debugflag[13])
	return;

cse1count = 0;
cse2count = 0;
for (sl = firstslot; sl; sl = sl->next)
	sl->expr = rmcommaop (sl->expr,sl);
for (bb = firstblock; bb; bb = bb->next)
	rewritebb (bb);

if (debugflag[0])
	fprintf (diagfile,
		"%d common subexpression use%s eliminated (%d definition%s)\n",
		cse1count, (cse1count==1 ? "" : "s"),
		cse2count, (cse2count==1 ? "" : "s"));
}