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 module SAT ( doStaticArgs ) where
43 #include "HsVersions.h"
47 doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
49 {- LATER: to end of file:
56 doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
59 = initSAT (mapSAT sat_bind binds)
61 sat_bind (NonRec binder expr)
62 = emptyEnvSAT `thenSAT_`
63 satExpr expr `thenSAT` (\ expr' ->
64 returnSAT (NonRec binder expr') )
65 sat_bind (Rec [(binder,rhs)])
66 = emptyEnvSAT `thenSAT_`
67 insSAEnv binder (getArgLists rhs) `thenSAT_`
68 satExpr rhs `thenSAT` (\ rhs' ->
69 saTransform binder rhs')
71 = emptyEnvSAT `thenSAT_`
72 mapSAT satExpr rhss `thenSAT` \ rhss' ->
73 returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
75 (binders, rhss) = unzip pairs
80 = updSAEnv (Just (v,([],[]))) `thenSAT_`
83 satAtom _ = returnSAT ()
87 satExpr :: CoreExpr -> SatM CoreExpr
90 = updSAEnv (Just (v,([],[]))) `thenSAT_`
93 satExpr lit@(Lit _) = returnSAT lit
95 satExpr e@(Con con types args)
96 = mapSAT satAtom args `thenSAT_`
99 satExpr e@(Prim prim ty args)
100 = mapSAT satAtom args `thenSAT_`
103 satExpr (Lam binders body)
104 = satExpr body `thenSAT` \ body' ->
105 returnSAT (Lam binders body')
107 satExpr (CoTyLam tyvar body)
108 = satExpr body `thenSAT` (\ body' ->
109 returnSAT (CoTyLam tyvar body') )
111 satExpr app@(App _ _)
114 satExpr app@(CoTyApp _ _)
117 satExpr (Case expr alts)
118 = satExpr expr `thenSAT` \ expr' ->
119 sat_alts alts `thenSAT` \ alts' ->
120 returnSAT (Case expr' alts')
122 sat_alts (AlgAlts alts deflt)
123 = mapSAT satAlgAlt alts `thenSAT` \ alts' ->
124 sat_default deflt `thenSAT` \ deflt' ->
125 returnSAT (AlgAlts alts' deflt')
127 satAlgAlt (con, params, rhs)
128 = satExpr rhs `thenSAT` \ rhs' ->
129 returnSAT (con, params, rhs')
131 sat_alts (PrimAlts alts deflt)
132 = mapSAT satPrimAlt alts `thenSAT` \ alts' ->
133 sat_default deflt `thenSAT` \ deflt' ->
134 returnSAT (PrimAlts alts' deflt')
136 satPrimAlt (lit, rhs)
137 = satExpr rhs `thenSAT` \ rhs' ->
138 returnSAT (lit, rhs')
140 sat_default NoDefault
141 = returnSAT NoDefault
142 sat_default (BindDefault binder rhs)
143 = satExpr rhs `thenSAT` \ rhs' ->
144 returnSAT (BindDefault binder rhs')
146 satExpr (Let (NonRec binder rhs) body)
147 = satExpr body `thenSAT` \ body' ->
148 satExpr rhs `thenSAT` \ rhs' ->
149 returnSAT (Let (NonRec binder rhs') body')
151 satExpr (Let (Rec [(binder,rhs)]) body)
152 = satExpr body `thenSAT` \ body' ->
153 insSAEnv binder (getArgLists rhs) `thenSAT_`
154 satExpr rhs `thenSAT` \ rhs' ->
155 saTransform binder rhs' `thenSAT` \ binding ->
156 returnSAT (Let binding body')
158 satExpr (Let (Rec binds) body)
160 (binders, rhss) = unzip binds
162 satExpr body `thenSAT` \ body' ->
163 mapSAT satExpr rhss `thenSAT` \ rhss' ->
164 returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
166 satExpr (SCC cc expr)
167 = satExpr expr `thenSAT` \ expr2 ->
168 returnSAT (SCC cc expr2)
170 satExpr (Coerce c ty expr)
171 = satExpr expr `thenSAT` \ expr2 ->
172 returnSAT (Coerce c ty expr2)
176 getAppArgs :: CoreExpr -> SatM CoreExpr
179 = get app `thenSAT` \ (app',result) ->
180 updSAEnv result `thenSAT_`
184 -> SatM (CoreExpr, Maybe (Id, SATInfo))
187 = get e `thenSAT` \ (e',result) ->
192 Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
196 = get e `thenSAT` \ (e', result) ->
199 (VarArg v) -> Static v
205 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
210 = returnSAT (var, Just (v,([],[])))
213 = satExpr e `thenSAT` \ e2 ->
214 returnSAT (e2, Nothing)