X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Foptimise.c;fp=ghc%2Finterpreter%2Foptimise.c;h=313116c6ef76bbe3223431c51b2ca268cfbc458c;hb=b9ad54f9b2bb99d2d3d62c61e2da71e076938f18;hp=a8913891bf1e1a535b0a885ef1b9b0c5c3046ad8;hpb=2948d495129c7d4d2067d4609fc8bf392a019d82;p=ghc-hetmet.git diff --git a/ghc/interpreter/optimise.c b/ghc/interpreter/optimise.c index a891389..313116c 100644 --- a/ghc/interpreter/optimise.c +++ b/ghc/interpreter/optimise.c @@ -7,8 +7,8 @@ * 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" @@ -16,221 +16,2356 @@ #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; + } } /*-------------------------------------------------------------------------*/