2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 %************************************************************************
6 \section[SAT]{Static Argument Transformation pass}
8 %************************************************************************
10 May be seen as removing invariants from loops:
11 Arguments of recursive functions that do not change in recursive
12 calls are removed from the recursion, which is done locally
13 and only passes the arguments which effectively change.
16 map = /\ ab -> \f -> \xs -> case xs of
18 (a:b) -> f a : map f b
20 as map is recursively called with the same argument f (unmodified)
23 map = /\ ab -> \f -> \xs -> let map' ys = case ys of
28 Notice that for a compiler that uses lambda lifting this is
29 useless as map' will be transformed back to what map was.
31 We could possibly do the same for big lambdas, but we don't as
32 they will eventually be removed in later stages of the compiler,
33 therefore there is no penalty in keeping them.
35 Experimental Evidence: Heap: +/- 7%
36 Instrs: Always improves for 2 or more Static Args.
39 #include "HsVersions.h"
44 -- and to make the interface self-sufficient...
47 import Maybes ( Maybe(..) )
53 doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
56 = initSAT (mapSAT sat_bind binds)
58 sat_bind (NonRec binder expr)
59 = emptyEnvSAT `thenSAT_`
60 satExpr expr `thenSAT` (\ expr' ->
61 returnSAT (NonRec binder expr') )
62 sat_bind (Rec [(binder,rhs)])
63 = emptyEnvSAT `thenSAT_`
64 insSAEnv binder (getArgLists rhs) `thenSAT_`
65 satExpr rhs `thenSAT` (\ rhs' ->
66 saTransform binder rhs')
68 = emptyEnvSAT `thenSAT_`
69 mapSAT satExpr rhss `thenSAT` \ rhss' ->
70 returnSAT (Rec (binders `zip` rhss'))
72 (binders, rhss) = unzip pairs
77 = updSAEnv (Just (v,([],[]))) `thenSAT_`
80 satAtom _ = returnSAT ()
84 satExpr :: CoreExpr -> SatM CoreExpr
87 = updSAEnv (Just (v,([],[]))) `thenSAT_`
90 satExpr lit@(Lit _) = returnSAT lit
92 satExpr e@(Con con types args)
93 = mapSAT satAtom args `thenSAT_`
96 satExpr e@(Prim prim ty args)
97 = mapSAT satAtom args `thenSAT_`
100 satExpr (Lam binders body)
101 = satExpr body `thenSAT` \ body' ->
102 returnSAT (Lam binders body')
104 satExpr (CoTyLam tyvar body)
105 = satExpr body `thenSAT` (\ body' ->
106 returnSAT (CoTyLam tyvar body') )
108 satExpr app@(App _ _)
111 satExpr app@(CoTyApp _ _)
114 satExpr (Case expr alts)
115 = satExpr expr `thenSAT` \ expr' ->
116 sat_alts alts `thenSAT` \ alts' ->
117 returnSAT (Case expr' alts')
119 sat_alts (AlgAlts alts deflt)
120 = mapSAT satAlgAlt alts `thenSAT` \ alts' ->
121 sat_default deflt `thenSAT` \ deflt' ->
122 returnSAT (AlgAlts alts' deflt')
124 satAlgAlt (con, params, rhs)
125 = satExpr rhs `thenSAT` \ rhs' ->
126 returnSAT (con, params, rhs')
128 sat_alts (PrimAlts alts deflt)
129 = mapSAT satPrimAlt alts `thenSAT` \ alts' ->
130 sat_default deflt `thenSAT` \ deflt' ->
131 returnSAT (PrimAlts alts' deflt')
133 satPrimAlt (lit, rhs)
134 = satExpr rhs `thenSAT` \ rhs' ->
135 returnSAT (lit, rhs')
137 sat_default NoDefault
138 = returnSAT NoDefault
139 sat_default (BindDefault binder rhs)
140 = satExpr rhs `thenSAT` \ rhs' ->
141 returnSAT (BindDefault binder rhs')
143 satExpr (Let (NonRec binder rhs) body)
144 = satExpr body `thenSAT` \ body' ->
145 satExpr rhs `thenSAT` \ rhs' ->
146 returnSAT (Let (NonRec binder rhs') body')
148 satExpr (Let (Rec [(binder,rhs)]) body)
149 = satExpr body `thenSAT` \ body' ->
150 insSAEnv binder (getArgLists rhs) `thenSAT_`
151 satExpr rhs `thenSAT` \ rhs' ->
152 saTransform binder rhs' `thenSAT` \ binding ->
153 returnSAT (Let binding body')
155 satExpr (Let (Rec binds) body)
157 (binders, rhss) = unzip binds
159 satExpr body `thenSAT` \ body' ->
160 mapSAT satExpr rhss `thenSAT` \ rhss' ->
161 returnSAT (Let (Rec (binders `zip` rhss')) body')
163 satExpr (SCC cc expr)
164 = satExpr expr `thenSAT` \ expr2 ->
165 returnSAT (SCC cc expr2)
169 getAppArgs :: CoreExpr -> SatM CoreExpr
172 = get app `thenSAT` \ (app',result) ->
173 updSAEnv result `thenSAT_`
177 -> SatM (CoreExpr, Maybe (Id, SATInfo))
180 = get e `thenSAT` \ (e',result) ->
185 Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
189 = get e `thenSAT` \ (e', result) ->
192 (VarArg v) -> Static v
198 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
203 = returnSAT (var, Just (v,([],[])))
206 = satExpr e `thenSAT` \ e2 ->
207 returnSAT (e2, Nothing)