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: 2000/03/22 18:14:22 $
17 * ------------------------------------------------------------------------*/
25 /* --------------------------------------------------------------------------
26 * Local function prototypes:
27 * ------------------------------------------------------------------------*/
29 static List liftedBinds = NIL;
30 static Bool makeInlineable = FALSE;
31 static Int inlineCounter = 0;
33 static StgExpr abstractExpr ( List vars, StgExpr e );
34 static inline Bool isTopLevel( StgVar v );
35 static List filterFreeVars( List vs );
36 static List liftLetBinds ( List binds, Bool topLevel );
37 static void liftAlt ( StgCaseAlt alt );
38 static void liftPrimAlt ( StgPrimAlt alt );
39 static void liftExpr ( StgExpr e );
41 /* --------------------------------------------------------------------------
43 * ------------------------------------------------------------------------*/
45 /* abstract variables out of an expression */
46 static StgExpr abstractExpr( List vars, StgExpr e )
49 List sub = NIL; /* association list */
50 for(; nonNull(vars); vars=tl(vars)) {
51 StgVar var = hd(vars);
52 StgVar arg = mkStgVar(NIL,NIL);
53 stgVarRep(arg) = stgVarRep(var);
54 args = cons(arg,args);
55 sub = cons(pair(var,arg),sub);
57 return makeStgLambda(rev(args),substExpr(sub,e));
60 /* ToDo: should be conservative estimate but isn't */
61 /* Will a variable be floated out to top level - conservative estimate? */
62 static inline Bool isTopLevel( StgVar v )
64 if (isNull(stgVarBody(v))) {
65 return FALSE; /* only let bound vars can be floated */
66 } else if (stgVarInfo(v) == NONE) {
67 return TRUE; /* those at top level are already there */
73 static List filterFreeVars( List vs )
79 for(; nonNull(vs); vs=tl(vs)) {
89 static List liftLetBinds( List binds, Bool topLevel )
92 for(; nonNull(binds); binds=tl(binds)) {
93 StgVar bind = hd(binds);
94 StgRhs rhs = stgVarBody(bind);
95 List fvs = filterFreeVars(stgVarInfo(bind));
97 switch (whatIs(rhs)) {
107 StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
108 liftedBinds = cons(v,liftedBinds);
109 if (makeInlineable) {
112 sprintf(s,"lam%d",inlineCounter++);
113 n = newName(findText(s),NIL);
115 stgVarBody(bind) = makeStgApp(n, fvs);
117 stgVarBody(bind) = makeStgApp(v, fvs);
127 static void liftAlt( StgCaseAlt alt )
129 if (isDefaultAlt(alt))
130 liftExpr(stgDefaultBody(alt)); else
131 liftExpr(stgCaseAltBody(alt));
134 static void liftPrimAlt( StgPrimAlt alt )
136 liftExpr(stgPrimAltBody(alt));
139 static void liftExpr( StgExpr e )
143 stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
144 liftExpr(stgLetBody(e));
147 liftExpr(stgLambdaBody(e));
150 liftExpr(stgCaseScrut(e));
151 mapProc(liftAlt,stgCaseAlts(e));
154 liftExpr(stgPrimCaseScrut(e));
155 mapProc(liftPrimAlt,stgPrimCaseAlts(e));
165 internal("liftExpr");
169 /* Lift a list of top-level binds. */
170 List liftBinds( List binds )
174 for(bs=binds; nonNull(bs); bs=tl(bs)) {
175 StgVar bind = hd(bs);
178 if (currentModule != modulePrelude) {
179 fprintf(stderr, "\n");
181 fprintf(stderr, "\n");
184 freeVarsBind(NIL,bind);
185 stgVarInfo(bind) = NONE; /* mark as top level */
189 binds = liftLetBinds(binds,TRUE);
190 binds = revOnto(liftedBinds,binds);
195 /* --------------------------------------------------------------------------
197 * ------------------------------------------------------------------------*/
199 Void liftControl(what)
202 case POSTPREL: break;
214 /*-------------------------------------------------------------------------*/