2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
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.
42 -- The above warning supression flag is a temporary kludge.
43 -- While working on this module you are encouraged to remove it and fix
44 -- any warnings in the module. See
45 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
48 module SAT ( doStaticArgs ) where
50 #include "HsVersions.h"
52 import Panic ( panic )
54 doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
56 {- LATER: to end of file:
63 doStaticArgs :: [CoreBind] -> UniqSupply -> [CoreBind]
67 showPass "Static argument";
68 let { binds' = initSAT (mapSAT sat_bind binds) };
69 endPass "Static argument"
70 False -- No specific flag for dumping SAT
74 sat_bind (NonRec binder expr)
75 = emptyEnvSAT `thenSAT_`
76 satExpr expr `thenSAT` (\ expr' ->
77 returnSAT (NonRec binder expr') )
78 sat_bind (Rec [(binder,rhs)])
79 = emptyEnvSAT `thenSAT_`
80 insSAEnv binder (getArgLists rhs) `thenSAT_`
81 satExpr rhs `thenSAT` (\ rhs' ->
82 saTransform binder rhs')
84 = emptyEnvSAT `thenSAT_`
85 mapSAT satExpr rhss `thenSAT` \ rhss' ->
86 returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
88 (binders, rhss) = unzip pairs
93 = updSAEnv (Just (v,([],[]))) `thenSAT_`
96 satAtom _ = returnSAT ()
100 satExpr :: CoreExpr -> SatM CoreExpr
103 = updSAEnv (Just (v,([],[]))) `thenSAT_`
106 satExpr lit@(Lit _) = returnSAT lit
108 satExpr e@(Prim prim ty args)
109 = mapSAT satAtom args `thenSAT_`
112 satExpr (Lam binders body)
113 = satExpr body `thenSAT` \ body' ->
114 returnSAT (Lam binders body')
116 satExpr (CoTyLam tyvar body)
117 = satExpr body `thenSAT` (\ body' ->
118 returnSAT (CoTyLam tyvar body') )
120 satExpr app@(App _ _)
123 satExpr app@(CoTyApp _ _)
126 satExpr (Case expr alts)
127 = satExpr expr `thenSAT` \ expr' ->
128 sat_alts alts `thenSAT` \ alts' ->
129 returnSAT (Case expr' alts')
131 sat_alts (AlgAlts alts deflt)
132 = mapSAT satAlgAlt alts `thenSAT` \ alts' ->
133 sat_default deflt `thenSAT` \ deflt' ->
134 returnSAT (AlgAlts alts' deflt')
136 satAlgAlt (con, params, rhs)
137 = satExpr rhs `thenSAT` \ rhs' ->
138 returnSAT (con, params, rhs')
140 sat_alts (PrimAlts alts deflt)
141 = mapSAT satPrimAlt alts `thenSAT` \ alts' ->
142 sat_default deflt `thenSAT` \ deflt' ->
143 returnSAT (PrimAlts alts' deflt')
145 satPrimAlt (lit, rhs)
146 = satExpr rhs `thenSAT` \ rhs' ->
147 returnSAT (lit, rhs')
149 sat_default NoDefault
150 = returnSAT NoDefault
151 sat_default (BindDefault binder rhs)
152 = satExpr rhs `thenSAT` \ rhs' ->
153 returnSAT (BindDefault binder rhs')
155 satExpr (Let (NonRec binder rhs) body)
156 = satExpr body `thenSAT` \ body' ->
157 satExpr rhs `thenSAT` \ rhs' ->
158 returnSAT (Let (NonRec binder rhs') body')
160 satExpr (Let (Rec [(binder,rhs)]) body)
161 = satExpr body `thenSAT` \ body' ->
162 insSAEnv binder (getArgLists rhs) `thenSAT_`
163 satExpr rhs `thenSAT` \ rhs' ->
164 saTransform binder rhs' `thenSAT` \ binding ->
165 returnSAT (Let binding body')
167 satExpr (Let (Rec binds) body)
169 (binders, rhss) = unzip binds
171 satExpr body `thenSAT` \ body' ->
172 mapSAT satExpr rhss `thenSAT` \ rhss' ->
173 returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
175 satExpr (Note note expr)
176 = satExpr expr `thenSAT` \ expr2 ->
177 returnSAT (Note note expr2)
181 getAppArgs :: CoreExpr -> SatM CoreExpr
184 = get app `thenSAT` \ (app',result) ->
185 updSAEnv result `thenSAT_`
189 -> SatM (CoreExpr, Maybe (Id, SATInfo))
192 = get e `thenSAT` \ (e',result) ->
197 Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
201 = get e `thenSAT` \ (e', result) ->
204 (VarArg v) -> Static v
210 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
215 = returnSAT (var, Just (v,([],[])))
218 = satExpr e `thenSAT` \ e2 ->
219 returnSAT (e2, Nothing)