2 /* --------------------------------------------------------------------------
5 * This is a very simple lambda lifter - it doesn't try to do Johnsson-style
6 * lambda lifting (yet).
8 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
9 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
10 * Technology, 1994-1999, All rights reserved. It is distributed as
11 * free software under the license in the file "License", which is
12 * included in the distribution.
14 * $RCSfile: lift.c,v $
16 * $Date: 1999/10/15 21:40:51 $
17 * ------------------------------------------------------------------------*/
26 /* --------------------------------------------------------------------------
27 * Local function prototypes:
28 * ------------------------------------------------------------------------*/
30 static List liftedBinds = NIL;
31 static Bool makeInlineable = FALSE;
32 static Int inlineCounter = 0;
34 static StgExpr abstractExpr ( List vars, StgExpr e );
35 static inline Bool isTopLevel( StgVar v );
36 static List filterFreeVars( List vs );
37 static List liftLetBinds ( List binds, Bool topLevel );
38 static void liftAlt ( StgCaseAlt alt );
39 static void liftPrimAlt ( StgPrimAlt alt );
40 static void liftExpr ( StgExpr e );
42 /* --------------------------------------------------------------------------
44 * ------------------------------------------------------------------------*/
46 /* abstract variables out of an expression */
47 static StgExpr abstractExpr( List vars, StgExpr e )
50 List sub = NIL; /* association list */
51 for(; nonNull(vars); vars=tl(vars)) {
52 StgVar var = hd(vars);
53 StgVar arg = mkStgVar(NIL,NIL);
54 stgVarRep(arg) = stgVarRep(var);
55 args = cons(arg,args);
56 sub = cons(pair(var,arg),sub);
58 return makeStgLambda(rev(args),substExpr(sub,e));
61 /* ToDo: should be conservative estimate but isn't */
62 /* Will a variable be floated out to top level - conservative estimate? */
63 static inline Bool isTopLevel( StgVar v )
65 if (isNull(stgVarBody(v))) {
66 return FALSE; /* only let bound vars can be floated */
67 } else if (stgVarInfo(v) == NONE) {
68 return TRUE; /* those at top level are already there */
72 StgRhs rhs = stgVarBody(v);
73 switch (whatIs(rhs)) {
76 return isNull(stgVarInfo(v));
86 static List filterFreeVars( List vs )
92 for(; nonNull(vs); vs=tl(vs)) {
102 static List liftLetBinds( List binds, Bool topLevel )
105 for(; nonNull(binds); binds=tl(binds)) {
106 StgVar bind = hd(binds);
107 StgRhs rhs = stgVarBody(bind);
108 List fvs = filterFreeVars(stgVarInfo(bind));
109 /* stgVarInfo(bind) = NIL; */ /* ToDo: discard fv list */
111 /* if starting on a new top-level inlineable bind, ensure that
112 the lifted-out binds get marked inlineable too
115 Name n = nameFromStgVar(bind);
116 makeInlineable = FALSE;
117 if (nonNull(n) && name(n).inlineMe==TRUE) makeInlineable = TRUE;
120 switch (whatIs(rhs)) {
124 #error lift constants
126 StgVar v = mkStgVar(rhs,NONE);
127 stgVarBody(bind) = mkStgLet(singleton(v),v);
128 /* ppStg(v); */ /* check inlinable */
129 liftedBinds = cons(bind,liftedBinds);
132 /* deliberate fall through */
141 StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
142 liftedBinds = cons(v,liftedBinds);
143 if (makeInlineable) {
146 sprintf(s,"lam%d",inlineCounter++);
147 n = newName(findText(s),NIL);
149 name(n).simplified = TRUE; /* optimiser is upstream of lifter */
150 if (makeInlineable) name(n).inlineMe = TRUE;
151 stgVarBody(bind) = makeStgApp(n, fvs);
153 stgVarBody(bind) = makeStgApp(v, fvs);
157 #error lift constants
159 StgVar r = mkStgVar(rhs,NIL); /* copy the var */
160 StgVar v = mkStgVar(mkStgLet(singleton(r),r),NONE);
161 stgVarBody(bind) = v; /* indirection to r */
163 liftedBinds = cons(v,liftedBinds);
164 bs = cons(bind,bs); /* keep the old binding */
167 /* deliberate fall through */
176 static void liftAlt( StgCaseAlt alt )
178 if (isDefaultAlt(alt))
179 liftExpr(stgDefaultBody(alt)); else
180 liftExpr(stgCaseAltBody(alt));
183 static void liftPrimAlt( StgPrimAlt alt )
185 liftExpr(stgPrimAltBody(alt));
188 static void liftExpr( StgExpr e )
192 stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
193 liftExpr(stgLetBody(e));
196 liftExpr(stgLambdaBody(e));
199 liftExpr(stgCaseScrut(e));
200 mapProc(liftAlt,stgCaseAlts(e));
203 liftExpr(stgPrimCaseScrut(e));
204 mapProc(liftPrimAlt,stgPrimCaseAlts(e));
214 internal("liftExpr");
218 /* Lift a list of top-level binds. */
219 List liftBinds( List binds )
223 for(bs=binds; nonNull(bs); bs=tl(bs)) {
224 StgVar bind = hd(bs);
225 freeVarsBind(NIL,bind);
226 stgVarInfo(bind) = NONE; /* mark as top level */
230 binds = liftLetBinds(binds,TRUE);
231 binds = revOnto(liftedBinds,binds);
233 for (bs=binds; nonNull(bs); bs=tl(bs)) {
234 Name n = nameFromStgVar(hd(bs));
236 name(n).stgSize = stgSize(stgVarBody(name(n).stgVar));
243 /* --------------------------------------------------------------------------
245 * ------------------------------------------------------------------------*/
247 Void liftControl(what)
251 /* deliberate fall though */
261 /*-------------------------------------------------------------------------*/