1 /* -*- mode: hugs-c; -*- */
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: 1998/12/02 13:22:23 $
12 * ------------------------------------------------------------------------*/
21 /* --------------------------------------------------------------------------
23 * ------------------------------------------------------------------------*/
25 static StgAtom optimiseAtom Args((StgAtom));
26 static StgVar optimiseVar Args((StgVar));
27 static StgCaseAlt optimiseAlt Args((StgCaseAlt));
28 static StgPrimAlt optimisePrimAlt Args((StgPrimAlt));
29 static StgExpr optimiseExpr Args((StgExpr));
31 /* --------------------------------------------------------------------------
33 * ------------------------------------------------------------------------*/
35 static StgAtom optimiseAtom(StgAtom a)
39 return optimiseVar(a);
40 /* Note that NAMEs have no free vars. */
46 static StgVar optimiseVar(StgVar v)
48 StgRhs rhs = stgVarBody(v);
49 /* short circuit: let x = y in ...x... --> let x = y ...y... */
50 if (whatIs(rhs) == STGVAR && rhs != v) {
53 /* find last variable in chain */
55 while (whatIs(rhs) == STGVAR
56 && rhs != v /* infinite loop */
59 rhs = stgVarBody(rhs);
62 /* Make all variables in chain point to v1
63 * This makes sure we always resolve cycles the same way
64 * as well as making things faster if we call optimiseVar again
67 StgRhs r = stgVarBody(v);
68 assert(whatIs(r) == STGVAR);
77 void optimiseBind( StgVar v )
79 StgRhs rhs = stgVarBody(v);
80 switch (whatIs(rhs)) {
82 mapOver(optimiseAtom,stgConArgs(rhs));
85 stgVarBody(v) = optimiseExpr(rhs);
90 static StgCaseAlt optimiseAlt( StgCaseAlt alt )
92 /* StgPat pat = stgCaseAltPat(alt); */
93 stgCaseAltBody(alt) = optimiseExpr(stgCaseAltBody(alt));
97 static StgPrimAlt optimisePrimAlt( StgPrimAlt alt )
99 /* List vs = stgPrimAltPats(alt); */
100 stgPrimAltBody(alt) = optimiseExpr(stgPrimAltBody(alt));
104 static StgExpr optimiseExpr( StgExpr e )
109 List binds = stgLetBinds(e);
111 /* First we filter out trivial bindings.
112 * this has to be done before optimising the individual
113 * bindings so that we don't get confused by the results
114 * of other optimisations.
118 for(; nonNull(bs); bs=tl(bs)) {
119 StgVar b = optimiseVar(hd(bs));
120 StgRhs rhs = stgVarBody(b);
121 if (whatIs(rhs) == STGVAR && b != rhs) {
122 /* This variable will be short-circuited
123 * by optimiseVar so we can drop the binding
127 binds = cons(hd(bs),binds);
130 binds = rev(binds); /* preserve original order */
132 stgLetBody(e) = optimiseExpr(stgLetBody(e));
134 return stgLetBody(e);
136 mapProc(optimiseBind,binds);
137 stgLetBinds(e) = binds;
142 stgLambdaBody(e) = optimiseExpr(stgLambdaBody(e));
146 StgExpr scrut = optimiseExpr(stgCaseScrut(e));
147 StgExpr alts = stgCaseAlts(e);
148 if (whatIs(scrut) == STGVAR
149 && whatIs(stgVarBody(scrut)) == STGCON
151 StgRhs rhs = stgVarBody(scrut);
152 StgDiscr d = stgConCon(rhs);
153 List args = stgConArgs(rhs);
154 for(; nonNull(alts); alts=tl(alts)) {
155 StgCaseAlt alt = hd(alts);
156 StgPat pat = stgCaseAltPat(alt);
157 if (isDefaultPat(pat)) { /* the easy case */
158 StgExpr body = stgCaseAltBody(alt);
159 stgVarBody(pat) = rhs;
160 return optimiseExpr(body);
161 } else if (stgPatDiscr(pat) == d) {
163 * rebind all the pattern args to the con args
164 * and rebind the pattern var to con
165 * and run optimiser (to eliminate the binding)
167 StgExpr body = stgCaseAltBody(alt);
168 List binds = stgPatVars(pat);
172 nonNull(vs) && nonNull(args);
173 vs = tl(vs), args=tl(args)
175 stgVarBody(hd(vs)) = hd(args);
178 binds = cons(pat,binds); /* turn patvar into a var! */
179 stgVarBody(pat) = rhs;
181 /* This letrec will always be optimised away */
182 body = makeStgLet(binds,body);
183 return optimiseExpr(body);
186 internal("optimiseExpr: no patterns matched");
188 stgCaseScrut(e) = scrut;
189 mapOver(optimiseAlt,alts);
193 mapOver(optimisePrimAlt,stgPrimCaseAlts(e));
194 stgPrimCaseScrut(e) = optimiseExpr(stgPrimCaseScrut(e));
197 mapOver(optimiseAtom,stgPrimArgs(e));
198 /* primop is not a var */
201 stgAppFun(e) = optimiseExpr(stgAppFun(e));
202 mapOver(optimiseAtom,stgAppArgs(e));
205 return optimiseVar(e);
207 break; /* Names are never free vars */
209 internal("optimiseExpr");
214 /*-------------------------------------------------------------------------*/