[project @ 1998-01-08 18:03:08 by simonm]
[ghc-hetmet.git] / ghc / compiler / simplCore / SAT.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 %************************************************************************
5 %*                                                                      *
6 \section[SAT]{Static Argument Transformation pass}
7 %*                                                                      *
8 %************************************************************************
9
10 96/03: We aren't using the static-argument transformation right now.
11
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.
16
17 Example:
18 map = /\ ab -> \f -> \xs -> case xs of
19                              []    -> []
20                              (a:b) -> f a : map f b
21
22 as map is recursively called with the same argument f (unmodified)
23 we transform it to
24
25 map = /\ ab -> \f -> \xs -> let map' ys = case ys of
26                                            []    -> []
27                                            (a:b) -> f a : map' b
28                             in map' xs
29
30 Notice that for a compiler that uses lambda lifting this is
31 useless as map' will be transformed back to what map was.
32
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.
36
37 Experimental Evidence: Heap: +/- 7%
38                        Instrs: Always improves for 2 or more Static Args.
39
40 \begin{code}
41 module SAT ( doStaticArgs ) where
42
43 #include "HsVersions.h"
44
45 import Util             ( panic )
46
47 doStaticArgs = panic "SAT.doStaticArgs (ToDo)"
48
49 {- LATER: to end of file:
50
51 import SATMonad
52 import Util
53 \end{code}
54
55 \begin{code}
56 doStaticArgs :: [CoreBinding] -> UniqSupply -> [CoreBinding]
57
58 doStaticArgs binds
59   = initSAT (mapSAT sat_bind binds)
60   where
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')
70     sat_bind (Rec pairs)
71       = emptyEnvSAT             `thenSAT_`
72         mapSAT satExpr rhss     `thenSAT` \ rhss' ->
73         returnSAT (Rec (zipEqual "doStaticArgs" binders rhss'))
74       where
75         (binders, rhss) = unzip pairs
76 \end{code}
77
78 \begin{code}
79 satAtom (VarArg v)
80   = updSAEnv (Just (v,([],[]))) `thenSAT_`
81     returnSAT ()
82
83 satAtom _ = returnSAT ()
84 \end{code}
85
86 \begin{code}
87 satExpr :: CoreExpr -> SatM CoreExpr
88
89 satExpr var@(Var v)
90   = updSAEnv (Just (v,([],[]))) `thenSAT_`
91     returnSAT var
92
93 satExpr lit@(Lit _) = returnSAT lit
94
95 satExpr e@(Con con types args)
96   = mapSAT satAtom args     `thenSAT_`
97     returnSAT e
98
99 satExpr e@(Prim prim ty args)
100   = mapSAT satAtom args     `thenSAT_`
101     returnSAT e
102
103 satExpr (Lam binders body)
104   = satExpr body                `thenSAT` \ body' ->
105     returnSAT (Lam binders body')
106
107 satExpr (CoTyLam tyvar body)
108   = satExpr body           `thenSAT` (\ body' ->
109     returnSAT (CoTyLam tyvar body') )
110
111 satExpr app@(App _ _)
112   = getAppArgs app
113
114 satExpr app@(CoTyApp _ _)
115   = getAppArgs app
116
117 satExpr (Case expr alts)
118   = satExpr expr        `thenSAT` \ expr' ->
119     sat_alts alts       `thenSAT` \ alts' ->
120     returnSAT (Case expr' alts')
121   where
122     sat_alts (AlgAlts alts deflt)
123       = mapSAT satAlgAlt alts       `thenSAT` \ alts' ->
124         sat_default deflt           `thenSAT` \ deflt' ->
125         returnSAT (AlgAlts alts' deflt')
126       where
127         satAlgAlt (con, params, rhs)
128           = satExpr rhs          `thenSAT` \ rhs' ->
129             returnSAT (con, params, rhs')
130
131     sat_alts (PrimAlts alts deflt)
132       = mapSAT satPrimAlt alts      `thenSAT` \ alts' ->
133         sat_default deflt           `thenSAT` \ deflt' ->
134         returnSAT (PrimAlts alts' deflt')
135       where
136         satPrimAlt (lit, rhs)
137           = satExpr rhs `thenSAT` \ rhs' ->
138             returnSAT (lit, rhs')
139
140     sat_default NoDefault
141       = returnSAT NoDefault
142     sat_default (BindDefault binder rhs)
143       = satExpr rhs                  `thenSAT` \ rhs' ->
144         returnSAT (BindDefault binder rhs')
145
146 satExpr (Let (NonRec binder rhs) body)
147   = satExpr body                `thenSAT` \ body' ->
148     satExpr rhs                 `thenSAT` \ rhs' ->
149     returnSAT (Let (NonRec binder rhs') body')
150
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')
157
158 satExpr (Let (Rec binds) body)
159   = let
160         (binders, rhss) = unzip binds
161     in
162     satExpr body                    `thenSAT` \ body' ->
163     mapSAT satExpr rhss             `thenSAT` \ rhss' ->
164     returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
165
166 satExpr (SCC cc expr)
167   = satExpr expr                    `thenSAT` \ expr2 ->
168     returnSAT (SCC cc expr2)
169
170 satExpr (Coerce c ty expr)
171   = satExpr expr                    `thenSAT` \ expr2 ->
172     returnSAT (Coerce c ty expr2)
173 \end{code}
174
175 \begin{code}
176 getAppArgs :: CoreExpr -> SatM CoreExpr
177
178 getAppArgs app
179   = get app             `thenSAT` \ (app',result) ->
180     updSAEnv result     `thenSAT_`
181     returnSAT app'
182   where
183     get :: CoreExpr
184         -> SatM (CoreExpr, Maybe (Id, SATInfo))
185
186     get (CoTyApp e ty)
187       = get e           `thenSAT` \ (e',result) ->
188         returnSAT (
189           CoTyApp e' ty,
190           case result of
191             Nothing          -> Nothing
192             Just (v,(tv,lv)) -> Just (v,(tv++[Static ty],lv))
193         )
194
195     get (App e a)
196       = get e           `thenSAT` \ (e', result) ->
197         satAtom a       `thenSAT_`
198         let si = case a of
199                    (VarArg v) -> Static v
200                    _             -> NotStatic
201         in
202           returnSAT (
203             App e' a,
204             case result of
205                 Just (v,(tv,lv)) -> Just (v,(tv,lv++[si]))
206                 Nothing          -> Nothing
207           )
208
209     get var@(Var v)
210       = returnSAT (var, Just (v,([],[])))
211
212     get e
213       = satExpr e       `thenSAT` \ e2 ->
214         returnSAT (e2, Nothing)
215 -}
216 \end{code}