2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 %************************************************************************
6 \section[SAT]{Static Argument Transformation pass}
8 %************************************************************************
10 96/03: We aren't using the static-argument transformation right now.
12 May be seen as removing invariants from loops:
13 Arguments of recursive functions that do not change in recursive
14 calls are removed from the recursion, which is done locally
15 and only passes the arguments which effectively change.
18 map = /\ ab -> \f -> \xs -> case xs of
20 (a:b) -> f a : map f b
22 as map is recursively called with the same argument f (unmodified)
25 map = /\ ab -> \f -> \xs -> let map' ys = case ys of
30 Notice that for a compiler that uses lambda lifting this is
31 useless as map' will be transformed back to what map was.
33 We could possibly do the same for big lambdas, but we don't as
34 they will eventually be removed in later stages of the compiler,
35 therefore there is no penalty in keeping them.
37 Experimental Evidence: Heap: +/- 7%
38 Instrs: Always improves for 2 or more Static Args.
41 #include "HsVersions.h"
43 module SAT ( doStaticArgs ) where
48 doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
50 {- LATER: to end of file:
57 doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
60 = initSAT (mapSAT sat_bind binds)
62 sat_bind (NonRec binder expr)
63 = emptyEnvSAT `thenSAT_`
64 satExpr expr `thenSAT` (\ expr' ->
65 returnSAT (NonRec binder expr') )
66 sat_bind (Rec [(binder,rhs)])
67 = emptyEnvSAT `thenSAT_`
68 insSAEnv binder (getArgLists rhs) `thenSAT_`
69 satExpr rhs `thenSAT` (\ rhs' ->
70 saTransform binder rhs')
72 = emptyEnvSAT `thenSAT_`
73 mapSAT satExpr rhss `thenSAT` \ rhss' ->
74 returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
76 (binders, rhss) = unzip pairs
81 = updSAEnv (Just (v,([],[]))) `thenSAT_`
84 satAtom _ = returnSAT ()
88 satExpr :: CoreExpr -> SatM CoreExpr
91 = updSAEnv (Just (v,([],[]))) `thenSAT_`
94 satExpr lit@(Lit _) = returnSAT lit
96 satExpr e@(Con con types args)
97 = mapSAT satAtom args `thenSAT_`
100 satExpr e@(Prim prim ty args)
101 = mapSAT satAtom args `thenSAT_`
104 satExpr (Lam binders body)
105 = satExpr body `thenSAT` \ body' ->
106 returnSAT (Lam binders body')
108 satExpr (CoTyLam tyvar body)
109 = satExpr body `thenSAT` (\ body' ->
110 returnSAT (CoTyLam tyvar body') )
112 satExpr app@(App _ _)
115 satExpr app@(CoTyApp _ _)
118 satExpr (Case expr alts)
119 = satExpr expr `thenSAT` \ expr' ->
120 sat_alts alts `thenSAT` \ alts' ->
121 returnSAT (Case expr' alts')
123 sat_alts (AlgAlts alts deflt)
124 = mapSAT satAlgAlt alts `thenSAT` \ alts' ->
125 sat_default deflt `thenSAT` \ deflt' ->
126 returnSAT (AlgAlts alts' deflt')
128 satAlgAlt (con, params, rhs)
129 = satExpr rhs `thenSAT` \ rhs' ->
130 returnSAT (con, params, rhs')
132 sat_alts (PrimAlts alts deflt)
133 = mapSAT satPrimAlt alts `thenSAT` \ alts' ->
134 sat_default deflt `thenSAT` \ deflt' ->
135 returnSAT (PrimAlts alts' deflt')
137 satPrimAlt (lit, rhs)
138 = satExpr rhs `thenSAT` \ rhs' ->
139 returnSAT (lit, rhs')
141 sat_default NoDefault
142 = returnSAT NoDefault
143 sat_default (BindDefault binder rhs)
144 = satExpr rhs `thenSAT` \ rhs' ->
145 returnSAT (BindDefault binder rhs')
147 satExpr (Let (NonRec binder rhs) body)
148 = satExpr body `thenSAT` \ body' ->
149 satExpr rhs `thenSAT` \ rhs' ->
150 returnSAT (Let (NonRec binder rhs') body')
152 satExpr (Let (Rec [(binder,rhs)]) body)
153 = satExpr body `thenSAT` \ body' ->
154 insSAEnv binder (getArgLists rhs) `thenSAT_`
155 satExpr rhs `thenSAT` \ rhs' ->
156 saTransform binder rhs' `thenSAT` \ binding ->
157 returnSAT (Let binding body')
159 satExpr (Let (Rec binds) body)
161 (binders, rhss) = unzip binds
163 satExpr body `thenSAT` \ body' ->
164 mapSAT satExpr rhss `thenSAT` \ rhss' ->
165 returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
167 satExpr (SCC cc expr)
168 = satExpr expr `thenSAT` \ expr2 ->
169 returnSAT (SCC cc expr2)
171 satExpr (Coerce c ty expr)
172 = satExpr expr `thenSAT` \ expr2 ->
173 returnSAT (Coerce c ty expr2)
177 getAppArgs :: CoreExpr -> SatM CoreExpr
180 = get app `thenSAT` \ (app',result) ->
181 updSAEnv result `thenSAT_`
185 -> SatM (CoreExpr, Maybe (Id, SATInfo))
188 = get e `thenSAT` \ (e',result) ->
193 Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
197 = get e `thenSAT` \ (e', result) ->
200 (VarArg v) -> Static v
206 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
211 = returnSAT (var, Just (v,([],[])))
214 = satExpr e `thenSAT` \ e2 ->
215 returnSAT (e2, Nothing)