+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Optimiser
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: optimise.c,v $
- * $Revision: 1.7 $
- * $Date: 1999/10/15 21:40:52 $
- * ------------------------------------------------------------------------*/
-
-#include "prelude.h"
-#include "storage.h"
-#include "backend.h"
-#include "connect.h"
-#include "errors.h"
-#include "link.h"
-#include "Assembler.h"
-
-/* #define DEBUG_OPTIMISE */
-
-extern void print ( Cell, Int );
-
-/* --------------------------------------------------------------------------
- * Local functions
- * ------------------------------------------------------------------------*/
-
-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)))
-
-
-/* --------------------------------------------------------------------------
- * Transformation stats
- * ------------------------------------------------------------------------*/
-
-void initOptStats ( void )
-{
- 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));
-}
-
-
-/* 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 )
-{
- List xs, newvs;
- StgVar newv;
- StgExpr t;
-
- 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;
-}
-
-
-/* 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.
- */
- 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);
- }
-}
-
-
-
-/* --------------------------------------------------------------------------
- * 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 )
-{
- 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);
- }
-}
-
-
-/* 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;
-}
-
-
-/* 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 )
-{
- 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;
-}
-
-
-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 / commitdiff