* 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"
* 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 );
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);
}
} 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
}
}
}
}
-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);
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;
}
static void liftAlt( StgCaseAlt alt )
{
- liftExpr(stgCaseAltBody(alt));
+ if (isDefaultAlt(alt))
+ liftExpr(stgDefaultBody(alt)); else
+ liftExpr(stgCaseAltBody(alt));
}
static void liftPrimAlt( StgPrimAlt alt )
{
switch (whatIs(e)) {
case LETREC:
- stgLetBinds(e) = liftLetBinds(stgLetBinds(e));
+ stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
liftExpr(stgLetBody(e));
break;
case LAMBDA:
}
}
+/* 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;
}
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;
}
}
projects / ghc-hetmet.git / blobdiff