* Hugs version 1.4, December 1997
*
* $RCSfile: optimise.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/09 14:51:09 $
+ * $Revision: 1.5 $
+ * $Date: 1999/04/27 10:06:57 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "backend.h"
#include "connect.h"
#include "errors.h"
+#include "link.h"
+#include "Assembler.h"
+
+/* #define DEBUG_OPTIMISE */
/* --------------------------------------------------------------------------
* Local functions
* ------------------------------------------------------------------------*/
-static StgAtom optimiseAtom Args((StgAtom));
-static StgVar optimiseVar Args((StgVar));
-static StgCaseAlt optimiseAlt Args((StgCaseAlt));
-static StgPrimAlt optimisePrimAlt Args((StgPrimAlt));
-static StgExpr optimiseExpr Args((StgExpr));
+Int nLoopBreakersInlined;
+Int nLetvarsInlined;
+Int nTopvarsInlined;
+Int nCaseOfLet;
+Int nCaseOfCase;
+Int nCaseOfPrimCase;
+Int nCaseOfCon;
+Int nCaseOfOuter;
+Int nLetBindsDropped;
+Int nLetrecGroupsDropped;
+Int nLambdasMerged;
+Int nCaseDefaultsDropped;
+Int nAppsMerged;
+Int nLetsFloatedOutOfFn;
+Int nLetsFloatedIntoCase;
+Int nCasesFloatedOutOfFn;
+Int nBetaReductions;
+
+Int nTotSizeIn;
+Int nTotSizeOut;
+
+Int rDepth;
+Bool copyInTopvar;
+Bool inDBuilder;
+
+static void local optimiseTopBind( StgVar v );
+
+typedef
+ enum {
+ CTX_SCRUT,
+ CTX_OTHER
+ }
+ InlineCtx;
+
+/* Exactly like whatIs except it avoids a fn call for STG tags */
+#define whatIsStg(xx) ((isPair(xx) ? (isTag(fst(xx)) ? fst(xx) : AP) : whatIs(xx)))
+
/* --------------------------------------------------------------------------
- * A simple optimiser
+ * Transformation stats
* ------------------------------------------------------------------------*/
-static StgAtom optimiseAtom(StgAtom a)
+void initOptStats ( void )
{
- switch (whatIs(a)) {
- case STGVAR:
- return optimiseVar(a);
- /* Note that NAMEs have no free vars. */
- default:
- return a;
- }
+ nLoopBreakersInlined = 0;
+ nLetvarsInlined = 0;
+ nTopvarsInlined = 0;
+ nCaseOfLet = 0;
+ nCaseOfCase = 0;
+ nCaseOfPrimCase = 0;
+ nCaseOfCon = 0;
+ nCaseOfOuter = 0;
+ nLetBindsDropped = 0;
+ nLetrecGroupsDropped = 0;
+ nLambdasMerged = 0;
+ nCaseDefaultsDropped = 0;
+ nAppsMerged = 0;
+ nLetsFloatedOutOfFn = 0;
+ nLetsFloatedIntoCase = 0;
+ nCasesFloatedOutOfFn = 0;
+ nBetaReductions = 0;
+ nTotSizeIn = 0;
+ nTotSizeOut = 0;
+}
+
+void printOptStats ( FILE* f )
+{
+ fflush(stdout); fflush(stderr); fflush(f);
+ fprintf(f, "\n\n" );
+ fprintf(f, "Inlining: topvar %-5d letvar %-5d"
+ " loopbrkr %-5d betaredn %-5d\n",
+ nTopvarsInlined, nLetvarsInlined, nLoopBreakersInlined,
+ nBetaReductions );
+ fprintf(f, "Case-of-: let %-5d case %-5d"
+ " con %-5d case# %-5d\n",
+ nCaseOfLet, nCaseOfCase, nCaseOfCon, nCaseOfPrimCase );
+ fprintf(f, "Dropped: letbind %-5d letgroup %-5d"
+ " default %-5d\n",
+ nLetBindsDropped, nLetrecGroupsDropped, nCaseDefaultsDropped );
+ fprintf(f, "Merges: lambda %-5d app %-5d\n",
+ nLambdasMerged, nAppsMerged );
+ fprintf(f, "Fn-float: let %-5d case %-5d\n",
+ nLetsFloatedOutOfFn, nCasesFloatedOutOfFn );
+ fprintf(f, "Misc: case-outer %-5d let-into-case %-5d\n",
+ nCaseOfOuter, nLetsFloatedIntoCase );
+ fprintf(f, "total size: in %-5d out %-5d\n",
+ nTotSizeIn, nTotSizeOut );
+ fprintf(f, "\n" );
+}
+
+
+/* --------------------------------------------------------------------------
+ * How big is this STG tree (viz (primarily), do I want to inline it?)
+ * ------------------------------------------------------------------------*/
+
+Int stgSize_list ( List es )
+{
+ Int n = 0;
+ for (; nonNull(es); es=tl(es)) n += stgSize(hd(es));
+ return n;
+}
+
+Int stgSize ( StgExpr e )
+{
+ List xs;
+ Int n = 1;
+
+ if (isNull(e)) return 0;
+
+ switch(whatIsStg(e)) {
+ case STGVAR:
+ break;
+ case LETREC:
+ for (xs = stgLetBinds(e); nonNull(xs);xs=tl(xs))
+ n += stgSize(stgVarBody(hd(xs)));
+ n += stgSize(stgLetBody(e));
+ break;
+ case LAMBDA:
+ n += stgSize(stgLambdaBody(e));
+ break;
+ case CASE:
+ n += stgSize_list(stgCaseAlts(e));
+ n += stgSize(stgCaseScrut(e));
+ break;
+ case PRIMCASE:
+ n += stgSize_list(stgPrimCaseAlts(e));
+ n += stgSize(stgPrimCaseScrut(e));
+ break;
+ case STGAPP:
+ n += stgSize_list(stgAppArgs(e));
+ n += stgSize(stgAppFun(e));
+ break;
+ case STGPRIM:
+ n += stgSize_list(stgPrimArgs(e));
+ n += stgSize(stgPrimOp(e));
+ break;
+ case STGCON:
+ n += stgSize_list(stgConArgs(e));
+ n += stgSize(stgConCon(e));
+ break;
+ case DEEFALT:
+ n = stgSize(stgDefaultBody(e));
+ break;
+ case CASEALT:
+ n = stgSize(stgCaseAltBody(e));
+ break;
+ case PRIMALT:
+ n = stgSize(stgPrimAltBody(e));
+ break;
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ case BIGCELL:
+ case NAME:
+ case TUPLE:
+ break;
+ default:
+ fprintf(stderr, "sizeStg: unknown stuff %d\n",whatIsStg(e));
+ assert(0);
+ }
+ return n;
+}
+
+
+/* --------------------------------------------------------------------------
+ * Stacks of pairs of collectable things. Used to implement associations.
+ * cloneStg() uses its stack to map old var names to new ones.
+ * ------------------------------------------------------------------------*/
+
+#define M_PAIRS 400
+#define SP_NOT_IN_USE (-123456789)
+
+typedef
+ struct { Cell pfst; Cell psnd; }
+ StgPair;
+
+static Int spClone;
+static StgPair pairClone[M_PAIRS];
+
+void markPairs ( void )
+{
+ Int i;
+ if (spClone != SP_NOT_IN_USE) {
+ for (i = 0; i <= spClone; i++) {
+ mark(pairClone[i].pfst);
+ mark(pairClone[i].psnd);
+ }
+ }
+}
+
+void pushClone ( Cell a, Cell b )
+{
+ spClone++;
+ if (spClone >= M_PAIRS) internal("pushClone -- M_PAIRS too small");
+ pairClone[spClone].pfst = a;
+ pairClone[spClone].psnd = b;
+}
+
+void dropClone ( void )
+{
+ if (spClone < 0) internal("dropClone");
+ spClone--;
+}
+
+Cell findClone ( Cell x )
+{
+ Int i;
+ for (i = spClone; i >= 0; i--)
+ if (pairClone[i].pfst == x)
+ return pairClone[i].psnd;
+ return NIL;
+}
+
+
+/* --------------------------------------------------------------------------
+ * Cloning of STG trees
+ * ------------------------------------------------------------------------*/
+
+/* Clone v to create a new var. Works for both StgVar and StgPrimVar. */
+StgVar cloneStgVar ( StgVar v )
+{
+ return ap(STGVAR,triple(stgVarBody(v),stgVarRep(v),NIL));
}
-static StgVar optimiseVar(StgVar v)
+
+/* For each StgVar in origVars, make a new one with cloneStgVar,
+ and push the (old,new) pair on the clone pair stack. Returns
+ the list of new vars.
+*/
+List cloneStg_addVars ( List origVars )
+{
+ List newVars = NIL;
+ while (nonNull(origVars)) {
+ StgVar newv = cloneStgVar(hd(origVars));
+ pushClone ( hd(origVars), newv );
+ newVars = cons(newv,newVars);
+ origVars = tl(origVars);
+ }
+ newVars = rev(newVars);
+ return newVars;
+}
+
+
+void cloneStg_dropVars ( List vs )
+{
+ for (; nonNull(vs); vs=tl(vs))
+ dropClone();
+}
+
+
+/* Print the clone pair stack. Just for debugging purposes. */
+void ppCloneEnv ( char* s )
+{
+ Int i;
+ fflush(stdout);fflush(stderr);
+ printf ( "\nenv-%s\n", s );
+ for (i = 0; i <= spClone; i++) {
+ printf ( "\t" );
+ ppStgExpr(pairClone[i].pfst);
+ ppStgExpr(pairClone[i].psnd);
+ printf ( "\n" );
+ };
+ printf ( "vne-%s\n", s );
+}
+
+
+StgExpr cloneStg ( StgExpr e )
{
- StgRhs rhs = stgVarBody(v);
-fprintf(stderr,"optimiseVar ");printStg(stderr,v);fprintf(stderr,"\n");
- /* short circuit: let x = y in ...x... --> let x = y in ...y... */
- if (whatIs(rhs) == STGVAR && rhs != v) {
- StgVar v1 = rhs;
-fprintf(stderr, "dumpable\n");
+ List xs, newvs;
+ StgVar newv;
+ StgExpr t;
- /* find last variable in chain */
- rhs = stgVarBody(v1);
- while (whatIs(rhs) == STGVAR
- && rhs != v /* infinite loop */
- ) {
- v1 = rhs;
- rhs = stgVarBody(rhs);
- }
+ switch(whatIsStg(e)) {
+ case STGVAR:
+ newv = findClone(e);
+ if (nonNull(newv)) return newv; else return e;
+ case LETREC:
+ newvs = cloneStg_addVars ( stgLetBinds(e) );
+ for (xs = newvs; nonNull(xs);xs=tl(xs))
+ stgVarBody(hd(xs)) = cloneStg(stgVarBody(hd(xs)));
+ t = mkStgLet(newvs,cloneStg(stgLetBody(e)));
+ cloneStg_dropVars ( stgLetBinds(e) );
+ return t;
+ case LAMBDA:
+ newvs = cloneStg_addVars ( stgLambdaArgs(e) );
+ t = mkStgLambda(newvs, cloneStg(stgLambdaBody(e)));
+ cloneStg_dropVars ( stgLambdaArgs(e) );
+ return t;
+ case CASE:
+ xs = dupList(stgCaseAlts(e));
+ mapOver(cloneStg,xs);
+ return mkStgCase(cloneStg(stgCaseScrut(e)),xs);
+ case PRIMCASE:
+ xs = dupList(stgPrimCaseAlts(e));
+ mapOver(cloneStg,xs);
+ return mkStgPrimCase(cloneStg(stgPrimCaseScrut(e)),xs);
+ case STGAPP:
+ xs = dupList(stgAppArgs(e));
+ mapOver(cloneStg,xs);
+ return mkStgApp(cloneStg(stgAppFun(e)),xs);
+ case STGPRIM:
+ xs = dupList(stgPrimArgs(e));
+ mapOver(cloneStg,xs);
+ return mkStgPrim(cloneStg(stgPrimOp(e)),xs);
+ case STGCON:
+ xs = dupList(stgConArgs(e));
+ mapOver(cloneStg,xs);
+ return mkStgCon(cloneStg(stgConCon(e)),xs);
+ case DEEFALT:
+ newv = cloneStgVar(stgDefaultVar(e));
+ pushClone ( stgDefaultVar(e), newv );
+ t = mkStgDefault(newv,cloneStg(stgDefaultBody(e)));
+ dropClone();
+ return t;
+ case CASEALT:
+ newvs = cloneStg_addVars ( stgCaseAltVars(e) );
+ t = mkStgCaseAlt(stgCaseAltCon(e),newvs,
+ cloneStg(stgCaseAltBody(e)));
+ cloneStg_dropVars ( stgCaseAltVars(e) );
+ return t;
+ case PRIMALT:
+ newvs = cloneStg_addVars ( stgPrimAltVars(e) );
+ t = mkStgPrimAlt(newvs, cloneStg(stgPrimAltBody(e)));
+ cloneStg_dropVars ( stgPrimAltVars(e) );
+ return t;
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case BIGCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ case NAME:
+ case TUPLE:
+ return e;
+ default:
+ fprintf(stderr, "cloneStg: unknown stuff %d\n",whatIsStg(e));
+ assert(0);
+ }
+}
+
+
+/* Main entry point. Checks against re-entrant use. */
+StgExpr cloneStgTop ( StgExpr e )
+{
+ StgExpr res;
+ if (spClone != SP_NOT_IN_USE)
+ internal("cloneStgTop");
+ spClone = -1;
+ res = cloneStg ( e );
+ assert(spClone == -1);
+ spClone = SP_NOT_IN_USE;
+ return res;
+}
+
+
+
+/* --------------------------------------------------------------------------
+ * Sets of StgVars, used by the strongly-connected-components machinery.
+ * Represented as an array of variables. The vars
+ * must be in strictly nondecreasing order. Each value may appear
+ * more than once, so as to make deletion relatively cheap.
+
+ * After a garbage collection happens, the values may have changed,
+ * so the array will need to be sorted.
+
+ * Using a binary search, membership costs O(log N). Union and
+ * intersection cost O(N + M). Deletion of a single element costs
+ * O(N) in the worst case, although if it happens infrequently
+ * compared to the other ops, it should asymptotically approach O(1).
+ * ------------------------------------------------------------------------*/
+
+#define M_VAR_SETS 4000
+#define MIN_VAR_SET_SIZE 4
+#define M_UNION_TMP 20000
+
+typedef
+ struct {
+ Int nextfree;
+ Bool inUse;
+ Int size;
+ Int used;
+ Cell* vs;
+ }
+ StgVarSetRec;
+
+typedef Int StgVarSet;
+
+StgVarSetRec varSet[M_VAR_SETS];
+Int varSet_nfree;
+Int varSet_nextfree;
+Cell union_tmp[M_UNION_TMP];
+
+#if 0 /* unused since unnecessary */
+/* Shellsort set elems to restore representation invariants */
+static Int shellCells_incs[10]
+ = { 1, 4, 13, 40, 121, 364, 1093, 3280, 9841, 29524 };
+static void shellCells ( Cell* a, Int lo, Int hi )
+{
+ Int i, j, h, N, hp;
+ Cell v;
+
+ N = hi - lo + 1; if (N < 2) return;
+ hp = 0;
+ while (hp < 10 && shellCells_incs[hp] < N) hp++; hp--;
+
+ for (; hp >= 0; hp--) {
+ h = shellCells_incs[hp];
+ i = lo + h;
+ while (1) {
+ if (i > hi) break;
+ v = a[i];
+ j = i;
+ while (a[j-h] > v) {
+ a[j] = a[j-h]; j = j - h;
+ if (j <= (lo + h - 1)) break;
+ }
+ a[j] = v; i++;
+ }
+ }
+}
+#endif
+
+/* check that representation invariant still holds */
+static void checkCells ( Cell* a, Int lo, Int hi )
+{
+ Int i;
+ for (i = lo; i < hi; i++)
+ if (a[i] > a[i+1])
+ internal("checkCells");
+}
+
+
+/* Mark set contents for GC */
+void markStgVarSets ( void )
+{
+ Int i, j;
+ for (i = 0; i < M_VAR_SETS; i++)
+ if (varSet[i].inUse)
+ for (j = 0; j < varSet[i].used; j++)
+ mark(varSet[i].vs[j]);
+}
+
+
+/* Check representation invariants after GC */
+void checkStgVarSets ( void )
+{
+ Int i;
+ for (i = 0; i < M_VAR_SETS; i++)
+ if (varSet[i].inUse)
+ checkCells ( varSet[i].vs, 0, varSet[i].used-1 );
+}
+
+
+/* Allocate a set of a given size */
+StgVarSet allocStgVarSet ( Int size )
+{
+ Int i, j;
+ if (varSet_nextfree == -1)
+ internal("allocStgVarSet -- run out of var sets");
+ i = varSet_nextfree;
+ varSet_nextfree = varSet[i].nextfree;
+ varSet[i].inUse = TRUE;
+ j = MIN_VAR_SET_SIZE;
+ while (j <= size) j *= 2;
+ varSet[i].used = 0;
+ varSet[i].size = j;
+ varSet[i].vs = malloc(j * sizeof(StgVar) );
+ if (!varSet[i].vs)
+ internal("allocStgVarSet -- can't malloc memory");
+ varSet_nfree--;
+ return i;
+}
- /* Make all variables in chain point to v1
- * This makes sure we always resolve cycles the same way
- * as well as making things faster if we call optimiseVar again
+
+/* resize (upwards) */
+void resizeStgVarSet ( StgVarSet s, Int size )
+{
+ Cell* tmp;
+ Cell* tmp2;
+ Int i;
+ Int j = MIN_VAR_SET_SIZE;
+ while (j <= size) j *= 2;
+ if (j < varSet[s].size) return;
+ tmp = varSet[s].vs;
+ tmp2 = malloc( j * sizeof(StgVar) );
+ if (!tmp2) internal("resizeStgVarSet -- can't malloc memory");
+ varSet[s].vs = tmp2;
+ for (i = 0; i < varSet[s].used; i++)
+ tmp2[i] = tmp[i];
+ free(tmp);
+}
+
+
+/* Deallocation ... */
+void freeStgVarSet ( StgVarSet s )
+{
+ if (s < 0 || s >= M_VAR_SETS ||
+ !varSet[s].inUse || !varSet[s].vs)
+ internal("freeStgVarSet");
+ free(varSet[s].vs);
+ varSet[s].inUse = FALSE;
+ varSet[s].vs = NULL;
+ varSet[s].nextfree = varSet_nextfree;
+ varSet_nextfree = s;
+ varSet_nfree++;
+}
+
+
+/* Initialisation */
+void initStgVarSets ( void )
+{
+ Int i;
+ for (i = M_VAR_SETS-1; i >= 0; i--) {
+ varSet[i].inUse = FALSE;
+ varSet[i].vs = NULL;
+ varSet[i].nextfree = i+1;
+ }
+ varSet[M_VAR_SETS-1].nextfree = -1;
+ varSet_nextfree = 0;
+ varSet_nfree = M_VAR_SETS;
+}
+
+
+/* Find a var using binary search */
+Int findInStgVarSet ( StgVarSet s, StgVar v )
+{
+ Int lo, mid, hi;
+ lo = 0;
+ hi = varSet[s].used-1;
+ while (1) {
+ if (lo > hi) return -1;
+ mid = (hi+lo)/2;
+ if (varSet[s].vs[mid] == v) return mid;
+ if (varSet[s].vs[mid] < v) lo = mid+1; else hi = mid-1;
+ }
+}
+
+
+Bool elemStgVarSet ( StgVarSet s, StgVar v )
+{
+ return findInStgVarSet(s,v) != -1;
+}
+
+void ppSet ( StgVarSet s )
+{
+ Int i;
+ fprintf(stderr, "{ ");
+ for (i = 0; i < varSet[s].used; i++)
+ fprintf(stderr, "%d ", varSet[s].vs[i] );
+ fprintf(stderr, "}\n" );
+}
+
+
+void deleteFromStgVarSet ( StgVarSet s, StgVar v )
+{
+ Int i, j;
+ i = findInStgVarSet(s,v);
+ if (i == -1) return;
+ j = varSet[s].used-1;
+ for (; i < j; i++) varSet[s].vs[i] = varSet[s].vs[i+1];
+ varSet[s].used--;
+}
+
+
+void singletonStgVarSet ( StgVarSet s, StgVar v )
+{
+ varSet[s].used = 1;
+ varSet[s].vs[0] = v;
+}
+
+
+void emptyStgVarSet ( StgVarSet s )
+{
+ varSet[s].used = 0;
+}
+
+
+void copyStgVarSets ( StgVarSet dst, StgVarSet src )
+{
+ Int i;
+ varSet[dst].used = varSet[src].used;
+ for (i = 0; i < varSet[dst].used; i++)
+ varSet[dst].vs[i] = varSet[src].vs[i];
+}
+
+
+Int sizeofVarSet ( StgVarSet s )
+{
+ return varSet[s].used;
+}
+
+
+void unionStgVarSets ( StgVarSet dst, StgVarSet src )
+{
+ StgVar v1;
+ Int pd, ps, i, res_used, tmp_used, dst_used, src_used;
+ StgVar* dst_vs;
+ StgVar* src_vs;
+ StgVar* tmp_vs;
+
+ dst_vs = varSet[dst].vs;
+
+ /* fast track a common (~ 50%) case */
+ if (varSet[src].used == 1) {
+ v1 = varSet[src].vs[0];
+ pd = findInStgVarSet(dst,v1);
+ if (pd != -1) return;
+ if (varSet[dst].used < varSet[dst].size) {
+ i = varSet[dst].used;
+ while (i > 0 && dst_vs[i-1] > v1) {
+ dst_vs[i] = dst_vs[i-1];
+ i--;
+ }
+ dst_vs[i] = v1;
+ varSet[dst].used++;
+ return;
+ }
+ }
+
+ res_used = varSet[dst].used + varSet[src].used;
+ if (res_used > M_UNION_TMP)
+ internal("unionStgVarSets -- M_UNION_TMP too small");
+
+ resizeStgVarSet(dst,res_used);
+ dst_vs = varSet[dst].vs;
+ src_vs = varSet[src].vs;
+ tmp_vs = union_tmp;
+ tmp_used = 0;
+ dst_used = varSet[dst].used;
+ src_used = varSet[src].used;
+
+ /* merge the two sets into tmp */
+ pd = ps = 0;
+ while (pd < dst_used || ps < src_used) {
+ if (pd == dst_used)
+ tmp_vs[tmp_used++] = src_vs[ps++];
+ else
+ if (ps == src_used)
+ tmp_vs[tmp_used++] = dst_vs[pd++];
+ else {
+ StgVar vald = dst_vs[pd];
+ StgVar vals = src_vs[ps];
+ if (vald < vals)
+ tmp_vs[tmp_used++] = vald, pd++;
+ else
+ if (vald > vals)
+ tmp_vs[tmp_used++] = vals, ps++;
+ else
+ tmp_vs[tmp_used++] = vals, ps++, pd++;
+ }
+ }
+
+ /* copy setTmp back to dst */
+ varSet[dst].used = tmp_used;
+ for (i = 0; i < tmp_used; i++) {
+ dst_vs[i] = tmp_vs[i];
+ }
+}
+
+
+
+/* --------------------------------------------------------------------------
+ * Strongly-connected-components machinery for STG let bindings.
+ * Arranges let bindings in minimal mutually recursive groups, and
+ * then throws away any groups not referred to in the body of the let.
+ *
+ * How it works: does a bottom-up sweep of the tree. Each call returns
+ * the set of variables free in the tree. All nodes except LETREC are
+ * boring.
+ *
+ * When 'let v1=e1 .. vn=en in e' is encountered:
+ * -- recursively make a call on e. This returns fvs(e) and scc-ifies
+ * inside e as well.
+ * -- do recursive calls for e1 .. en too, giving fvs(e1) ... fvs(en).
+ *
+ * Then, using fvs(e1) ... fvs(en), the dependancy graph for v1 ... vn
+ * can be cheaply computed. Using that, compute the strong components
+ * and rearrange the let binding accordingly.
+ * Finally, for each of the strong components, we can use fvs(en) to
+ * cheaply determine if the component is used in the body of the let,
+ * and if not, it can be omitted.
+ *
+ * oaScc destructively modifies the tree -- when it gets to a let --
+ * we need to pass the address of the expression to scc, not the
+ * (more usual) heap index of it.
+ *
+ * The main requirement of this algorithm is an efficient implementation
+ * of sets of variables. Because there is no name shadowing in these
+ * trees, either mentioned-sets or free-sets would be ok, although
+ * free sets are presumably smaller.
+ * ------------------------------------------------------------------------*/
+
+
+#define SCC stgScc /* make scc algorithm for StgVars */
+#define LOWLINK stgLowlink
+#define DEPENDS(t) thd3(t)
+#define SETDEPENDS(c,v) thd3(c)=v
+#include "scc.c"
+#undef SETDEPENDS
+#undef DEPENDS
+#undef LOWLINK
+#undef SCC
+
+
+StgVarSet oaScc ( StgExpr* e_orig )
+{
+ Bool grpUsed;
+ StgExpr e;
+ StgVarSet e_fvs, s1, s2;
+ List bs, bs2, bs3, bsFinal, augs, augsL;
+
+ bs=bs2=bs3=bsFinal=augs=augsL=e_fvs=s1=s2=e=NIL;
+ grpUsed=FALSE;
+
+ e = *e_orig;
+
+ //fprintf(stderr,"\n==================\n");
+ //ppStgExpr(*e_orig);
+ //fprintf(stderr,"\n\n");fflush(stderr);fflush(stdout);
+
+
+ switch(whatIsStg(e)) {
+ case LETREC:
+ /* first, recurse into the let body */
+ e_fvs = oaScc(&stgLetBody(*e_orig));
+
+ /* Make bs :: [StgVar] and e :: Stgexpr. */
+ bs = stgLetBinds(e);
+ e = stgLetBody(e);
+
+ /* make augs :: [(StgVar,fvs(bindee),NIL)] */
+ augs = NIL;
+ for (; nonNull(bs); bs=tl(bs)) {
+ StgVarSet fvs_bindee = oaScc(&stgVarBody(hd(bs)));
+ augs = cons( triple(hd(bs),mkInt(fvs_bindee),NIL), augs );
+ }
+
+ bs2=bs3=bsFinal=augsL=s1=s2=NIL;
+
+ /* In each of the triples in aug, replace the NIL field with
+ a list of the let-bound vars appearing in the bindee.
+ ie, construct the adjacency list for the graph.
+ giving
+ augs :: [(StgVar,fvs(bindee),[pointers-back-to-this-list-of-pairs])]
+ */
+ for (bs=augs;nonNull(bs);bs=tl(bs)) {
+ augsL = NIL;
+ for (bs2=augs;nonNull(bs2);bs2=tl(bs2))
+ if (elemStgVarSet( intOf(snd3(hd(bs))), fst3(hd(bs2)) ))
+ augsL = cons(hd(bs2),augsL);
+ thd3(hd(bs)) = augsL;
+ }
+
+ bs2=bs3=bsFinal=augsL=s1=s2=NIL;
+
+ /* Do the Biz.
+ augs becomes :: [[(StgVar,fvs(bindee),aux_info_field)]] */
+ augs = stgScc(augs);
+
+ /* work backwards through augs, reconstructing the expression,
+ dumping any unused groups as you go.
*/
- while (v != v1) {
- StgRhs r = stgVarBody(v);
- assert(whatIs(r) == STGVAR);
- stgVarBody(v) = v1;
- v = r;
- }
- return v1;
- }
- return v;
+ bsFinal = NIL;
+ for (augs=rev(augs); nonNull(augs); augs=tl(augs)) {
+ bs2 = NIL;
+ for (augsL=hd(augs);nonNull(augsL); augsL=tl(augsL))
+ bs2 = cons(fst3(hd(augsL)),bs2);
+ grpUsed = FALSE;
+ for (bs3=bs2;nonNull(bs3);bs3=tl(bs3))
+ if (elemStgVarSet(e_fvs,hd(bs3))) { grpUsed=TRUE; break; }
+ if (grpUsed) {
+ //e = mkStgLet(bs2,e);
+ bsFinal = dupOnto(bs2,bsFinal);
+ for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) {
+ unionStgVarSets(e_fvs, intOf(snd3(hd(augsL))) );
+ freeStgVarSet(intOf(snd3(hd(augsL))));
+ }
+ } else {
+ nLetrecGroupsDropped++;
+ for (augsL=hd(augs);nonNull(augsL);augsL=tl(augsL)) {
+ freeStgVarSet(intOf(snd3(hd(augsL))));
+ }
+ }
+ }
+ //*e_orig = e;
+ *e_orig = mkStgLet(bsFinal,e);
+ return e_fvs;
+
+ case LAMBDA:
+ s1 = oaScc(&stgLambdaBody(e));
+ for (bs=stgLambdaArgs(e);nonNull(bs);bs=tl(bs))
+ deleteFromStgVarSet(s1,hd(bs));
+ return s1;
+ case CASE:
+ s1 = oaScc(&stgCaseScrut(e));
+ for (bs=stgCaseAlts(e);nonNull(bs);bs=tl(bs)) {
+ s2 = oaScc(&hd(bs));
+ unionStgVarSets(s1,s2);
+ freeStgVarSet(s2);
+ }
+ return s1;
+ case PRIMCASE:
+ s1 = oaScc(&stgPrimCaseScrut(e));
+ for (bs=stgPrimCaseAlts(e);nonNull(bs);bs=tl(bs)) {
+ s2 = oaScc(&hd(bs));
+ unionStgVarSets(s1,s2);
+ freeStgVarSet(s2);
+ }
+ return s1;
+ case STGAPP:
+ s1 = oaScc(&stgAppFun(e));
+ for (bs=stgAppArgs(e);nonNull(bs);bs=tl(bs)) {
+ s2 = oaScc(&hd(bs));
+ unionStgVarSets(s1,s2);
+ freeStgVarSet(s2);
+ }
+ return s1;
+ case STGPRIM:
+ s1 = oaScc(&stgPrimOp(e));
+ for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) {
+ s2 = oaScc(&hd(bs));
+ unionStgVarSets(s1,s2);
+ freeStgVarSet(s2);
+ }
+ return s1;
+ case STGCON:
+ s1 = allocStgVarSet(0);
+ for (bs=stgPrimArgs(e);nonNull(bs);bs=tl(bs)) {
+ s2 = oaScc(&hd(bs));
+ unionStgVarSets(s1,s2);
+ freeStgVarSet(s2);
+ }
+ return s1;
+ case CASEALT:
+ s1 = oaScc(&stgCaseAltBody(e));
+ for (bs=stgCaseAltVars(e);nonNull(bs);bs=tl(bs))
+ deleteFromStgVarSet(s1,hd(bs));
+ return s1;
+ case DEEFALT:
+ s1 = oaScc(&stgDefaultBody(e));
+ deleteFromStgVarSet(s1,stgDefaultVar(e));
+ return s1;
+ case PRIMALT:
+ s1 = oaScc(&stgPrimAltBody(e));
+ for (bs=stgPrimAltVars(e);nonNull(bs);bs=tl(bs))
+ deleteFromStgVarSet(s1,hd(bs));
+ return s1;
+ case STGVAR:
+ s1 = allocStgVarSet(1);
+ singletonStgVarSet(s1,e);
+ return s1;
+ case NAME:
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case BIGCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ return allocStgVarSet(0);
+ break;
+ default:
+ fprintf(stderr, "oaScc: unknown stuff %d\n",whatIsStg(e));
+ assert(0);
+ }
}
-void optimiseBind( StgVar v )
+
+
+/* --------------------------------------------------------------------------
+ * Occurrence analyser. Marks each let-bound var with the number of times
+ * it is used, or some number >= OCC_IN_LAMBDA if it is used inside a lambda.
+ *
+ * Firstly, oaPre traverses the tree, attaching a mutable INT cell to each
+ * let bound var, and NIL-ing the counts on all other vars.
+ *
+ * Then oaCount traveses the tree. Because variables are represented by
+ * pointers in the heap, we can just increment the count field of each
+ * variable we see. However, to deal with lambdas, the Hugs stack holds
+ * all let-bound variables currently in scope, and the uppermost portion
+ * of the stack, stack(spBase .. sp) inclusive, denotes the variables
+ * introduced into scope since the nearest enclosing lambda. When a
+ * let-bound var is seen, we search stack(spBase .. sp). If it appears
+ * there, no lambda exists between the binding site and this usage of the
+ * var, so we can safely increment its use. Otherwise, we must set it to
+ * OCC_IN_LAMBDA.
+ *
+ * When passing a lambda, spBase is set to sp+1, so as to effectively
+ * empty the set of vars-bound-since-the-latest-lambda.
+ *
+ * Because oaPre pre-annotates the tree with mutable INT cells, oaCount
+ * doesn't allocate any heap at all.
+ * ------------------------------------------------------------------------*/
+
+static int spBase;
+
+
+#define OCC_IN_LAMBDA 50 /* any number > 1 will do */
+#define nullCount(vv) stgVarInfo(vv)=NIL
+#define nullCounts(vvs) { List tt=(vvs);for(;nonNull(tt);tt=tl(tt)) nullCount(hd(tt));}
+
+
+
+void oaPre ( StgExpr e )
{
- StgRhs rhs;
- rhs = stgVarBody(v);
- switch (whatIs(rhs)) {
- case STGCON:
- mapOver(optimiseAtom,stgConArgs(rhs));
- break;
- default:
- stgVarBody(v) = optimiseExpr(rhs);
- break;
- }
+ List bs;
+ switch(whatIsStg(e)) {
+ case LETREC:
+ for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
+ stgVarInfo(hd(bs)) = mkInt(0);
+ for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
+ oaPre(stgVarBody(hd(bs)));
+ oaPre(stgLetBody(e));
+ break;
+ case LAMBDA:
+ nullCounts(stgLambdaArgs(e));
+ oaPre(stgLambdaBody(e));
+ break;
+ case CASE:
+ oaPre(stgCaseScrut(e));
+ mapProc(oaPre,stgCaseAlts(e));
+ break;
+ case PRIMCASE:
+ oaPre(stgPrimCaseScrut(e));
+ mapProc(oaPre,stgPrimCaseAlts(e));
+ break;
+ case STGAPP:
+ oaPre(stgAppFun(e));
+ mapProc(oaPre,stgAppArgs(e));
+ break;
+ case STGPRIM:
+ mapProc(oaPre,stgPrimArgs(e));
+ break;
+ case STGCON:
+ mapProc(oaPre,stgConArgs(e));
+ break;
+ case CASEALT:
+ nullCounts(stgCaseAltVars(e));
+ oaPre(stgCaseAltBody(e));
+ break;
+ case DEEFALT:
+ nullCount(stgDefaultVar(e));
+ oaPre(stgDefaultBody(e));
+ break;
+ case PRIMALT:
+ nullCounts(stgPrimAltVars(e));
+ oaPre(stgPrimAltBody(e));
+ break;
+ case STGVAR:
+ case NAME:
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case BIGCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ break;
+ default:
+ fprintf(stderr, "oaPre: unknown stuff %d\n",whatIsStg(e));
+ assert(0);
+ }
}
-static StgCaseAlt optimiseAlt( StgCaseAlt alt )
-{
- /* StgPat pat = stgCaseAltPat(alt); */
- stgCaseAltBody(alt) = optimiseExpr(stgCaseAltBody(alt));
- return alt;
-}
-
-static StgPrimAlt optimisePrimAlt( StgPrimAlt alt )
-{
- /* List vs = stgPrimAltPats(alt); */
- stgPrimAltBody(alt) = optimiseExpr(stgPrimAltBody(alt));
- return alt;
-}
-
-static StgExpr optimiseExpr( StgExpr e )
-{
- switch (whatIs(e)) {
- case LETREC:
- {
- List binds = stgLetBinds(e);
- {
- /* First we filter out trivial bindings.
- * this has to be done before optimising the individual
- * bindings so that we don't get confused by the results
- * of other optimisations.
- */
- List bs = binds;
- binds = NIL;
- for(; nonNull(bs); bs=tl(bs)) {
- StgVar b = optimiseVar(hd(bs));
- StgRhs rhs = stgVarBody(b);
- if (whatIs(rhs) == STGVAR && b != rhs) {
- /* This variable will be short-circuited
- * by optimiseVar so we can drop the binding
- * right now.
- */
-fprintf(stderr, "dropping bind ");printStg(stderr,b);fprintf(stderr, "\n");
- } else {
-fprintf(stderr, "retaining bind ");printStg(stderr,b);fprintf(stderr, "\n");
- binds = cons(hd(bs),binds);
- }
- }
- binds = rev(binds); /* preserve original order */
- }
- stgLetBody(e) = optimiseExpr(stgLetBody(e));
- if (isNull(binds)) {
- return stgLetBody(e);
- } else {
- mapProc(optimiseBind,binds);
- stgLetBinds(e) = binds;
- }
- break;
- }
- case LAMBDA:
- stgLambdaBody(e) = optimiseExpr(stgLambdaBody(e));
- break;
- case CASE:
- {
- StgExpr scrut = optimiseExpr(stgCaseScrut(e));
- StgExpr alts = stgCaseAlts(e);
- if (whatIs(scrut) == STGVAR
- && whatIs(stgVarBody(scrut)) == STGCON
- ) {
- StgRhs rhs = stgVarBody(scrut);
- StgDiscr d = stgConCon(rhs);
- List args = stgConArgs(rhs);
- for(; nonNull(alts); alts=tl(alts)) {
- StgCaseAlt alt = hd(alts);
- StgPat pat = stgCaseAltPat(alt);
- if (isDefaultPat(pat)) { /* the easy case */
- StgExpr body = stgCaseAltBody(alt);
- stgVarBody(pat) = rhs;
- return optimiseExpr(body);
- } else if (stgPatDiscr(pat) == d) {
- /* The tricky case:
- * rebind all the pattern args to the con args
- * and rebind the pattern var to con
- * and run optimiser (to eliminate the binding)
- */
- StgExpr body = stgCaseAltBody(alt);
- List binds = stgPatVars(pat);
- {
- List vs = binds;
- for(;
- nonNull(vs) && nonNull(args);
- vs = tl(vs), args=tl(args)
- ) {
- stgVarBody(hd(vs)) = hd(args);
- }
- }
- binds = cons(pat,binds); /* turn patvar into a var! */
- stgVarBody(pat) = rhs;
-
- /* This letrec will always be optimised away */
- body = makeStgLet(binds,body);
- return optimiseExpr(body);
- }
- }
- internal("optimiseExpr: no patterns matched");
- }
- stgCaseScrut(e) = scrut;
- mapOver(optimiseAlt,alts);
- break;
- }
- case PRIMCASE:
- mapOver(optimisePrimAlt,stgPrimCaseAlts(e));
- stgPrimCaseScrut(e) = optimiseExpr(stgPrimCaseScrut(e));
- break;
- case STGPRIM:
- mapOver(optimiseAtom,stgPrimArgs(e));
- /* primop is not a var */
- break;
- case STGAPP:
- stgAppFun(e) = optimiseExpr(stgAppFun(e));
- mapOver(optimiseAtom,stgAppArgs(e));
- break;
- case STGVAR:
- return optimiseVar(e);
- case NAME:
- break; /* Names are never free vars */
- default:
- internal("optimiseExpr");
- }
- return e;
+
+/* In oaCount:
+ -- the stack is always the set of let-bound vars currently
+ in scope. viz, stack(0 .. sp) inclusive.
+ -- spBase is always >= 0 and <= sp.
+ stack(spBase .. sp) inclusive will be the let vars bound
+ since the nearest enclosing lambda. When entering a lambda,
+ we set spBase=sp+1 so as record this fact, and restore spBase
+ afterwards.
+*/
+void oaCount ( StgExpr e )
+{
+ List bs;
+ Int spBase_saved;
+
+ switch(whatIsStg(e)) {
+ case LETREC:
+ for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
+ push(hd(bs));
+ for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
+ oaCount(stgVarBody(hd(bs)));
+ oaCount(stgLetBody(e));
+ for (bs = stgLetBinds(e);nonNull(bs);bs=tl(bs))
+ drop();
+ break;
+ case LAMBDA:
+ spBase_saved = spBase;
+ spBase = sp+1;
+ oaCount(stgLambdaBody(e));
+ spBase = spBase_saved;
+ break;
+ case CASE:
+ oaCount(stgCaseScrut(e));
+ mapProc(oaCount,stgCaseAlts(e));
+ break;
+ case PRIMCASE:
+ oaCount(stgPrimCaseScrut(e));
+ mapProc(oaCount,stgPrimCaseAlts(e));
+ break;
+ case STGAPP:
+ oaCount(stgAppFun(e));
+ mapProc(oaCount,stgAppArgs(e));
+ break;
+ case STGPRIM:
+ mapProc(oaCount,stgPrimArgs(e));
+ break;
+ case STGCON:
+ mapProc(oaCount,stgConArgs(e));
+ break;
+ case CASEALT:
+ nullCounts(stgCaseAltVars(e));
+ oaCount(stgCaseAltBody(e));
+ break;
+ case DEEFALT:
+ nullCount(stgDefaultVar(e));
+ oaCount(stgDefaultBody(e));
+ break;
+ case PRIMALT:
+ nullCounts(stgPrimAltVars(e));
+ oaCount(stgPrimAltBody(e));
+ break;
+ case STGVAR:
+ if (isInt(stgVarInfo(e))) {
+ Int i, j;
+ j = -1;
+ for (i = sp; i >= spBase; i--)
+ if (stack(i) == e) { j = i; break; };
+ if (j == -1)
+ stgVarInfo(e) = mkInt(OCC_IN_LAMBDA); else
+ stgVarInfo(e) = mkInt(1 + intOf(stgVarInfo(e)));
+ }
+ break;
+ case NAME:
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case BIGCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ break;
+ default:
+ fprintf(stderr, "oaCount: unknown stuff %d\n",whatIsStg(e));
+ assert(0);
+ }
+}
+
+void stgTopSanity ( char*, StgVar );
+
+/* Top level entry point for the occurrence analyser. */
+void oaTop ( StgVar v )
+{
+ assert (varSet_nfree == M_VAR_SETS);
+ freeStgVarSet(oaScc(&stgVarBody(v)));
+ assert (varSet_nfree == M_VAR_SETS);
+ oaPre(stgVarBody(v));
+ clearStack(); spBase = 0;
+ oaCount(stgVarBody(v));
+ assert(stackEmpty());
+ stgTopSanity("oaTop",stgVarBody(v));
+}
+
+
+/* --------------------------------------------------------------------------
+ * Transformation machinery proper
+ * ------------------------------------------------------------------------*/
+
+#define streq(aa,bb) (strcmp((aa),(bb))==0)
+/* Return TRUE if the non-default alts in the given list are exhaustive.
+ If in doubt, return FALSE.
+*/
+Bool stgAltsExhaustive ( List alts )
+{
+ Int nDefnCons;
+ Name con;
+ Tycon t;
+ List cs;
+ char* s;
+ List alts0 = alts;
+ while (nonNull(alts) && isDefaultAlt(hd(alts))) alts=tl(alts);
+ if (isNull(alts)) {
+ return FALSE;
+ } else {
+ con = stgCaseAltCon(hd(alts));
+ /* special case: dictionary constructor */
+ if (strncmp("Make.",textToStr(name(con).text),5)==0)
+ return TRUE;
+ /* special case: constructor boxing an unboxed value. */
+ if (isBoxingCon(con))
+ return TRUE;
+ /* some other special cases which are not boxingCons */
+ s = textToStr(name(con).text);
+ if (streq(s,"Integer#")
+ || streq(s,"Ref#")
+ || streq(s,"PrimMutableArray#")
+ || streq(s,"PrimMutableByteArray#")
+ || streq(s,"PrimByteArray#")
+ || streq(s,"PrimArray#")
+ )
+ return TRUE;
+ if (strcmp("Ref#",textToStr(name(con).text))==0)
+ return TRUE;
+ /* special case: Tuples */
+ if (isTuple(con) || (isName(con) && con==nameUnit))
+ return TRUE;
+ if (isNull(name(con).parent)) internal("stgAltsExhaustive(1)");
+ t = name(con).parent;
+ cs = tycon(t).defn;
+ if (tycon(t).what != DATATYPE) internal("stgAltsExhaustive(2)");
+ nDefnCons = length(cs);
+ for (; nonNull(alts0);alts0=tl(alts0)) {
+ if (isDefaultAlt(hd(alts0))) continue;
+ nDefnCons--;
+ }
+ }
+ return nDefnCons == 0;
+}
+#undef streq
+
+
+/* If in doubt, return FALSE.
+*/
+Bool isManifestCon ( StgExpr e )
+{
+ StgExpr altB;
+ switch (whatIsStg(e)) {
+ case STGCON: return TRUE;
+ case LETREC: return isManifestCon(stgLetBody(e));
+ case CASE: if (length(stgCaseAlts(e))==1) {
+ if (isDefaultAlt(hd(stgCaseAlts(e))))
+ altB = stgDefaultBody(hd(stgCaseAlts(e))); else
+ altB = stgCaseAltBody(hd(stgCaseAlts(e)));
+ return isManifestCon(altB);
+ } else {
+ return FALSE;
+ }
+ default: return FALSE;
+ }
+}
+
+
+/* Like isManifestCon, but doesn't give up at non-singular cases */
+Bool constructsCon ( StgExpr e )
+{
+ List as;
+ switch (whatIsStg(e)) {
+ case STGCON: return TRUE;
+ case LETREC: return constructsCon(stgLetBody(e));
+ case CASE: for (as = stgCaseAlts(e); nonNull(as); as=tl(as))
+ if (!constructsCon(hd(as))) return FALSE;
+ return TRUE;
+ case PRIMCASE: for (as = stgPrimCaseAlts(e); nonNull(as); as=tl(as))
+ if (!constructsCon(hd(as))) return FALSE;
+ return TRUE;
+ case CASEALT: return constructsCon(stgCaseAltBody(e));
+ case DEEFALT: return constructsCon(stgDefaultBody(e));
+ case PRIMALT: return constructsCon(stgPrimAltBody(e));
+ default: return FALSE;
+ }
+}
+
+
+/* Inline v in the special case where expr is
+ case v of C a1 ... an -> E
+ and v's bindee returns a product constructed with C.
+ and v does not appear in E
+ and v does not appear in letDefs (ie, this expr isn't
+ part of the definition of v.
+*/
+void tryLoopbreakerHack ( List letDefs, StgExpr expr )
+{
+ List alts;
+ StgExpr scrut, ee, v_bindee;
+ StgCaseAlt alt;
+
+ assert (whatIsStg(expr)==CASE);
+ alts = stgCaseAlts(expr);
+ scrut = stgCaseScrut(expr);
+ if (whatIsStg(scrut) != STGVAR || isNull(stgVarBody(scrut))) return;
+ if (length(alts) != 1 || isDefaultAlt(hd(alts))) return;
+ if (!stgAltsExhaustive(alts)) return;
+ alt = hd(alts);
+ ee = stgCaseAltBody(alt);
+ if (nonNull(cellIsMember(scrut,letDefs))) return;
+
+ v_bindee = stgVarBody(scrut);
+ if (!isManifestCon(v_bindee)) return;
+
+ stgCaseScrut(expr) = cloneStgTop(v_bindee);
+ nLoopBreakersInlined++;
+}
+
+
+/* Traverse a tree. Replace let-bound vars marked as used-once
+ by their definitions. Replace references to top-level
+ values marked inlineMe with their bodies. Carry around a list
+ of let-bound variables whose definitions we are currently in
+ so as to know not to inline let-bound vars in their own
+ definitions.
+*/
+StgExpr copyIn ( List letDefs, InlineCtx ctx, StgExpr e )
+{
+ List bs;
+
+ switch(whatIsStg(e)) {
+ // these are the only two interesting cases
+ case STGVAR:
+ assert(isPtr(stgVarInfo(e)) || isNull(stgVarInfo(e)) ||
+ isInt(stgVarInfo(e)));
+ if (isInt(stgVarInfo(e)) && intOf(stgVarInfo(e))==1) {
+ nLetvarsInlined++;
+ return cloneStgTop(stgVarBody(e));
+ } else
+ return e;
+ case NAME:
+ // if we're not inlining top vars on this round, do nothing
+ if (!copyInTopvar) return e;
+ // if it doesn't want to be inlined, do nothing
+ if (!name(e).inlineMe) return e;
+ // we decline to inline dictionary builders inside other builders
+ if (inDBuilder && name(e).isDBuilder) {
+ //fprintf(stderr, "decline to inline dbuilder %s\n", textToStr(name(e).text));
+ return e;
+ }
+ // in fact, only inline dict builders into a case scrutinee
+ if (name(e).isDBuilder && ctx != CTX_SCRUT)
+ return e;
+
+#if DEBUG_OPTIMISE
+assert( stgSize(stgVarBody(name(e).stgVar)) == name(e).stgSize );
+#endif
+
+ // only inline large dict builders if it returns a manifest con
+ if (name(e).isDBuilder &&
+ name(e).stgSize > 180 &&
+ !isManifestCon(stgVarBody(name(e).stgVar)))
+ return e;
+#if 0
+ // if it's huge, don't inline into a boring place
+ if (ctx != CTX_SCRUT &&
+ name(e).stgSize > 270)
+ return e;
+#endif
+
+ nTopvarsInlined++;
+ return cloneStgTop(stgVarBody(name(e).stgVar));
+
+ // the rest are a boring recursive traversal of the tree
+ case LETREC:
+ stgLetBody(e) = copyIn(letDefs,CTX_OTHER,stgLetBody(e));
+ letDefs = dupOnto(stgLetBinds(e),letDefs);
+ for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
+ stgVarBody(hd(bs)) = copyIn(letDefs,CTX_OTHER,stgVarBody(hd(bs)));
+ break;
+ case LAMBDA:
+ stgLambdaBody(e) = copyIn(letDefs,CTX_OTHER,stgLambdaBody(e));
+ break;
+ case CASE:
+ stgCaseScrut(e) = copyIn(letDefs,CTX_SCRUT,stgCaseScrut(e));
+ map2Over(copyIn,letDefs,CTX_OTHER,stgCaseAlts(e));
+ if (copyInTopvar) tryLoopbreakerHack(letDefs,e);
+ break;
+ case PRIMCASE:
+ stgPrimCaseScrut(e) = copyIn(letDefs,CTX_OTHER,stgPrimCaseScrut(e));
+ map2Over(copyIn,letDefs,CTX_OTHER,stgPrimCaseAlts(e));
+ break;
+ case STGAPP:
+ stgAppFun(e) = copyIn(letDefs,CTX_OTHER,stgAppFun(e));
+ break;
+ case CASEALT:
+ stgCaseAltBody(e) = copyIn(letDefs,CTX_OTHER,stgCaseAltBody(e));
+ break;
+ case DEEFALT:
+ stgDefaultBody(e) = copyIn(letDefs,CTX_OTHER,stgDefaultBody(e));
+ break;
+ case PRIMALT:
+ stgPrimAltBody(e) = copyIn(letDefs,CTX_OTHER,stgPrimAltBody(e));
+ break;
+ case STGPRIM:
+ case STGCON:
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ break;
+ default:
+ fprintf(stderr, "copyIn: unknown stuff %d\n",whatIsStg(e));
+ ppStgExpr(e);
+ printf("\n");
+ print(e,1000);
+ printf("\n");
+ assert(0);
+ }
+ return e;
+}
+
+
+
+/* case (C a1 ... an) of
+ B ... -> ...
+ C v1 ... vn -> e
+ D ... -> ...
+ ==>
+ e with v1/a1 ... vn/an
+*/
+StgExpr doCaseOfCon ( StgExpr expr, Bool* done )
+{
+ StgExpr scrut, e;
+ StgVar apC;
+ StgCaseAlt theAlt;
+ List alts, altvs, as, sub;
+
+ *done = FALSE;
+ alts = stgCaseAlts(expr);
+ scrut = stgCaseScrut(expr);
+
+ apC = stgConCon(scrut);
+
+ theAlt = NIL;
+ for (alts = stgCaseAlts(expr); nonNull(alts); alts=tl(alts))
+ if (!isDefaultAlt(hd(alts)) && stgCaseAltCon(hd(alts)) == apC) {
+ theAlt = hd(alts);
+ break;
+ }
+
+ if (isNull(theAlt)) return expr;
+ altvs = stgCaseAltVars(theAlt);
+ e = stgCaseAltBody(theAlt);
+ as = stgConArgs(scrut);
+
+ if (length(as)!=length(altvs)) return expr;
+
+ sub = NIL;
+ while (nonNull(altvs)) {
+ sub = cons(pair(hd(altvs),hd(as)),sub);
+ as = tl(as);
+ altvs = tl(altvs);
+ }
+ nCaseOfCon++;
+ *done = TRUE;
+ return zubstExpr(sub,e);
+}
+
+
+/* case (let binds in e) of alts
+ ===>
+ let binds in case e of alts
+*/
+StgExpr doCaseOfLet ( StgExpr expr, Bool* done )
+{
+ StgExpr letexpr, e;
+ List binds, alts;
+
+ letexpr = stgCaseScrut(expr);
+ e = stgLetBody(letexpr);
+ binds = stgLetBinds(letexpr);
+ alts = stgCaseAlts(expr);
+ nCaseOfLet++;
+ *done = TRUE;
+ return mkStgLet(binds,mkStgCase(e,alts));
+}
+
+
+
+/* case (case e of p1 -> e1 ... pn -> en) of
+ q1 -> h1
+ ...
+ qk -> hk
+ ===>
+ case e of
+ p1 -> case e1 of q1 -> h1 ... qk -> hk
+ ...
+ pn -> case en of q1 -> h1 ... qk -> kl
+*/
+StgExpr doCaseOfCase ( StgExpr expr )
+{
+ StgExpr innercase, e, tmpcase, protocase;
+ List ps_n_es, qs_n_hs, newAlts;
+ StgCaseAlt newAlt, p_n_e;
+
+ nCaseOfCase++;
+
+ innercase = stgCaseScrut(expr);
+ e = stgCaseScrut(innercase);
+ ps_n_es = stgCaseAlts(innercase);
+ qs_n_hs = stgCaseAlts(expr);
+
+ /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */
+ protocase = mkStgCase( mkInt(0), qs_n_hs);
+
+ newAlts = NIL;
+ for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) {
+ tmpcase = cloneStgTop(protocase);
+ p_n_e = hd(ps_n_es);
+ if (isDefaultAlt(p_n_e)) {
+ stgCaseScrut(tmpcase) = stgDefaultBody(p_n_e);
+ newAlt = mkStgDefault(stgDefaultVar(p_n_e), tmpcase);
+ } else {
+ stgCaseScrut(tmpcase) = stgCaseAltBody(p_n_e);
+ newAlt = mkStgCaseAlt(stgCaseAltCon(p_n_e),stgCaseAltVars(p_n_e),tmpcase);
+ }
+ newAlts = cons(newAlt,newAlts);
+ }
+ newAlts = rev(newAlts);
+ return
+ mkStgCase(e, newAlts);
+}
+
+
+
+/* case (case# e of p1 -> e1 ... pn -> en) of
+ q1 -> h1
+ ...
+ qk -> hk
+ ===>
+ case# e of
+ p1 -> case e1 of q1 -> h1 ... qk -> hk
+ ...
+ pn -> case en of q1 -> h1 ... qk -> kl
+*/
+StgExpr doCaseOfPrimCase ( StgExpr expr )
+{
+ StgExpr innercase, e, tmpcase, protocase;
+ List ps_n_es, qs_n_hs, newAlts;
+ StgCaseAlt newAlt, p_n_e;
+
+ nCaseOfPrimCase++;
+
+ innercase = stgCaseScrut(expr);
+ e = stgPrimCaseScrut(innercase);
+ ps_n_es = stgPrimCaseAlts(innercase);
+ qs_n_hs = stgCaseAlts(expr);
+
+ /* protocase = case (hole-to-fill-in) of q1 -> h1 ... qk -> hk */
+ protocase = mkStgCase( mkInt(0), qs_n_hs);
+
+ newAlts = NIL;
+ for (;nonNull(ps_n_es);ps_n_es = tl(ps_n_es)) {
+ tmpcase = cloneStgTop(protocase);
+ p_n_e = hd(ps_n_es);
+ stgPrimCaseScrut(tmpcase) = stgPrimAltBody(p_n_e);
+ newAlt = mkStgPrimAlt(stgPrimAltVars(p_n_e),tmpcase);
+ newAlts = cons(newAlt,newAlts);
+ }
+ newAlts = rev(newAlts);
+ return
+ mkStgPrimCase(e, newAlts);
+}
+
+
+Bool isStgCaseWithSingleNonDefaultAlt ( StgExpr e )
+{
+ return
+ whatIsStg(e)==CASE &&
+ length(stgCaseAlts(e))==1 &&
+ !isDefaultAlt(hd(stgCaseAlts(e)));
+}
+
+
+/* Do simplifications on an Stg tree. Invariant is that the
+ input and output trees should have no name shadowing.
+
+ -- let { } in e
+ ===>
+ e
+
+ -- dump individual let-bindings with usage counts of zero
+
+ -- dump let-binding groups for which none of the bound vars
+ occur in the let body
+
+ -- (\v1 ... vn -> e) a1 ... am
+ ===>
+ -- the usual beta reduction. There are no constraints on n and m, so
+ the result can be a lambda term (if n > m), or an application of e
+ to the unused args (if n < m).
+
+
+ Scheme is: bottom-up traversal of the tree. First simplify child
+ trees. Then try to do local transformations. If a local transformation
+ succeeds, jump to the local-transformation code for whatever node
+ is produced -- so as to try and maximise the amount of work which
+ happens on each call to simplify.
+*/
+StgExpr simplify ( List caseEnv, StgExpr e )
+{
+ List bs, bs2;
+ Bool done;
+ Int n;
+
+ restart:
+ switch(whatIsStg(e)) {
+ case STGVAR:
+ return e;
+ case NAME:
+ return e;
+
+ case LETREC:
+
+ /* first dump dead binds, so as not to waste effort simplifying them */
+ bs2=NIL;
+ for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
+ if (!isInt(stgVarInfo(hd(bs))) ||
+ intOf(stgVarInfo(hd(bs))) > 0) {
+ bs2=cons(hd(bs),bs2);
+ } else {
+ nLetBindsDropped++;
+ }
+ if (isNull(bs2)) { e = stgLetBody(e); goto restart; };
+ stgLetBinds(e) = rev(bs2);
+
+ for (bs=stgLetBinds(e);nonNull(bs);bs=tl(bs))
+ stgVarBody(hd(bs)) = simplify(caseEnv,stgVarBody(hd(bs)));
+ stgLetBody(e) = simplify(caseEnv,stgLetBody(e));
+
+ /* Merge let ... in let ... in e. Grouping lets together
+ sometimes reduces the number of iterations needed.
+ oaScc should do this anyway, but this just to make sure.
+ */
+ while (whatIsStg(stgLetBody(e))==LETREC) {
+ stgLetBinds(e) = dupOnto(stgLetBinds(stgLetBody(e)),stgLetBinds(e));
+ stgLetBody(e) = stgLetBody(stgLetBody(e));
+ }
+
+ let_local:
+ /* let binds in case v-not-in-binds of singleAlt -> expr
+ ===>
+ case v-not-in-binds of singleAlt -> let binds in expr
+ */
+ if (isStgCaseWithSingleNonDefaultAlt(stgLetBody(e)) &&
+ whatIsStg(stgCaseScrut(stgLetBody(e)))==STGVAR &&
+ isNull(cellIsMember(stgCaseScrut(stgLetBody(e)),stgLetBinds(e)))) {
+ StgVar v = stgCaseScrut(stgLetBody(e));
+ StgCaseAlt a = hd(stgCaseAlts(stgLetBody(e)));
+ nLetsFloatedIntoCase++;
+ e = mkStgCase(
+ v,
+ singleton(
+ mkStgCaseAlt(
+ stgCaseAltCon(a),
+ stgCaseAltVars(a),
+ mkStgLet(stgLetBinds(e),stgCaseAltBody(a))
+ )
+ )
+ );
+ assert(whatIsStg(e)==CASE);
+ goto case_local;
+ }
+
+ break;
+
+ case LAMBDA:
+ stgLambdaBody(e) = simplify(caseEnv,stgLambdaBody(e));
+
+ lambda_local:
+ while (whatIsStg(stgLambdaBody(e))==LAMBDA) {
+ nLambdasMerged++;
+ stgLambdaArgs(e) = appendOnto(stgLambdaArgs(e),
+ stgLambdaArgs(stgLambdaBody(e)));
+ stgLambdaBody(e) = stgLambdaBody(stgLambdaBody(e));
+ }
+ break;
+
+
+ case CASE:
+ stgCaseScrut(e) = simplify(caseEnv,stgCaseScrut(e));
+ if (isStgCaseWithSingleNonDefaultAlt(e) &&
+ (whatIsStg(stgCaseScrut(e))==STGVAR ||
+ whatIsStg(stgCaseScrut(e))==NAME)) {
+ List caseEnv2 = cons(
+ pair(stgCaseScrut(e),stgCaseAltVars(hd(stgCaseAlts(e)))),
+ caseEnv
+ );
+ map1Over(simplify,caseEnv2,stgCaseAlts(e));
+ } else {
+ map1Over(simplify,caseEnv,stgCaseAlts(e));
+ }
+
+ case_local:
+ /* zap redundant default alternatives */
+ if (stgAltsExhaustive(stgCaseAlts(e))) {
+ Bool droppedDef = FALSE;
+ bs2 = NIL;
+ for (bs = dupList(stgCaseAlts(e));nonNull(bs);bs=tl(bs))
+ if (!isDefaultAlt(hd(bs))) {
+ bs2=cons(hd(bs),bs2);
+ } else {
+ droppedDef = TRUE;
+ }
+ bs2 = rev(bs2);
+ stgCaseAlts(e) = bs2;
+ if (droppedDef) nCaseDefaultsDropped++;
+ }
+
+ switch (whatIsStg(stgCaseScrut(e))) {
+ case CASE:
+ /* attempt case-of-case */
+ n = length(stgCaseAlts(e));
+ if (n==1 ||
+ (n <= 3 &&
+ (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 &&
+ constructsCon(stgCaseScrut(e)))
+ ) {
+ e = doCaseOfCase(e);
+ assert(whatIsStg(e)==CASE);
+ goto case_local;
+ }
+ break;
+ case PRIMCASE:
+ /* attempt case-of-case# */
+ n = length(stgCaseAlts(e));
+ if (n==1 ||
+ (n <= 3 &&
+ (stgSize(e)-stgSize(stgCaseScrut(e))) < 100 &&
+ constructsCon(stgCaseScrut(e)))
+ ) {
+ e = doCaseOfPrimCase(e);
+ assert(whatIsStg(e)==PRIMCASE);
+ goto primcase_local;
+ }
+ break;
+ case LETREC:
+ /* attempt case-of-let */
+ e = doCaseOfLet(e,&done);
+ if (done) { assert(whatIsStg(e)==LETREC); goto let_local; };
+ break;
+ case STGCON:
+ /* attempt case-of-constructor */
+ e = doCaseOfCon(e,&done);
+ /* we don't know what the result is, so can't jump to local */
+ break;
+ case NAME:
+ case STGVAR: {
+ /* attempt to remove case on something already cased on */
+ List outervs, innervs, sub;
+ Cell lookupResult;
+ if (!isStgCaseWithSingleNonDefaultAlt(e)) break;
+ lookupResult = cellAssoc(stgCaseScrut(e),caseEnv);
+ if (isNull(lookupResult)) break;
+ outervs = snd(lookupResult);
+ nCaseOfOuter++;
+ sub = NIL;
+ innervs = stgCaseAltVars(hd(stgCaseAlts(e)));
+ for (; nonNull(outervs) && nonNull(innervs);
+ outervs=tl(outervs), innervs=tl(innervs))
+ sub = cons(pair(hd(innervs),hd(outervs)),sub);
+ assert (isNull(outervs) && isNull(innervs));
+ return zubstExpr(sub, stgCaseAltBody(hd(stgCaseAlts(e))));
+ }
+ default:
+ break;
+ }
+ break;
+ case CASEALT:
+ stgCaseAltBody(e) = simplify(caseEnv,stgCaseAltBody(e));
+ break;
+ case DEEFALT:
+ stgDefaultBody(e) = simplify(caseEnv,stgDefaultBody(e));
+ break;
+ case PRIMALT:
+ stgPrimAltBody(e) = simplify(caseEnv,stgPrimAltBody(e));
+ break;
+ case PRIMCASE:
+ stgPrimCaseScrut(e) = simplify(caseEnv,stgPrimCaseScrut(e));
+ map1Over(simplify,caseEnv,stgPrimCaseAlts(e));
+ primcase_local:
+ break;
+ case STGAPP: {
+ List sub, formals;
+ StgExpr subd_body;
+ StgExpr fun;
+ List args;
+
+ stgAppFun(e) = simplify(caseEnv,stgAppFun(e));
+ map1Over(simplify,caseEnv,stgAppArgs(e));
+
+ fun = stgAppFun(e);
+ args = stgAppArgs(e);
+
+ switch (whatIsStg(fun)) {
+ case STGAPP:
+ nAppsMerged++;
+ stgAppArgs(e) = appendOnto(stgAppArgs(fun),args);
+ stgAppFun(e) = stgAppFun(fun);
+ break;
+ case LETREC:
+ /* (let binds in f) args ==> let binds in (f args) */
+ nLetsFloatedOutOfFn++;
+ e = mkStgLet(stgLetBinds(fun),mkStgApp(stgLetBody(fun),args));
+ assert(whatIsStg(e)==LETREC);
+ goto let_local;
+ break;
+ case CASE:
+ if (length(stgCaseAlts(fun))==1 &&
+ !isDefaultAlt(hd(stgCaseAlts(fun)))) {
+ StgCaseAlt theAlt = hd(stgCaseAlts(fun));
+ /* (case e of alt -> f) args ==> case e of alt -> f args */
+ e = mkStgCase(
+ stgCaseScrut(fun),
+ singleton(mkStgCaseAlt(stgCaseAltCon(theAlt),
+ stgCaseAltVars(theAlt),
+ mkStgApp(stgCaseAltBody(theAlt),args))
+ )
+ );
+ nCasesFloatedOutOfFn++;
+ assert(whatIsStg(e)==CASE);
+ goto case_local;
+ }
+ break;
+ case LAMBDA: {
+ sub = NIL;
+ formals = stgLambdaArgs(fun);
+ while (nonNull(formals) && nonNull(args)) {
+ sub = cons(pair(hd(formals),hd(args)),sub);
+ formals = tl(formals);
+ args = tl(args);
+ }
+ subd_body = zubstExpr(sub,stgLambdaBody(fun));
+
+ nBetaReductions++;
+ assert(isNull(formals) || isNull(args));
+ if (isNull(formals) && isNull(args)) {
+ /* fn and args match exactly */
+ e = subd_body;
+ return e;
+ }
+ else
+ if (isNull(formals) && nonNull(args)) {
+ /* more args than we could deal with. Build a new Ap. */
+ e = mkStgApp(subd_body,args);
+ return e;
+ }
+ else
+ if (nonNull(formals) && isNull(args)) {
+ /* partial application. We get a new Lambda */
+ e = mkStgLambda(formals,subd_body);
+ return e;
+ }
+ }
+ break;
+ default:
+ break;
+ }
+ }
+ break;
+ case STGPRIM:
+ break;
+ case STGCON:
+ break;
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ break;
+ default:
+ fprintf(stderr, "simplify: unknown stuff %d\n",whatIsStg(e));
+ ppStgExpr(e);
+ printf("\n");
+ print(e,1000);
+ printf("\n");
+ assert(0);
+ }
+ return e;
}
-void optimiseTopBind( StgVar v )
+/* Restore STG representation invariants broken by simplify.
+ -- Let-bind any constructor applications which appear
+ anywhere other than a let.
+ -- Let-bind non-atomic case scrutinees (ToDo).
+*/
+StgExpr restoreStg ( StgExpr e )
{
-if (lastModule() != modulePrelude) {
-fflush(stdout); fflush(stderr);
-fprintf ( stderr, "------------------------------\n" );
-fflush(stderr);
-printStg ( stderr, v );
-fprintf(stderr, "\n" );
+ List bs;
+ StgVar newv;
+
+ if (isNull(e)) return e;
+
+ switch(whatIsStg(e)) {
+ case LETREC:
+ for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) {
+ if (whatIsStg(stgVarBody(hd(bs))) == STGCON) {
+ /* do nothing */
+ }
+ else
+ if (whatIsStg(stgVarBody(hd(bs))) == LAMBDA) {
+ stgLambdaBody(stgVarBody(hd(bs)))
+ = restoreStg(stgLambdaBody(stgVarBody(hd(bs))));
+ }
+ else {
+ stgVarBody(hd(bs)) = restoreStg(stgVarBody(hd(bs)));
+ }
+ }
+ stgLetBody(e) = restoreStg(stgLetBody(e));
+ break;
+ case LAMBDA:
+ /* note that the check in LETREC above ensures we won't
+ get here for legitimate (let-bound) lambdas. */
+ stgLambdaBody(e) = restoreStg(stgLambdaBody(e));
+ newv = mkStgVar(e,NIL);
+ e = mkStgLet(singleton(newv),newv);
+ break;
+ case CASE:
+ stgCaseScrut(e) = restoreStg(stgCaseScrut(e));
+ mapOver(restoreStg,stgCaseAlts(e));
+ if (!isAtomic(stgCaseScrut(e))) {
+ newv = mkStgVar(stgCaseScrut(e),NIL);
+ return mkStgLet(singleton(newv),mkStgCase(newv,stgCaseAlts(e)));
+ }
+ break;
+ case PRIMCASE:
+ stgPrimCaseScrut(e) = restoreStg(stgPrimCaseScrut(e));
+ mapOver(restoreStg,stgPrimCaseAlts(e));
+ break;
+ case STGAPP:
+ stgAppFun(e) = restoreStg(stgAppFun(e));
+ mapOver(restoreStg,stgAppArgs(e)); /* probably incorrect */
+ if (!isAtomic(stgAppFun(e))) {
+ newv = mkStgVar(stgAppFun(e),NIL);
+ e = mkStgLet(singleton(newv),mkStgApp(newv,stgAppArgs(e)));
+ }
+ break;
+ case STGPRIM:
+ mapOver(restoreStg,stgPrimArgs(e));
+ break;
+ case STGCON:
+ /* note that the check in LETREC above ensures we won't
+ get here for legitimate constructor applications. */
+ mapOver(restoreStg,stgConArgs(e));
+ newv = mkStgVar(e,NIL);
+ return mkStgLet(singleton(newv),newv);
+ break;
+ case CASEALT:
+ stgCaseAltBody(e) = restoreStg(stgCaseAltBody(e));
+ if (whatIsStg(stgCaseAltBody(e))==LAMBDA) {
+ newv = mkStgVar(stgCaseAltBody(e),NIL);
+ stgCaseAltBody(e) = mkStgLet(singleton(newv),newv);
+ }
+ break;
+ case DEEFALT:
+ stgDefaultBody(e) = restoreStg(stgDefaultBody(e));
+ if (whatIsStg(stgDefaultBody(e))==LAMBDA) {
+ newv = mkStgVar(stgDefaultBody(e),NIL);
+ stgDefaultBody(e) = mkStgLet(singleton(newv),newv);
+ }
+ break;
+ case PRIMALT:
+ stgPrimAltBody(e) = restoreStg(stgPrimAltBody(e));
+ break;
+ case STGVAR:
+ case NAME:
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ break;
+ default:
+ fprintf(stderr, "restoreStg: unknown stuff %d\n",whatIsStg(e));
+ ppStgExpr(e);
+ printf("\n");
+ assert(0);
+ }
+ return e;
}
-optimiseBind ( v );
-if (lastModule() != modulePrelude) {
-printStg ( stderr,v );
-fprintf(stderr, "\n\n" );
-fflush(stderr);
+
+
+StgExpr restoreStgTop ( StgExpr e )
+{
+ if (whatIs(e)==LAMBDA)
+ stgLambdaBody(e) = restoreStg(stgLambdaBody(e)); else
+ e = restoreStg(e);
+ return e;
}
+
+
+void simplTopRefs ( StgExpr e )
+{
+ List bs;
+
+ switch(whatIsStg(e)) {
+ /* the only interesting case */
+ case NAME:
+ if (name(e).inlineMe && !name(e).simplified) {
+ /* printf("\n((%d)) request for %s\n",rDepth, textToStr(name(e).text)); */
+ name(e).simplified = TRUE;
+ optimiseTopBind(name(e).stgVar);
+ /* printf("((%d)) done for %s\n",rDepth, textToStr(name(e).text)); */
+ }
+ break;
+ case LETREC:
+ simplTopRefs(stgLetBody(e));
+ for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
+ simplTopRefs(stgVarBody(hd(bs)));
+ break;
+ case LAMBDA:
+ simplTopRefs(stgLambdaBody(e));
+ break;
+ case CASE:
+ simplTopRefs(stgCaseScrut(e));
+ mapProc(simplTopRefs,stgCaseAlts(e));
+ break;
+ case PRIMCASE:
+ simplTopRefs(stgPrimCaseScrut(e));
+ mapProc(simplTopRefs,stgPrimCaseAlts(e));
+ break;
+ case STGAPP:
+ simplTopRefs(stgAppFun(e));
+ mapProc(simplTopRefs,stgAppArgs(e));
+ break;
+ case STGCON:
+ mapProc(simplTopRefs,stgConArgs(e));
+ break;
+ case STGPRIM:
+ simplTopRefs(stgPrimOp(e));
+ mapProc(simplTopRefs,stgPrimArgs(e));
+ break;
+ case CASEALT:
+ simplTopRefs(stgCaseAltBody(e));
+ break;
+ case DEEFALT:
+ simplTopRefs(stgDefaultBody(e));
+ break;
+ case PRIMALT:
+ simplTopRefs(stgPrimAltBody(e));
+ break;
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case BIGCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ case TUPLE:
+ case STGVAR:
+ break;
+ default:
+ fprintf(stderr, "simplTopRefs: unknown stuff %d\n",whatIsStg(e));
+ ppStgExpr(e);
+ printf("\n");
+ print(e,1000);
+ printf("\n");
+ assert(0);
+ }
+}
+
+char* maybeName ( StgVar v )
+{
+ Name n = nameFromStgVar(v);
+ if (isNull(n)) return "(unknown)";
+ return textToStr(name(n).text);
+}
+
+
+/* --------------------------------------------------------------------------
+ * Sanity checking (weak :-(
+ * ------------------------------------------------------------------------*/
+
+Bool stgError;
+
+int stgSanity_checkStack ( StgVar v )
+{
+ int i, j;
+ j = 0;
+ for (i = 0; i <= sp; i++)
+ if (stack(i)==v) j++;
+ return j;
+}
+
+void stgSanity_dropVar ( StgVar v )
+{
+ drop();
+}
+
+void stgSanity_pushVar ( StgVar v )
+{
+ if (stgSanity_checkStack(v) != 0) stgError = TRUE;
+ push(v);
+}
+
+
+void stgSanity ( StgExpr e )
+{
+ List bs;
+
+ switch(whatIsStg(e)) {
+ case LETREC:
+ mapProc(stgSanity_pushVar,stgLetBinds(e));
+ stgSanity(stgLetBody(e));
+ for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
+ stgSanity(stgVarBody(hd(bs)));
+ mapProc(stgSanity_dropVar,stgLetBinds(e));
+ break;
+ case LAMBDA:
+ mapProc(stgSanity_pushVar,stgLambdaArgs(e));
+ stgSanity(stgLambdaBody(e));
+ mapProc(stgSanity_dropVar,stgLambdaArgs(e));
+ break;
+ case CASE:
+ stgSanity(stgCaseScrut(e));
+ mapProc(stgSanity,stgCaseAlts(e));
+ break;
+ case PRIMCASE:
+ stgSanity(stgPrimCaseScrut(e));
+ mapProc(stgSanity,stgPrimCaseAlts(e));
+ break;
+ case STGAPP:
+ stgSanity(stgAppFun(e));
+ mapProc(stgSanity,stgAppArgs(e));
+ break;
+ case STGCON:
+ stgSanity(stgConCon(e));
+ mapProc(stgSanity,stgConArgs(e));
+ break;
+ case STGPRIM:
+ stgSanity(stgPrimOp(e));
+ mapProc(stgSanity,stgPrimArgs(e));
+ break;
+ case CASEALT:
+ mapProc(stgSanity_pushVar,stgCaseAltVars(e));
+ stgSanity(stgCaseAltBody(e));
+ mapProc(stgSanity_dropVar,stgCaseAltVars(e));
+ break;
+ case DEEFALT:
+ stgSanity_pushVar(stgDefaultVar(e));
+ stgSanity(stgDefaultBody(e));
+ stgSanity_dropVar(stgDefaultVar(e));
+ break;
+ case PRIMALT:
+ mapProc(stgSanity_pushVar,stgPrimAltVars(e));
+ stgSanity(stgPrimAltBody(e));
+ mapProc(stgSanity_dropVar,stgPrimAltVars(e));
+ break;
+ case STGVAR:
+ if (stgSanity_checkStack(e) == 1) break;
+ if (nonNull(nameFromStgVar(e))) return;
+ break;
+ case NAME:
+ case INTCELL:
+ case STRCELL:
+ case PTRCELL:
+ case CHARCELL:
+ case FLOATCELL:
+ case TUPLE:
+ break;
+ default:
+ fprintf(stderr, "stgSanity: unknown stuff %d\n",whatIsStg(e));
+ ppStgExpr(e);
+ printf("\n");
+ print(e,1000);
+ printf("\n");
+ assert(0);
+ }
+}
+
+
+void stgTopSanity ( char* caller, StgExpr e )
+{
+return;
+ clearStack();
+ assert(sp == -1);
+ stgError = FALSE;
+ stgSanity(e);
+ assert(sp == -1);
+ if (stgError) {
+ fprintf(stderr, "\n\nstgTopSanity (caller = %s):\n\n", caller );
+ ppStgExpr ( e );
+ printf( "\n\n" );
+ assert(0);
+ }
+}
+
+
+/* Check if e is in a form which the code generator can deal with.
+ * stgexpr-ness is what we need to enforce. The extended version,
+ * expr, may only occur as the rhs of a let binding.
+ *
+ * stgexpr ::= case atom of alts
+ * | case# primop{atom*} of primalts
+ * | let v_i = expr_i in stgexpr
+ * | var{atom*}
+ *
+ * expr ::= stgexpr
+ * | \v_i -> stgexpr
+ * | con{atoms}
+ *
+ * alt ::= con vars -> stgexpr (primalt and default similarly)
+ *
+ * atom ::= var | int | char etc (unboxed, that is)
+ */
+Bool isStgExpr ( StgExpr e );
+Bool isStgFullExpr ( StgExpr e );
+
+Bool isStgExpr ( StgExpr e )
+{
+ List bs;
+ switch (whatIs(e)) {
+ case LAMBDA:
+ case STGCON:
+ return FALSE;
+ case LETREC:
+ for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs))
+ if (!isStgFullExpr(stgVarBody(hd(bs))))
+ return FALSE;
+ return isStgExpr(stgLetBody(e));
+ case CASE:
+ for (bs=stgCaseAlts(e); nonNull(bs); bs=tl(bs))
+ if (!isStgExpr(hd(bs))) return FALSE;
+ return isAtomic(stgCaseScrut(e));
+ case PRIMCASE:
+ for (bs=stgPrimCaseAlts(e); nonNull(bs); bs=tl(bs))
+ if (!isStgExpr(hd(bs))) return FALSE;
+ if (isAtomic(stgPrimCaseScrut(e))) return TRUE;
+ if (whatIs(stgPrimCaseScrut(e))==STGPRIM)
+ return isStgExpr(stgPrimCaseScrut(e));
+ return FALSE;
+ case STGVAR:
+ case NAME:
+ return TRUE;
+ case STGAPP:
+ for (bs=stgAppArgs(e); nonNull(bs); bs=tl(bs))
+ if (!isAtomic(hd(bs))) return FALSE;
+ if (isStgVar(stgAppFun(e)) || isName(stgAppFun(e))) return TRUE;
+ return FALSE;
+ case STGPRIM:
+ for (bs=stgPrimArgs(e); nonNull(bs); bs=tl(bs))
+ if (!isAtomic(hd(bs))) return FALSE;
+ if (isName(stgPrimOp(e))) return TRUE;
+ return FALSE;
+ case CASEALT:
+ return isStgExpr(stgCaseAltBody(e));
+ case DEEFALT:
+ return isStgExpr(stgDefaultBody(e));
+ case PRIMALT:
+ return isStgExpr(stgPrimAltBody(e));
+ default:
+ return FALSE;
+ }
+}
+
+
+Bool isStgFullExpr ( StgExpr e )
+{
+ List bs;
+ switch (whatIs(e)) {
+ case LAMBDA:
+ return isStgExpr(stgLambdaBody(e));
+ case STGCON:
+ for (bs=stgConArgs(e); nonNull(bs); bs=tl(bs))
+ if (!isAtomic(hd(bs))) return FALSE;
+ if (isName(stgConCon(e)) || isTuple(stgConCon(e)))
+ return TRUE;
+ return FALSE;
+ default:
+ return isStgExpr(e);
+ }
+}
+
+
+/* --------------------------------------------------------------------------
+ * Top level calls
+ * ------------------------------------------------------------------------*/
+
+/* Set ddumpSimpl to TRUE if you want to see simplified code. */
+static Bool ddumpSimpl = FALSE;
+
+/* Leave this one alone ... */
+static Bool noisy;
+
+
+static void local optimiseTopBind( StgVar v )
+{
+ Bool ppPrel = FALSE;
+ Int n, m;
+ Name naam;
+ Int oldSize, newSize;
+ Bool me;
+
+ /* printf( "[[%d]] looking at %s\n", rDepth, maybeName(v)); */
+ assert(whatIsStg(v)==STGVAR);
+
+ rDepth++;
+ if (nonNull(stgVarBody(v))) simplTopRefs(stgVarBody(v));
+ rDepth--;
+
+ /* debugging ... */
+ //me= 0&& 0==strcmp("tcUnify",maybeName(v));
+ me= 0&& 0==strcmp("ttt",maybeName(v));
+
+ nTotSizeIn += stgSize(stgVarBody(v));
+ if (noisy) {
+ printf( "%28s: in %4d ", maybeName(v),stgSize(stgVarBody(v)));
+ fflush(stdout);
+ }
+
+ inDBuilder = FALSE;
+ naam = nameFromStgVar(v);
+ if (nonNull(naam) && name(naam).isDBuilder) inDBuilder = TRUE;
+
+#if DEBUG_OPTIMISE
+ if (nonNull(naam)) {
+ assert(name(naam).stgSize == stgSize(stgVarBody(name(naam).stgVar)));
+ }
+#endif
+
+ if (me) {
+ fflush(stdout); fflush(stderr);
+ fprintf ( stderr, "{{%d}}-----------------------------\n", -v );fflush(stderr);
+ printStg ( stderr, v );
+ fprintf(stderr, "\n" );
+ }
+
+ stgTopSanity ( "initial", stgVarBody(v));
+
+ if (nonNull(stgVarBody(v))) {
+ oldSize = -1;
+
+ for (n = 0; n < 8; n++) { // originally 7
+ if (noisy) printf("%4d", stgSize(stgVarBody(v)));
+ copyInTopvar = TRUE;
+ stgTopSanity ( "outer-1", stgVarBody(v));
+ oaTop ( v );
+ stgTopSanity ( "outer-2", stgVarBody(v));
+ stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) );
+ stgTopSanity ( "outer-3", stgVarBody(v));
+ stgVarBody(v) = simplify ( NIL, stgVarBody(v) );
+ stgTopSanity ( "outer-4", stgVarBody(v));
+
+ for (m = 0; m < 3; m++) { // oprignally 3
+ if (noisy) printf(".");
+ fflush(stdout);
+ copyInTopvar = FALSE;
+ stgTopSanity ( "inner-1", stgVarBody(v));
+ oaTop ( v );
+ stgTopSanity ( "inner-2", stgVarBody(v));
+ stgVarBody(v) = copyIn ( NIL, CTX_OTHER, stgVarBody(v) );
+ stgTopSanity ( "inner-3", stgVarBody(v));
+ stgVarBody(v) = simplify ( NIL, stgVarBody(v) );
+
+ if (me && 0) {
+ fprintf(stderr,"\n-%d- - - - - - - - - - - - - -\n", n+1);
+ printStg ( stderr,v );
+ }
+ stgTopSanity ( "inner-post", stgVarBody(v));
+
+ }
+
+ if (me && 1) {
+ fprintf(stderr,"\n-%d-=-=-=-=-=-=-=-=-=-=-=-=-=-\n", n+1);
+ printStg ( stderr,v );
+ }
+
+ stgTopSanity ( "outer-post", stgVarBody(v));
+
+ newSize = stgSize ( stgVarBody(v) );
+ if (newSize == oldSize) break;
+ oldSize = newSize;
+ }
+ n++; for (; n < 8; n++) for (m = 0; m <= 3+3; m++) if (noisy) printf ( " " );
+ if (noisy) printf(" --> %4d\n", stgSize(stgVarBody(v)) );
+ stgVarBody(v) = restoreStgTop ( stgVarBody(v) );
+
+ if (nonNull(naam)) {
+ assert(name(naam).stgVar == v);
+ name(naam).stgSize = stgSize(stgVarBody(v));
+ }
+
+#if DEBUG_OPTIMISE
+ /* debugging ... */
+ if (!isStgFullExpr(stgVarBody(v))) {
+ fprintf(stderr, "\n\nrestoreStg failed!\n\n" );
+ printStg(stderr, v);
+ fprintf(stderr, "\n" );
+ exit(1);
+ }
+#endif
+ }
+
+ nTotSizeOut += stgSize(stgVarBody(v));
+
+ if (me) {
+ fprintf(stderr,"\n=============================\n");
+ printStg ( stderr,v );
+ fprintf(stderr, "\n\n" );
+ fflush(stderr);
+ if (me) exit(1);
+ }
+}
+
+
+void optimiseTopBinds ( List bs )
+{
+ List t;
+ Name n;
+ Target ta = 0;
+
+ noisy = ddumpSimpl && (lastModule() != modulePrelude);
+
+ optimiser(RESET);
+ if (noisy) printf("\n");
+ initOptStats();
+
+ for (t = bs; nonNull(t); t=tl(t)) {
+ n = nameFromStgVar(hd(t));
+ if (isNull(n) || !name(n).simplified) {
+ rDepth = 0;
+ optimiseTopBind(hd(t));
+ }
+ soFar(ta++);
+ }
+ if (noisy) printOptStats ( stderr );
+ optimiser(RESET);
+}
+
+
+/* --------------------------------------------------------------------------
+ * Optimiser control:
+ * ------------------------------------------------------------------------*/
+
+Void optimiser(what)
+Int what; {
+
+ switch (what) {
+ case INSTALL :
+ case RESET : spClone = SP_NOT_IN_USE;
+ initStgVarSets();
+ daSccs = NIL;
+ break;
+
+ case MARK : markPairs();
+ markStgVarSets();
+ mark(daSccs);
+ break;
+
+ case GCDONE : checkStgVarSets();
+ break;
+ }
}
/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / blobdiff