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/04/27 16:35:29 $
17 * ------------------------------------------------------------------------*/
19 #include "hugsbasictypes.h"
25 /* --------------------------------------------------------------------------
26 * Local function prototypes:
27 * ------------------------------------------------------------------------*/
29 static List liftedBinds = NIL;
31 static StgExpr abstractExpr ( List vars, StgExpr e );
32 static Bool isTopLevel ( StgVar v );
33 static List filterFreeVars ( List vs );
34 static List liftLetBinds ( List binds, Bool topLevel );
35 static void liftAlt ( StgCaseAlt alt );
36 static void liftPrimAlt ( StgPrimAlt alt );
37 static void liftExpr ( StgExpr e );
39 /* --------------------------------------------------------------------------
41 * ------------------------------------------------------------------------*/
43 /* abstract variables out of an expression */
44 static StgExpr abstractExpr( List vars, StgExpr e )
47 List sub = NIL; /* association list */
48 for(; nonNull(vars); vars=tl(vars)) {
49 StgVar var = hd(vars);
50 StgVar arg = mkStgVar(NIL,NIL);
51 stgVarRep(arg) = stgVarRep(var);
52 args = cons(arg,args);
53 sub = cons(pair(var,arg),sub);
55 return makeStgLambda(rev(args),substExpr(sub,e));
58 /* ToDo: should be conservative estimate but isn't */
59 /* Will a variable be floated out to top level - conservative estimate? */
60 static Bool isTopLevel( StgVar v )
62 if (isNull(stgVarBody(v))) {
63 return FALSE; /* only let bound vars can be floated */
64 } else if (stgVarInfo(v) == NONE) {
65 return TRUE; /* those at top level are already there */
71 static List filterFreeVars( List vs )
77 for(; nonNull(vs); vs=tl(vs)) {
87 static Int nameCounter;
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);
111 sprintf(s,"(lift%d)",nameCounter++);
112 n = newName(findText(s),NIL);
114 stgVarBody(bind) = makeStgApp(n, fvs);
115 liftedBinds = cons(n,liftedBinds);
125 static void liftAlt( StgCaseAlt alt )
127 if (isDefaultAlt(alt))
128 liftExpr(stgDefaultBody(alt)); else
129 liftExpr(stgCaseAltBody(alt));
132 static void liftPrimAlt( StgPrimAlt alt )
134 liftExpr(stgPrimAltBody(alt));
137 static void liftExpr( StgExpr e )
141 stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
142 liftExpr(stgLetBody(e));
145 liftExpr(stgLambdaBody(e));
148 liftExpr(stgCaseScrut(e));
149 mapProc(liftAlt,stgCaseAlts(e));
152 liftExpr(stgPrimCaseScrut(e));
153 mapProc(liftPrimAlt,stgPrimCaseAlts(e));
164 internal("liftExpr");
168 /* Lift the list of top-level binds for a module. */
169 void liftModule ( Module mod )
175 for (cl = module(mod).codeList; nonNull(cl); cl = tl(cl)) {
176 StgVar bind = getNameOrTupleClosure(hd(cl));
177 if (isCPtr(bind)) continue;
178 assert(nonNull(bind));
180 if (currentModule != modulePrelude) {
181 fprintf(stderr, "\n");
183 fprintf(stderr, "\n");
186 freeVarsBind(NIL,bind);
187 stgVarInfo(bind) = NONE; /* mark as top level */
188 binds = cons(bind,binds);
192 binds = liftLetBinds(binds,TRUE);
193 module(mod).codeList = revOnto(liftedBinds, module(mod).codeList);
197 /* --------------------------------------------------------------------------
199 * ------------------------------------------------------------------------*/
201 Void liftControl(what)
204 case POSTPREL: break;
216 /*-------------------------------------------------------------------------*/