From: sewardj Date: Fri, 12 Nov 1999 17:32:48 +0000 (+0000) Subject: [project @ 1999-11-12 17:32:36 by sewardj] X-Git-Tag: Approximately_9120_patches~5558 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=8aaa69d48f3d866727620c7d7e3a663dde3fb02a;p=ghc-hetmet.git [project @ 1999-11-12 17:32:36 by sewardj] Delete optimiser.c (the simplifier) and all supporting bits and pieces. --- diff --git a/ghc/includes/options.h b/ghc/includes/options.h index e060b27..ac8e283 100644 --- a/ghc/includes/options.h +++ b/ghc/includes/options.h @@ -13,8 +13,8 @@ * Hugs version 1.4, December 1997 * * $RCSfile: options.h,v $ - * $Revision: 1.11 $ - * $Date: 1999/11/12 16:38:33 $ + * $Revision: 1.12 $ + * $Date: 1999/11/12 17:32:36 $ * ------------------------------------------------------------------------*/ @@ -118,7 +118,7 @@ #define MINIMUMHEAP Pick(7500, 19000, 19000) #define MAXIMUMHEAP Pick(32765, 0, 0) -#define DEFAULTHEAP Pick(28000, 50000, 650000) +#define DEFAULTHEAP Pick(28000, 50000, 300000) #define NUM_SCRIPTS Pick(64, 100, 100) #define NUM_MODULE NUM_SCRIPTS @@ -202,16 +202,6 @@ */ #define DEFAULT_BIGNUM 1 -/* Should lambda lifter lift constant expressions out to top level? - * Experimental optimisation. - */ -#define LIFT_CONSTANTS 0 - -/* Should we run optimizer on Hugs code? - * Experimental optimisation. - */ -#define USE_HUGS_OPTIMIZER 1 - /* Are things being used in an interactive setting or a batch setting? * In an interactive setting, System.exitWith should not call _exit * getProgName and getProgArgs need to be handled differently, etc. diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile index 7ff9694..ff6bc04 100644 --- a/ghc/interpreter/Makefile +++ b/ghc/interpreter/Makefile @@ -1,6 +1,6 @@ # ----------------------------------------------------------------------------- # -# $Id: Makefile,v 1.16 1999/11/12 16:38:31 sewardj Exp $ # +# $Id: Makefile,v 1.17 1999/11/12 17:32:37 sewardj Exp $ # # ----------------------------------------------------------------------------- # TOP = ../.. @@ -21,7 +21,7 @@ DYN_EXT=.so LIB_DL=-ldl endif -ifeq "$(HaveLibReadLine)$" "YES" +ifeq "$(HaveLibReadline)$" "YES" LIB_READLINE=-lreadline else LIB_READLINE= @@ -37,7 +37,7 @@ HS_SRCS = Y_SRCS = parser.y C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \ - translate.c codegen.c lift.c free.c stgSubst.c optimise.c output.c \ + translate.c codegen.c lift.c free.c stgSubst.c output.c \ hugs.c dynamic.c stg.c sainteger.c interface.c SRC_CC_OPTS = -g -O -I$(GHC_DIR)/interpreter -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -DCOMPILING_RTS -Wall -Wstrict-prototypes -Wno-unused -DDEBUG -DDEBUG_EXTRA -Winline @@ -50,8 +50,8 @@ all :: parser.c $(GHC_LIBS_NEEDED) nHandle.$(DYN_EXT) hugs hugs: $(C_OBJS) ../rts/Sanity.o ../rts/Assembler.o ../rts/Disassembler.o \ ../rts/Evaluator.o ../rts/ForeignCall.o ../rts/GC.o ../rts/Printer.o \ ../rts/StgCRun.o - $(CC) -o $@ $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) -lreadline \ - -lbfd -liberty $(LIB_READLINE) $(LIB_DL) -lm + $(CC) -o $@ $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) \ + -lbfd -liberty $(LIB_READLINE) $(LIB_DL) -lm nHandle.$(DYN_EXT): nHandle.c ifeq "$(TARGETPLATFORM)" "i386-unknown-cygwin32" diff --git a/ghc/interpreter/backend.h b/ghc/interpreter/backend.h index 9df6b14..fb3a8a0 100644 --- a/ghc/interpreter/backend.h +++ b/ghc/interpreter/backend.h @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: backend.h,v $ - * $Revision: 1.5 $ - * $Date: 1999/10/15 21:41:02 $ + * $Revision: 1.6 $ + * $Date: 1999/11/12 17:32:37 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -128,8 +128,6 @@ extern Bool isStgVar ( StgRhs rhs ); extern Bool isAtomic ( StgRhs rhs ); extern StgVar mkStgVar ( StgRhs rhs, Cell info ); -extern Int stgSize ( StgExpr e ); - #define mkStgRep(c) mkChar(c) /*-------------------------------------------------------------------------*/ @@ -181,10 +179,8 @@ extern List liftBinds( List binds ); extern Void liftControl ( Int what ); extern StgExpr substExpr ( List sub, StgExpr e ); -extern StgExpr zubstExpr ( List sub, StgExpr e ); extern List freeVarsBind Args((List, StgVar)); -extern Void optimiseBind Args((StgVar)); #ifdef CRUDE_PROFILING extern void cp_init ( void ); diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c index ef0be9b..784d8aa 100644 --- a/ghc/interpreter/compiler.c +++ b/ghc/interpreter/compiler.c @@ -11,8 +11,8 @@ * included in the distribution. * * $RCSfile: compiler.c,v $ - * $Revision: 1.11 $ - * $Date: 1999/11/11 17:42:31 $ + * $Revision: 1.12 $ + * $Date: 1999/11/12 17:32:37 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1602,14 +1602,6 @@ Void compileDefns() { /* compile script definitions */ binds = addGlobals(binds); done(); -#if USE_HUGS_OPTIMIZER - if (optimise) { - t = length(binds); - setGoal("Simplifying",t); - optimiseTopBinds(binds); - done(); - } -#endif setGoal("Generating code",t); stgCGBinds(binds); diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 06a2983..93be39b 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -8,8 +8,8 @@ * included in the distribution. * * $RCSfile: connect.h,v $ - * $Revision: 1.14 $ - * $Date: 1999/10/29 11:41:04 $ + * $Revision: 1.15 $ + * $Date: 1999/11/12 17:32:38 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -160,7 +160,6 @@ extern Bool gcMessages; /* TRUE => print GC messages */ extern Bool literateScripts; /* TRUE => default lit scripts */ extern Bool literateErrors; /* TRUE => report errs in lit scrs */ extern Bool showInstRes; /* TRUE => show instance resolution */ -extern Bool optimise; /* TRUE => simplify STG */ extern Int cutoff; /* Constraint Cutoff depth */ @@ -532,7 +531,6 @@ extern Void unlexStrConst Args((Text)); extern Void unlexVar Args((Text)); extern List offsetTyvarsIn Args((Type,List)); -extern Void optimiseTopBinds Args((List)); extern List cfunSfuns; /* List of (Cfun,[SelectorVar]) */ extern Void interface Args((Int)); diff --git a/ghc/interpreter/derive.c b/ghc/interpreter/derive.c index 37f1336..f3ea7cf 100644 --- a/ghc/interpreter/derive.c +++ b/ghc/interpreter/derive.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: derive.c,v $ - * $Revision: 1.8 $ - * $Date: 1999/11/01 04:17:37 $ + * $Revision: 1.9 $ + * $Date: 1999/11/12 17:32:38 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -927,7 +927,6 @@ Tycon t; { name(nm).arity = 1; name(nm).stgVar = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)), NIL); - name(nm).stgSize = stgSize(stgVarBody(name(nm).stgVar)); tycon(t).conToTag = nm; /* hack to make it print out */ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals); @@ -1007,7 +1006,6 @@ Tycon t; { mkStgPrimCase(v2,alts))))), NIL ); - name(nm).stgSize = stgSize(stgVarBody(name(nm).stgVar)); tycon(t).tagToCon = nm; /* hack to make it print out */ stgGlobals = cons(pair(nm,name(nm).stgVar),stgGlobals); diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 07a5316..bb8fa93 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.18 $ - * $Date: 1999/11/12 14:32:44 $ + * $Revision: 1.19 $ + * $Date: 1999/11/12 17:32:39 $ * ------------------------------------------------------------------------*/ #include @@ -114,7 +114,6 @@ static Bool useDots = RISCOS; /* TRUE => use dots in progress */ static Bool quiet = FALSE; /* TRUE => don't show progress */ static Bool lastWasObject = FALSE; Bool preludeLoaded = FALSE; - Bool optimise = FALSE; typedef struct { @@ -189,10 +188,9 @@ return; scriptInfo[i].path ); } - // printf ( "\n" ); fflush(stdout);fflush(stderr); -ppScripts(); -ppModules(); + ppScripts(); + ppModules(); printf ( "\n" ); } @@ -323,7 +321,6 @@ String argv[]; { #endif - #if 0 if (!scriptName[0]) { Printf("Prelude not found on current path: \"%s\"\n", @@ -749,7 +746,6 @@ struct options toggle[] = { /* List of command line toggles */ {'w', 1, "Always show which modules are loaded", &listScripts}, {'k', 1, "Show kind errors in full", &kindExpert}, {'o', 0, "Allow overlapping instances", &allowOverlap}, - {'O', 1, "Optimise (improve?) generated code", &optimise}, #if DEBUG_CODE @@ -1583,7 +1579,6 @@ static Void local dumpStg( void ) { /* print STG stuff */ if (isNull(n) && whatIs(v)==STGVAR) { Printf ( "\n{- `%s' has no nametable entry -}\n", s ); - Printf ( "{- stgSize of body is %d -}\n\n", stgSize(stgVarBody(v))); printStg(stderr, v ); } else if (isNull(n)) { @@ -1596,8 +1591,6 @@ static Void local dumpStg( void ) { /* print STG stuff */ Printf ( "Doesn't have a STG tree: %s\n", s ); } else { Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar); - Printf ( "{- stgSize of body is %d -}\n\n", - stgSize(stgVarBody(name(n).stgVar))); printStg(stderr, name(n).stgVar); } } @@ -2349,7 +2342,6 @@ Int what; { /* system to respond as appropriate ... */ typeChecker(what); compiler(what); codegen(what); - optimiser(what); } /* -------------------------------------------------------------------------- diff --git a/ghc/interpreter/lift.c b/ghc/interpreter/lift.c index 82544f4..8f237eb 100644 --- a/ghc/interpreter/lift.c +++ b/ghc/interpreter/lift.c @@ -12,8 +12,8 @@ * included in the distribution. * * $RCSfile: lift.c,v $ - * $Revision: 1.6 $ - * $Date: 1999/10/15 21:40:51 $ + * $Revision: 1.7 $ + * $Date: 1999/11/12 17:32:40 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -67,19 +67,7 @@ static inline Bool isTopLevel( StgVar v ) } else if (stgVarInfo(v) == NONE) { return TRUE; /* those at top level are already there */ } else { -#if LIFT_CONSTANTS -#error lift constants - StgRhs rhs = stgVarBody(v); - switch (whatIs(rhs)) { - case STGCON: - case STGAPP: - return isNull(stgVarInfo(v)); - default: - return FALSE; - } -#else return FALSE; -#endif } } @@ -106,31 +94,10 @@ static List liftLetBinds( List binds, Bool topLevel ) StgVar bind = hd(binds); StgRhs rhs = stgVarBody(bind); List fvs = filterFreeVars(stgVarInfo(bind)); - /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */ - - /* if starting on a new top-level inlineable bind, ensure that - the lifted-out binds get marked inlineable too - */ - if (topLevel) { - Name n = nameFromStgVar(bind); - makeInlineable = FALSE; - if (nonNull(n) && name(n).inlineMe==TRUE) makeInlineable = TRUE; - } switch (whatIs(rhs)) { case STGCON: case STGAPP: -#if LIFT_CONSTANTS -#error lift constants - if (isNull(fvs)) { - StgVar v = mkStgVar(rhs,NONE); - stgVarBody(bind) = mkStgLet(singleton(v),v); - /* ppStg(v); */ /* check inlinable */ - liftedBinds = cons(bind,liftedBinds); - break; - } - /* deliberate fall through */ -#endif case STGVAR: case NAME: bs = cons(bind,bs); @@ -146,26 +113,11 @@ static List liftLetBinds( List binds, Bool topLevel ) sprintf(s,"lam%d",inlineCounter++); n = newName(findText(s),NIL); name(n).stgVar = v; - name(n).simplified = TRUE; /* optimiser is upstream of lifter */ - if (makeInlineable) name(n).inlineMe = TRUE; stgVarBody(bind) = makeStgApp(n, fvs); } else { stgVarBody(bind) = makeStgApp(v, fvs); } } -#if LIFT_CONSTANTS -#error lift constants - else { - StgVar r = mkStgVar(rhs,NIL); /* copy the var */ - StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE); - stgVarBody(bind) = v; /* indirection to r */ - /* ppStg(v); */ - liftedBinds = cons(v,liftedBinds); - bs = cons(bind,bs); /* keep the old binding */ - break; - } - /* deliberate fall through */ -#endif bs = cons(bind,bs); break; } @@ -227,15 +179,8 @@ List liftBinds( List binds ) } liftedBinds = NIL; - binds = liftLetBinds(binds,TRUE); - binds = revOnto(liftedBinds,binds); - - for (bs=binds; nonNull(bs); bs=tl(bs)) { - Name n = nameFromStgVar(hd(bs)); - if (nonNull(n)) - name(n).stgSize = stgSize(stgVarBody(name(n).stgVar)); - } - + binds = liftLetBinds(binds,TRUE); + binds = revOnto(liftedBinds,binds); liftedBinds = NIL; return binds; } diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index ff18e6e..3ac5f76 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: link.c,v $ - * $Revision: 1.11 $ - * $Date: 1999/11/01 11:01:11 $ + * $Revision: 1.12 $ + * $Date: 1999/11/12 17:32:40 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -492,7 +492,6 @@ Void linkPreludeNames(void) { /* Hook to names defined in Prelude */ namePmInt = linkName("primPmInt"); namePmInteger = linkName("primPmInteger"); namePmDouble = linkName("primPmDouble"); - name(namePmInt).inlineMe = TRUE; } } @@ -554,7 +553,6 @@ Int what; { pFun(nameComp, "."); pFun(nameAnd, "&&"); pFun(nameCompAux, "primCompAux"); - name(nameCompAux).inlineMe = TRUE; pFun(nameMap, "map"); /* implementTagToCon */ @@ -562,9 +560,6 @@ Int what; { pFun(nameError, "error"); pFun(nameUnpackString, "primUnpackString"); - // /* foreign export dynamic */ - //pFun(nameCreateAdjThunk, "primCreateAdjThunk"); - /* hooks for handwritten bytecode */ pFun(namePrimSeq, "primSeq"); pFun(namePrimCatch, "primCatch"); diff --git a/ghc/interpreter/optimise.c b/ghc/interpreter/optimise.c deleted file mode 100644 index 7341076..0000000 --- a/ghc/interpreter/optimise.c +++ /dev/null @@ -1,2375 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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; - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/output.c b/ghc/interpreter/output.c index 648a32d..03187a5 100644 --- a/ghc/interpreter/output.c +++ b/ghc/interpreter/output.c @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: output.c,v $ - * $Revision: 1.11 $ - * $Date: 1999/11/11 16:24:12 $ + * $Revision: 1.12 $ + * $Date: 1999/11/12 17:32:42 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -378,7 +378,7 @@ static Void local putAp(d,e) /* print application (args>=1) */ Int d; Cell e; { Cell h; - Text t; + Text t = 0; /* bogus init to keep gcc -O happy */ Syntax sy; Int args = 0; diff --git a/ghc/interpreter/runallnofib b/ghc/interpreter/runallnofib index 38ea3bf..a35051c 100644 --- a/ghc/interpreter/runallnofib +++ b/ghc/interpreter/runallnofib @@ -5,7 +5,7 @@ echo "runallnofib: Can't cd to nofibtmp" exit fi -TROOT=/home/v-julsew/Oct11 +TROOT=/home/v-julsew/Oct19 NROOT=$TROOT/fpO/nofib cd nofibtmp @@ -15,7 +15,7 @@ cd nofibtmp ../runnofib imaginary exp3_8 ../runnofib imaginary gen_regexps -../runnofib imaginary paraffins +../runnofib imaginary paraffins ../runnofib imaginary primes ../runnofib imaginary rfib ../runnofib imaginary tak diff --git a/ghc/interpreter/runnofib b/ghc/interpreter/runnofib index 3167702..98d2b21 100644 --- a/ghc/interpreter/runnofib +++ b/ghc/interpreter/runnofib @@ -1,6 +1,6 @@ #!/bin/bash -TROOT=/home/v-julsew/Oct11 +TROOT=/home/v-julsew/Oct19 STGHUGSFLAGS=-P$TROOT/fpO/ghc/interpreter/lib NROOT=$TROOT/fpO/nofib diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index 3313ad6..0f665fd 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: static.c,v $ - * $Revision: 1.15 $ - * $Date: 1999/11/09 00:40:12 $ + * $Revision: 1.16 $ + * $Date: 1999/11/12 17:32:43 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1541,7 +1541,6 @@ Class parent; { name(m).arity = 1; name(m).number = mfunNo(no); name(m).type = t; - name(m).inlineMe = TRUE; return m; } @@ -4888,7 +4887,7 @@ Void checkExp() { /* Top level static check on Expr */ staticAnalysis(RESET); } -Void checkContext() { /* Top level static check on Expr */ +Void checkContext(void) { /* Top level static check on Expr */ List vs, qs; staticAnalysis(RESET); diff --git a/ghc/interpreter/stg.c b/ghc/interpreter/stg.c index 0b4dadc..742fe27 100644 --- a/ghc/interpreter/stg.c +++ b/ghc/interpreter/stg.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: stg.c,v $ - * $Revision: 1.7 $ - * $Date: 1999/10/15 21:40:57 $ + * $Revision: 1.8 $ + * $Date: 1999/11/12 17:32:45 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -183,7 +183,6 @@ static Void putStgAlts ( Int left, List alts ); static Void local putStgVar(StgVar v) { if (isName(v)) { - if (name(v).inlineMe) putStr("IL__"); unlexVar(name(v).text); } else { putStr("id"); @@ -535,7 +534,6 @@ StgVar b; beginStgPP(fp); n = nameFromStgVar(b); if (nonNull(n)) { - if (name(n).inlineMe) { putStr("INLINE\n"); pIndent(0); }; putStr(textToStr(name(n).text)); } else { putStgVar(b); diff --git a/ghc/interpreter/stgSubst.c b/ghc/interpreter/stgSubst.c index 83d70c0..6a401c6 100644 --- a/ghc/interpreter/stgSubst.c +++ b/ghc/interpreter/stgSubst.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: stgSubst.c,v $ - * $Revision: 1.5 $ - * $Date: 1999/10/15 21:40:57 $ + * $Revision: 1.6 $ + * $Date: 1999/11/12 17:32:46 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -116,63 +116,4 @@ StgExpr substExpr( List sub, StgExpr e ) } -/* A substitution engine more suitable for the optimiser. - Doesn't make so many assumptions about what is an atom. -*/ -StgExpr zubstExpr( List sub, StgExpr e ) -{ - List bs; - switch (whatIs(e)) { - case LETREC: - for (bs=stgLetBinds(e); nonNull(bs); bs=tl(bs)) - stgVarBody(hd(bs)) = zubstExpr(sub,stgVarBody(hd(bs))); - stgLetBody(e) = zubstExpr(sub,stgLetBody(e)); - break; - case LAMBDA: - stgLambdaBody(e) = zubstExpr(sub,stgLambdaBody(e)); - break; - case CASE: - stgCaseScrut(e) = zubstExpr(sub,stgCaseScrut(e)); - map1Proc(zubstExpr,sub,stgCaseAlts(e)); - break; - case PRIMCASE: - stgPrimCaseScrut(e) = zubstExpr(sub,stgPrimCaseScrut(e)); - map1Proc(zubstExpr,sub,stgPrimCaseAlts(e)); - break; - case CASEALT: - stgCaseAltBody(e) = zubstExpr(sub,stgCaseAltBody(e)); - break; - case DEEFALT: - stgDefaultBody(e) = zubstExpr(sub,stgDefaultBody(e)); - break; - case PRIMALT: - stgPrimAltBody(e) = zubstExpr(sub,stgPrimAltBody(e)); - break; - case STGPRIM: - map1Over(zubstExpr,sub,stgPrimArgs(e)); - break; - case STGAPP: - stgAppFun(e) = zubstExpr(sub,stgAppFun(e)); - map1Over(zubstExpr,sub,stgAppArgs(e)); - break; - case STGCON: - map1Over(zubstExpr,sub,stgConArgs(e)); - break; - case STGVAR: - return substVar(sub,e); - case NAME: - case INTCELL: - case STRCELL: - case PTRCELL: - case CHARCELL: - case FLOATCELL: - break; - default: - internal("zubstExpr"); - } - return e; -} - - - /*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 72e9a19..90bb906 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.14 $ - * $Date: 1999/10/26 17:27:43 $ + * $Revision: 1.15 $ + * $Date: 1999/11/12 17:32:46 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -434,10 +434,6 @@ Cell parent; { name(nameHw).number = EXECNAME; name(nameHw).defn = NIL; name(nameHw).stgVar = NIL; - name(nameHw).stgSize = 0; - name(nameHw).inlineMe = FALSE; - name(nameHw).simplified = FALSE; - name(nameHw).isDBuilder = FALSE; name(nameHw).callconv = NIL; name(nameHw).type = NIL; name(nameHw).primop = 0; diff --git a/ghc/interpreter/storage.h b/ghc/interpreter/storage.h index 342e983..c0560b3 100644 --- a/ghc/interpreter/storage.h +++ b/ghc/interpreter/storage.h @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: storage.h,v $ - * $Revision: 1.11 $ - * $Date: 1999/10/26 17:27:42 $ + * $Revision: 1.12 $ + * $Date: 1999/11/12 17:32:47 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -551,10 +551,6 @@ struct strName { Cell type; Cell defn; Cell stgVar; /* really StgVar */ - Int stgSize; /* == stgSize(stgVarBody(.stgVar)) */ - Bool inlineMe; /* self-evident */ - Bool simplified; /* TRUE => already simplified */ - Bool isDBuilder; /* TRUE => is a dictionary builder */ Text callconv; /* for foreign import/export */ const void* primop; /* really StgPrim* */ Name nextNameHash; diff --git a/ghc/interpreter/translate.c b/ghc/interpreter/translate.c index c184d7c..f54cf20 100644 --- a/ghc/interpreter/translate.c +++ b/ghc/interpreter/translate.c @@ -10,8 +10,8 @@ * included in the distribution. * * $RCSfile: translate.c,v $ - * $Revision: 1.14 $ - * $Date: 1999/11/01 11:07:07 $ + * $Revision: 1.15 $ + * $Date: 1999/11/12 17:32:48 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -455,11 +455,6 @@ Void stgDefn( Name n, Int arity, Cell e ) } stgVarBody(name(n).stgVar) = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail)); - s = stgSize(stgVarBody(name(n).stgVar)); - name(n).stgSize = s; - if (s <= SMALL_INLINE_SIZE && !name(n).inlineMe) { - name(n).inlineMe = TRUE; - } } Void implementCfun(c,scs) /* Build implementation for constr */ @@ -487,8 +482,6 @@ List scs; { /* in incr order of strict comps. */ StgVar v = mkStgVar(mkStgCon(c,NIL),NIL); name(c).stgVar = v; } - name(c).inlineMe = TRUE; - name(c).stgSize = stgSize(stgVarBody(name(c).stgVar)); stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals); /* printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n"); */ } @@ -752,8 +745,6 @@ Name n; { StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results); StgVar v = mkStgVar(rhs,NIL); name(n).stgVar = v; - name(n).stgSize = stgSize(stgVarBody(v)); - name(n).inlineMe = TRUE; stgGlobals=cons(pair(n,v),stgGlobals); /* so it will get codegened */ } @@ -848,11 +839,8 @@ Void implementForeignImport ( Name n ) textToStr(textOf(fst(extName))) EEND; } - /* ppStg(v); */ name(n).defn = NIL; name(n).stgVar = v; - name(n).stgSize = stgSize(stgVarBody(v)); - name(n).inlineMe = TRUE; stgGlobals=cons(pair(n,v),stgGlobals);/*so it will get codegen'd */ } } @@ -958,12 +946,9 @@ Void implementForeignExport ( Name n ) ); v = mkStgVar(fun,NIL); - /* ppStg(v); */ name(n).defn = NIL; name(n).stgVar = v; - name(n).stgSize = stgSize(stgVarBody(v)); - name(n).inlineMe = FALSE; stgGlobals = cons(pair(n,v),stgGlobals); } } diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index 9ec97c5..69c227f 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: type.c,v $ - * $Revision: 1.10 $ - * $Date: 1999/10/16 02:17:26 $ + * $Revision: 1.11 $ + * $Date: 1999/11/12 17:32:48 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -1825,7 +1825,6 @@ Class c; { /* defaults for class c */ name(hd(dsels)).defn = singleton(pair(pat, ap(mkInt(cclass(c).line), nthArg(i++,hd(pat))))); - name(hd(dsels)).inlineMe = TRUE; genDefns = cons(hd(dsels),genDefns); } for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) { @@ -1930,8 +1929,6 @@ Inst in; { /* member functions for instance in*/ name(inst(in).builder).defn /* Register builder imp */ = singleton(pair(args,ap(LETREC,pair(singleton(locs), ap(l,d))))); - name(inst(in).builder).inlineMe = TRUE; - name(inst(in).builder).isDBuilder = TRUE; genDefns = cons(inst(in).builder,genDefns); } @@ -2378,8 +2375,8 @@ Name s; { /* particular selector, s. */ Type rng = NIL; /* Inferred range */ Cell nv = inventVar(); List alts = NIL; - Int o; - Int m; + Int o = 0; /* bogus init to keep gcc -O happy */ + Int m = 0; /* bogus init to keep gcc -O happy */ #ifdef DEBUG_SELS Printf("Selector %s, cns=",textToStr(name(s).text));