2 /* --------------------------------------------------------------------------
5 * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
6 * All rights reserved. See NOTICE for details and conditions of use etc...
7 * Hugs version 1.4, December 1997
9 * $RCSfile: optimise.c,v $
11 * $Date: 1999/02/03 17:08:33 $
12 * ------------------------------------------------------------------------*/
20 /* --------------------------------------------------------------------------
22 * ------------------------------------------------------------------------*/
24 static StgAtom optimiseAtom Args((StgAtom));
25 static StgVar optimiseVar Args((StgVar));
26 static StgCaseAlt optimiseAlt Args((StgCaseAlt));
27 static StgPrimAlt optimisePrimAlt Args((StgPrimAlt));
28 static StgExpr optimiseExpr Args((StgExpr));
30 /* --------------------------------------------------------------------------
32 * ------------------------------------------------------------------------*/
34 static StgAtom optimiseAtom(StgAtom a)
38 return optimiseVar(a);
39 /* Note that NAMEs have no free vars. */
45 static StgVar optimiseVar(StgVar v)
47 StgRhs rhs = stgVarBody(v);
48 /* short circuit: let x = y in ...x... --> let x = y ...y... */
49 if (whatIs(rhs) == STGVAR && rhs != v) {
52 /* find last variable in chain */
54 while (whatIs(rhs) == STGVAR
55 && rhs != v /* infinite loop */
58 rhs = stgVarBody(rhs);
61 /* Make all variables in chain point to v1
62 * This makes sure we always resolve cycles the same way
63 * as well as making things faster if we call optimiseVar again
66 StgRhs r = stgVarBody(v);
67 assert(whatIs(r) == STGVAR);
76 void optimiseBind( StgVar v )
78 StgRhs rhs = stgVarBody(v);
79 switch (whatIs(rhs)) {
81 mapOver(optimiseAtom,stgConArgs(rhs));
84 stgVarBody(v) = optimiseExpr(rhs);
89 static StgCaseAlt optimiseAlt( StgCaseAlt alt )
91 /* StgPat pat = stgCaseAltPat(alt); */
92 stgCaseAltBody(alt) = optimiseExpr(stgCaseAltBody(alt));
96 static StgPrimAlt optimisePrimAlt( StgPrimAlt alt )
98 /* List vs = stgPrimAltPats(alt); */
99 stgPrimAltBody(alt) = optimiseExpr(stgPrimAltBody(alt));
103 static StgExpr optimiseExpr( StgExpr e )
108 List binds = stgLetBinds(e);
110 /* First we filter out trivial bindings.
111 * this has to be done before optimising the individual
112 * bindings so that we don't get confused by the results
113 * of other optimisations.
117 for(; nonNull(bs); bs=tl(bs)) {
118 StgVar b = optimiseVar(hd(bs));
119 StgRhs rhs = stgVarBody(b);
120 if (whatIs(rhs) == STGVAR && b != rhs) {
121 /* This variable will be short-circuited
122 * by optimiseVar so we can drop the binding
126 binds = cons(hd(bs),binds);
129 binds = rev(binds); /* preserve original order */
131 stgLetBody(e) = optimiseExpr(stgLetBody(e));
133 return stgLetBody(e);
135 mapProc(optimiseBind,binds);
136 stgLetBinds(e) = binds;
141 stgLambdaBody(e) = optimiseExpr(stgLambdaBody(e));
145 StgExpr scrut = optimiseExpr(stgCaseScrut(e));
146 StgExpr alts = stgCaseAlts(e);
147 if (whatIs(scrut) == STGVAR
148 && whatIs(stgVarBody(scrut)) == STGCON
150 StgRhs rhs = stgVarBody(scrut);
151 StgDiscr d = stgConCon(rhs);
152 List args = stgConArgs(rhs);
153 for(; nonNull(alts); alts=tl(alts)) {
154 StgCaseAlt alt = hd(alts);
155 StgPat pat = stgCaseAltPat(alt);
156 if (isDefaultPat(pat)) { /* the easy case */
157 StgExpr body = stgCaseAltBody(alt);
158 stgVarBody(pat) = rhs;
159 return optimiseExpr(body);
160 } else if (stgPatDiscr(pat) == d) {
162 * rebind all the pattern args to the con args
163 * and rebind the pattern var to con
164 * and run optimiser (to eliminate the binding)
166 StgExpr body = stgCaseAltBody(alt);
167 List binds = stgPatVars(pat);
171 nonNull(vs) && nonNull(args);
172 vs = tl(vs), args=tl(args)
174 stgVarBody(hd(vs)) = hd(args);
177 binds = cons(pat,binds); /* turn patvar into a var! */
178 stgVarBody(pat) = rhs;
180 /* This letrec will always be optimised away */
181 body = makeStgLet(binds,body);
182 return optimiseExpr(body);
185 internal("optimiseExpr: no patterns matched");
187 stgCaseScrut(e) = scrut;
188 mapOver(optimiseAlt,alts);
192 mapOver(optimisePrimAlt,stgPrimCaseAlts(e));
193 stgPrimCaseScrut(e) = optimiseExpr(stgPrimCaseScrut(e));
196 mapOver(optimiseAtom,stgPrimArgs(e));
197 /* primop is not a var */
200 stgAppFun(e) = optimiseExpr(stgAppFun(e));
201 mapOver(optimiseAtom,stgAppArgs(e));
204 return optimiseVar(e);
206 break; /* Names are never free vars */
208 internal("optimiseExpr");
213 /*-------------------------------------------------------------------------*/