X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Flift.c;h=b41d1f5ff8064fbad1b9a8de3304f86c86cd0aee;hb=d1417a2edfcc842415bb651be80d5669a31cd717;hp=4649901712da60955c78a90faa8f54bbcf4d9a0c;hpb=57131ad0203977941eb50d60550fa82e88614496;p=ghc-hetmet.git diff --git a/ghc/interpreter/lift.c b/ghc/interpreter/lift.c index 4649901..b41d1f5 100644 --- a/ghc/interpreter/lift.c +++ b/ghc/interpreter/lift.c @@ -5,18 +5,19 @@ * This is a very simple lambda lifter - it doesn't try to do Johnsson-style * lambda lifting (yet). * - * Copyright (c) The University of Nottingham and Yale University, 1994-1997. - * All rights reserved. See NOTICE for details and conditions of use etc... - * Hugs version 1.4, December 1997 + * 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: lift.c,v $ - * $Revision: 1.3 $ - * $Date: 1999/02/03 17:08:31 $ + * $Revision: 1.13 $ + * $Date: 2000/03/23 14:54:21 $ * ------------------------------------------------------------------------*/ -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" -#include "backend.h" #include "connect.h" #include "errors.h" @@ -25,12 +26,14 @@ * Local function prototypes: * ------------------------------------------------------------------------*/ -static List liftedBinds = NIL; +static List liftedBinds = NIL; +static Bool makeInlineable = FALSE; +static Int inlineCounter = 0; static StgExpr abstractExpr ( List vars, StgExpr e ); static inline Bool isTopLevel( StgVar v ); static List filterFreeVars( List vs ); -static List liftLetBinds ( List binds ); +static List liftLetBinds ( List binds, Bool topLevel ); static void liftAlt ( StgCaseAlt alt ); static void liftPrimAlt ( StgPrimAlt alt ); static void liftExpr ( StgExpr e ); @@ -47,6 +50,7 @@ static StgExpr abstractExpr( List vars, StgExpr e ) for(; nonNull(vars); vars=tl(vars)) { StgVar var = hd(vars); StgVar arg = mkStgVar(NIL,NIL); + stgVarRep(arg) = stgVarRep(var); args = cons(arg,args); sub = cons(pair(var,arg),sub); } @@ -62,18 +66,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 - StgRhs rhs = stgVarBody(v); - switch (whatIs(rhs)) { - case STGCON: - case STGAPP: - return isNull(stgVarInfo(v)); - default: - return FALSE; - } -#else return FALSE; -#endif } } @@ -93,28 +86,17 @@ static List filterFreeVars( List vs ) } } -static List liftLetBinds( List binds ) +static List liftLetBinds( List binds, Bool topLevel ) { List bs = NIL; for(; nonNull(binds); binds=tl(binds)) { StgVar bind = hd(binds); StgRhs rhs = stgVarBody(bind); List fvs = filterFreeVars(stgVarInfo(bind)); - /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */ switch (whatIs(rhs)) { case STGCON: case STGAPP: -#if LIFT_CONSTANTS - if (isNull(fvs)) { - StgVar v = mkStgVar(rhs,NONE); - stgVarBody(bind) = mkStgLet(singleton(v),v); - /* ppStg(v); */ - liftedBinds = cons(bind,liftedBinds); - break; - } - /* deliberate fall through */ -#endif case STGVAR: case NAME: bs = cons(bind,bs); @@ -123,22 +105,18 @@ static List liftLetBinds( List binds ) liftExpr(rhs); if (nonNull(fvs)) { StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE); - /* ppStg(v); */ - liftedBinds = cons(v,liftedBinds); - stgVarBody(bind) = makeStgApp(v, fvs); - } -#if 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; + if (makeInlineable) { + Name n; + char s[16]; + sprintf(s,"lam%d",inlineCounter++); + n = newName(findText(s),NIL); + name(n).stgVar = v; + stgVarBody(bind) = makeStgApp(n, fvs); + } else { + stgVarBody(bind) = makeStgApp(v, fvs); + } } - /* deliberate fall through */ -#endif bs = cons(bind,bs); break; } @@ -148,7 +126,9 @@ static List liftLetBinds( List binds ) static void liftAlt( StgCaseAlt alt ) { - liftExpr(stgCaseAltBody(alt)); + if (isDefaultAlt(alt)) + liftExpr(stgDefaultBody(alt)); else + liftExpr(stgCaseAltBody(alt)); } static void liftPrimAlt( StgPrimAlt alt ) @@ -160,7 +140,7 @@ static void liftExpr( StgExpr e ) { switch (whatIs(e)) { case LETREC: - stgLetBinds(e) = liftLetBinds(stgLetBinds(e)); + stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE); liftExpr(stgLetBody(e)); break; case LAMBDA: @@ -186,17 +166,28 @@ static void liftExpr( StgExpr e ) } } +/* Lift a list of top-level binds. */ List liftBinds( List binds ) { List bs; + for(bs=binds; nonNull(bs); bs=tl(bs)) { StgVar bind = hd(bs); + + if (debugSC) { + if (currentModule != modulePrelude) { + fprintf(stderr, "\n"); + ppStg(hd(bs)); + fprintf(stderr, "\n"); + } + } freeVarsBind(NIL,bind); stgVarInfo(bind) = NONE; /* mark as top level */ } + liftedBinds = NIL; - binds = liftLetBinds(binds); - binds = revOnto(liftedBinds,binds); + binds = liftLetBinds(binds,TRUE); + binds = revOnto(liftedBinds,binds); liftedBinds = NIL; return binds; } @@ -208,14 +199,15 @@ List liftBinds( List binds ) Void liftControl(what) Int what; { switch (what) { - case INSTALL: - /* deliberate fall though */ - case RESET: - liftedBinds = NIL; - break; - case MARK: - mark(liftedBinds); - break; + case POSTPREL: break; + + case PREPREL: + case RESET: + liftedBinds = NIL; + break; + case MARK: + mark(liftedBinds); + break; } }