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/04/27 10:06:54 $
15 * ------------------------------------------------------------------------*/
24 /* --------------------------------------------------------------------------
25 * Local function prototypes:
26 * ------------------------------------------------------------------------*/
28 static List liftedBinds = NIL;
29 static Bool makeInlineable = FALSE;
30 static Int inlineCounter = 0;
32 static StgExpr abstractExpr ( List vars, StgExpr e );
33 static inline Bool isTopLevel( StgVar v );
34 static List filterFreeVars( List vs );
35 static List liftLetBinds ( List binds, Bool topLevel );
36 static void liftAlt ( StgCaseAlt alt );
37 static void liftPrimAlt ( StgPrimAlt alt );
38 static void liftExpr ( StgExpr e );
40 /* --------------------------------------------------------------------------
42 * ------------------------------------------------------------------------*/
44 /* abstract variables out of an expression */
45 static StgExpr abstractExpr( List vars, StgExpr e )
48 List sub = NIL; /* association list */
49 for(; nonNull(vars); vars=tl(vars)) {
50 StgVar var = hd(vars);
51 StgVar arg = mkStgVar(NIL,NIL);
52 stgVarRep(arg) = stgVarRep(var);
53 args = cons(arg,args);
54 sub = cons(pair(var,arg),sub);
56 return makeStgLambda(rev(args),substExpr(sub,e));
59 /* ToDo: should be conservative estimate but isn't */
60 /* Will a variable be floated out to top level - conservative estimate? */
61 static inline Bool isTopLevel( StgVar v )
63 if (isNull(stgVarBody(v))) {
64 return FALSE; /* only let bound vars can be floated */
65 } else if (stgVarInfo(v) == NONE) {
66 return TRUE; /* those at top level are already there */
70 StgRhs rhs = stgVarBody(v);
71 switch (whatIs(rhs)) {
74 return isNull(stgVarInfo(v));
84 static List filterFreeVars( List vs )
90 for(; nonNull(vs); vs=tl(vs)) {
100 static List liftLetBinds( List binds, Bool topLevel )
103 for(; nonNull(binds); binds=tl(binds)) {
104 StgVar bind = hd(binds);
105 StgRhs rhs = stgVarBody(bind);
106 List fvs = filterFreeVars(stgVarInfo(bind));
107 /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */
109 /* if starting on a new top-level inlineable bind, ensure that
110 the lifted-out binds get marked inlineable too
113 Name n = nameFromStgVar(bind);
114 makeInlineable = FALSE;
115 if (nonNull(n) && name(n).inlineMe==TRUE) makeInlineable = TRUE;
118 switch (whatIs(rhs)) {
122 #error lift constants
124 StgVar v = mkStgVar(rhs,NONE);
125 stgVarBody(bind) = mkStgLet(singleton(v),v);
126 /* ppStg(v); */ /* check inlinable */
127 liftedBinds = cons(bind,liftedBinds);
130 /* deliberate fall through */
139 StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
140 liftedBinds = cons(v,liftedBinds);
141 if (makeInlineable) {
144 sprintf(s,"lam%d",inlineCounter++);
145 n = newName(findText(s),NIL);
147 name(n).simplified = TRUE; /* optimiser is upstream of lifter */
148 if (makeInlineable) name(n).inlineMe = TRUE;
149 stgVarBody(bind) = makeStgApp(n, fvs);
151 stgVarBody(bind) = makeStgApp(v, fvs);
155 #error lift constants
157 StgVar r = mkStgVar(rhs,NIL); /* copy the var */
158 StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE);
159 stgVarBody(bind) = v; /* indirection to r */
161 liftedBinds = cons(v,liftedBinds);
162 bs = cons(bind,bs); /* keep the old binding */
165 /* deliberate fall through */
174 static void liftAlt( StgCaseAlt alt )
176 if (isDefaultAlt(alt))
177 liftExpr(stgDefaultBody(alt)); else
178 liftExpr(stgCaseAltBody(alt));
181 static void liftPrimAlt( StgPrimAlt alt )
183 liftExpr(stgPrimAltBody(alt));
186 static void liftExpr( StgExpr e )
190 stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
191 liftExpr(stgLetBody(e));
194 liftExpr(stgLambdaBody(e));
197 liftExpr(stgCaseScrut(e));
198 mapProc(liftAlt,stgCaseAlts(e));
201 liftExpr(stgPrimCaseScrut(e));
202 mapProc(liftPrimAlt,stgPrimCaseAlts(e));
212 internal("liftExpr");
216 /* Lift a list of top-level binds. */
217 List liftBinds( List binds )
221 for(bs=binds; nonNull(bs); bs=tl(bs)) {
222 StgVar bind = hd(bs);
223 freeVarsBind(NIL,bind);
224 stgVarInfo(bind) = NONE; /* mark as top level */
228 binds = liftLetBinds(binds,TRUE);
229 binds = revOnto(liftedBinds,binds);
231 for (bs=binds; nonNull(bs); bs=tl(bs)) {
232 Name n = nameFromStgVar(hd(bs));
234 name(n).stgSize = stgSize(stgVarBody(name(n).stgVar));
241 /* --------------------------------------------------------------------------
243 * ------------------------------------------------------------------------*/
245 Void liftControl(what)
249 /* deliberate fall though */
259 /*-------------------------------------------------------------------------*/