2 /* --------------------------------------------------------------------------
5 * This is a very simple lambda lifter - it doesn't try to do Johnsson-style
6 * lambda lifting (yet).
8 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
9 * All rights reserved. See NOTICE for details and conditions of use etc...
10 * Hugs version 1.4, December 1997
12 * $RCSfile: lift.c,v $
14 * $Date: 1999/03/01 14:46:47 $
15 * ------------------------------------------------------------------------*/
24 /* --------------------------------------------------------------------------
25 * Local function prototypes:
26 * ------------------------------------------------------------------------*/
28 static List liftedBinds = NIL;
30 static StgExpr abstractExpr ( List vars, StgExpr e );
31 static inline Bool isTopLevel( StgVar v );
32 static List filterFreeVars( List vs );
33 static List liftLetBinds ( List binds );
34 static void liftAlt ( StgCaseAlt alt );
35 static void liftPrimAlt ( StgPrimAlt alt );
36 static void liftExpr ( StgExpr e );
38 /* --------------------------------------------------------------------------
40 * ------------------------------------------------------------------------*/
42 /* abstract variables out of an expression */
43 static StgExpr abstractExpr( List vars, StgExpr e )
46 List sub = NIL; /* association list */
47 for(; nonNull(vars); vars=tl(vars)) {
48 StgVar var = hd(vars);
49 StgVar arg = mkStgVar(NIL,NIL);
50 args = cons(arg,args);
51 sub = cons(pair(var,arg),sub);
53 return makeStgLambda(rev(args),substExpr(sub,e));
56 /* ToDo: should be conservative estimate but isn't */
57 /* Will a variable be floated out to top level - conservative estimate? */
58 static inline Bool isTopLevel( StgVar v )
60 if (isNull(stgVarBody(v))) {
61 return FALSE; /* only let bound vars can be floated */
62 } else if (stgVarInfo(v) == NONE) {
63 return TRUE; /* those at top level are already there */
67 StgRhs rhs = stgVarBody(v);
68 switch (whatIs(rhs)) {
71 return isNull(stgVarInfo(v));
81 static List filterFreeVars( List vs )
87 for(; nonNull(vs); vs=tl(vs)) {
97 static List liftLetBinds( List binds )
100 for(; nonNull(binds); binds=tl(binds)) {
101 StgVar bind = hd(binds);
102 StgRhs rhs = stgVarBody(bind);
103 List fvs = filterFreeVars(stgVarInfo(bind));
104 /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */
106 switch (whatIs(rhs)) {
110 #error lift constants
112 StgVar v = mkStgVar(rhs,NONE);
113 stgVarBody(bind) = mkStgLet(singleton(v),v);
115 liftedBinds = cons(bind,liftedBinds);
118 /* deliberate fall through */
127 StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
129 liftedBinds = cons(v,liftedBinds);
130 stgVarBody(bind) = makeStgApp(v, fvs);
133 #error lift constants
135 StgVar r = mkStgVar(rhs,NIL); /* copy the var */
136 StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE);
137 stgVarBody(bind) = v; /* indirection to r */
139 liftedBinds = cons(v,liftedBinds);
140 bs = cons(bind,bs); /* keep the old binding */
143 /* deliberate fall through */
152 static void liftAlt( StgCaseAlt alt )
154 liftExpr(stgCaseAltBody(alt));
157 static void liftPrimAlt( StgPrimAlt alt )
159 liftExpr(stgPrimAltBody(alt));
162 static void liftExpr( StgExpr e )
166 stgLetBinds(e) = liftLetBinds(stgLetBinds(e));
167 liftExpr(stgLetBody(e));
170 liftExpr(stgLambdaBody(e));
173 liftExpr(stgCaseScrut(e));
174 mapProc(liftAlt,stgCaseAlts(e));
177 liftExpr(stgPrimCaseScrut(e));
178 mapProc(liftPrimAlt,stgPrimCaseAlts(e));
188 internal("liftExpr");
192 List liftBinds( List binds )
195 for(bs=binds; nonNull(bs); bs=tl(bs)) {
196 StgVar bind = hd(bs);
197 freeVarsBind(NIL,bind);
198 stgVarInfo(bind) = NONE; /* mark as top level */
201 binds = liftLetBinds(binds);
202 binds = revOnto(liftedBinds,binds);
207 /* --------------------------------------------------------------------------
209 * ------------------------------------------------------------------------*/
211 Void liftControl(what)
215 /* deliberate fall though */
225 /*-------------------------------------------------------------------------*/