[project @ 2000-09-07 16:31:45 by simonpj]
[ghc-hetmet.git] / ghc / compiler / simplCore / SimplCore.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
5
6 \begin{code}
7 module SimplCore ( core2core ) where
8
9 #include "HsVersions.h"
10
11 import CmdLineOpts      ( CoreToDo(..), SimplifierSwitch(..), 
12                           SwitchResult(..), intSwitchSet,
13                           opt_D_dump_occur_anal, opt_D_dump_rules,
14                           opt_D_dump_simpl_iterations,
15                           opt_D_dump_simpl_stats,
16                           opt_D_dump_rules,
17                           opt_D_verbose_core2core,
18                           opt_D_dump_occur_anal,
19                           opt_UsageSPOn
20                         )
21 import CoreLint         ( beginPass, endPass )
22 import CoreSyn
23 import CSE              ( cseProgram )
24 import Rules            ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareLocalRuleBase,
25                           prepareOrphanRuleBase, unionRuleBase, localRule )
26 import CoreUnfold
27 import PprCore          ( pprCoreBindings )
28 import OccurAnal        ( occurAnalyseBinds )
29 import CoreUtils        ( exprIsTrivial, etaReduceExpr, coreBindsSize )
30 import Simplify         ( simplTopBinds, simplExpr )
31 import SimplUtils       ( simplBinders )
32 import SimplMonad
33 import ErrUtils         ( dumpIfSet )
34 import FloatIn          ( floatInwards )
35 import FloatOut         ( floatOutwards )
36 import Id               ( isDataConWrapId )
37 import VarSet
38 import LiberateCase     ( liberateCase )
39 import SAT              ( doStaticArgs )
40 import Specialise       ( specProgram)
41 import UsageSPInf       ( doUsageSPInf )
42 import StrictAnal       ( saBinds )
43 import WorkWrap         ( wwTopBinds )
44 import CprAnalyse       ( cprAnalyse )
45
46 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
47 import IO               ( hPutStr, stderr )
48 import Outputable
49
50 import List             ( partition )
51 \end{code}
52
53 %************************************************************************
54 %*                                                                      *
55 \subsection{The driver for the simplifier}
56 %*                                                                      *
57 %************************************************************************
58
59 \begin{code}
60 core2core :: [CoreToDo]         -- Spec of what core-to-core passes to do
61           -> [CoreBind]         -- Binds in
62           -> [ProtoCoreRule]    -- Rules in
63           -> IO ([CoreBind], RuleBase)  -- binds, local orphan rules out
64
65 core2core core_todos binds rules
66   = do
67         us <-  mkSplitUniqSupply 's'
68         let (cp_us, ru_us) = splitUniqSupply us
69
70         let (local_rules, imported_rules) = partition localRule rules
71
72         better_local_rules <- simplRules ru_us local_rules binds
73
74         let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules
75             imported_rule_base        = prepareOrphanRuleBase imported_rules
76
77         -- Do the main business
78         (stats, processed_binds, processed_local_rules)
79             <- doCorePasses zeroSimplCount cp_us binds1 local_rule_base
80                             imported_rule_base Nothing core_todos
81
82         dumpIfSet opt_D_dump_simpl_stats
83                   "Grand total simplifier statistics"
84                   (pprSimplCount stats)
85
86         -- Return results
87         -- We only return local orphan rules, i.e., local rules not attached to an Id
88         return (processed_binds, processed_local_rules)
89
90
91 doCorePasses :: SimplCount      -- simplifier stats
92              -> UniqSupply      -- uniques
93              -> [CoreBind]      -- local binds in (with rules attached)
94              -> RuleBase        -- local orphan rules
95              -> RuleBase        -- imported and builtin rules
96              -> Maybe RuleBase  -- combined rulebase, or Nothing to ask for it to be rebuilt
97              -> [CoreToDo]      -- which passes to do
98              -> IO (SimplCount, [CoreBind], RuleBase)  -- stats, binds, local orphan rules
99
100 doCorePasses stats us binds lrb irb rb0 []
101   = return (stats, binds, lrb)
102
103 doCorePasses stats us binds lrb irb rb0 (to_do : to_dos) 
104   = do
105         let (us1, us2) = splitUniqSupply us
106
107         -- recompute rulebase if necessary
108         let rb         = maybe (irb `unionRuleBase` lrb) id rb0
109
110         (stats1, binds1, mlrb1) <- doCorePass us1 binds lrb rb to_do
111
112         -- request rulebase recomputation if pass returned a new local rulebase
113         let (lrb1,rb1) = maybe (lrb, Just rb) (\ lrb1 -> (lrb1, Nothing)) mlrb1
114
115         doCorePasses (stats `plusSimplCount` stats1) us2 binds1 lrb1 irb rb1 to_dos
116
117 doCorePass us binds lrb rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify"      simplifyPgm rb sw_chkr us binds
118 doCorePass us binds lrb rb CoreCSE                  = _scc_ "CommonSubExpr" noStats (cseProgram binds)
119 doCorePass us binds lrb rb CoreLiberateCase         = _scc_ "LiberateCase"  noStats (liberateCase binds)
120 doCorePass us binds lrb rb CoreDoFloatInwards       = _scc_ "FloatInwards"  noStats (floatInwards binds)
121 doCorePass us binds lrb rb (CoreDoFloatOutwards f)  = _scc_ "FloatOutwards" noStats (floatOutwards f us binds)
122 doCorePass us binds lrb rb CoreDoStaticArgs         = _scc_ "StaticArgs"    noStats (doStaticArgs us binds)
123 doCorePass us binds lrb rb CoreDoStrictness         = _scc_ "Stranal"       noStats (saBinds binds)
124 doCorePass us binds lrb rb CoreDoWorkerWrapper      = _scc_ "WorkWrap"      noStats (wwTopBinds us binds)
125 doCorePass us binds lrb rb CoreDoSpecialising       = _scc_ "Specialise"    noStats (specProgram us binds)
126 doCorePass us binds lrb rb CoreDoCPResult           = _scc_ "CPResult"      noStats (cprAnalyse binds)
127 doCorePass us binds lrb rb CoreDoPrintCore          = _scc_ "PrintCore"     noStats (printCore binds)
128 doCorePass us binds lrb rb CoreDoGlomBinds          = noStats (glomBinds binds)
129 doCorePass us binds lrb rb CoreDoUSPInf             = _scc_ "CoreUsageSPInf" noStats (doUsageSPInf us binds lrb)
130
131 printCore binds = do dumpIfSet True "Print Core"
132                                (pprCoreBindings binds)
133                      return binds
134
135 -- most passes return no stats and don't change rules
136 noStats thing = do { binds <- thing; return (zeroSimplCount, binds, Nothing) }
137 \end{code}
138
139
140
141 %************************************************************************
142 %*                                                                      *
143 \subsection{Dealing with rules}
144 %*                                                                      *
145 %************************************************************************
146
147 We must do some gentle simplifiation on the template (but not the RHS)
148 of each rule.  The case that forced me to add this was the fold/build rule,
149 which without simplification looked like:
150         fold k z (build (/\a. g a))  ==>  ...
151 This doesn't match unless you do eta reduction on the build argument.
152
153 \begin{code}
154 simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
155 simplRules us rules binds
156   = do  let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
157         
158         dumpIfSet opt_D_dump_rules
159                   "Transformation rules"
160                   (vcat (map pprProtoCoreRule better_rules))
161
162         return better_rules
163   where
164     black_list_all v = not (isDataConWrapId v)
165                 -- This stops all inlining except the
166                 -- wrappers for data constructors
167
168     sw_chkr any = SwBool False                  -- A bit bogus
169
170         -- Boringly, we need to gather the in-scope set.
171         -- Typically this thunk won't even be force, but the test in
172         -- simpVar fails if it isn't right, and it might conceivably matter
173     bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
174
175
176 simplRule rule@(ProtoCoreRule is_local id (BuiltinRule _))
177   = returnSmpl rule
178 simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
179   | not is_local
180   = returnSmpl rule     -- No need to fiddle with imported rules
181   | otherwise
182   = simplBinders bndrs                  $ \ bndrs' -> 
183     mapSmpl simpl_arg args              `thenSmpl` \ args' ->
184     simplExpr rhs                       `thenSmpl` \ rhs' ->
185     returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
186
187 simpl_arg e 
188 --  I've seen rules in which a LHS like 
189 --      augment g (build h) 
190 -- turns into
191 --      augment (\a. g a) (build h)
192 -- So it's a help to eta-reduce the args as we simplify them.
193 -- Otherwise we don't match when given an argument like
194 --      (\a. h a a)
195   = simplExpr e         `thenSmpl` \ e' ->
196     returnSmpl (etaReduceExpr e')
197 \end{code}
198
199 \begin{code}
200 glomBinds :: [CoreBind] -> IO [CoreBind]
201 -- Glom all binds together in one Rec, in case any
202 -- transformations have introduced any new dependencies
203 --
204 -- NB: the global invariant is this:
205 --      *** the top level bindings are never cloned, and are always unique ***
206 --
207 -- We sort them into dependency order, but applying transformation rules may
208 -- make something at the top refer to something at the bottom:
209 --      f = \x -> p (q x)
210 --      h = \y -> 3
211 --      
212 --      RULE:  p (q x) = h x
213 --
214 -- Applying this rule makes f refer to h, 
215 -- although it doesn't appear to in the source program.  
216 -- This pass lets us control where it happens.
217 --
218 -- NOTICE that this cannot happen for rules whose head is a locally-defined
219 -- function.  It only happens for rules whose head is an imported function
220 -- (p in the example above).  So, for example, the rule had been
221 --      RULE: f (p x) = h x
222 -- then the rule for f would be attached to f itself (in its IdInfo) 
223 -- by prepareLocalRuleBase and h would be regarded by the occurrency 
224 -- analyser as free in f.
225
226 glomBinds binds
227   = do { beginPass "GlomBinds" ;
228          let { recd_binds = [Rec (flattenBinds binds)] } ;
229          return recd_binds }
230         -- Not much point in printing the result... 
231         -- just consumes output bandwidth
232 \end{code}
233
234 %************************************************************************
235 %*                                                                      *
236 \subsection{The driver for the simplifier}
237 %*                                                                      *
238 %************************************************************************
239
240 \begin{code}
241 simplifyPgm :: RuleBase
242             -> (SimplifierSwitch -> SwitchResult)
243             -> UniqSupply
244             -> [CoreBind]                                   -- Input
245             -> IO (SimplCount, [CoreBind], Maybe RuleBase)  -- New bindings
246
247 simplifyPgm (imported_rule_ids, rule_lhs_fvs) 
248             sw_chkr us binds
249   = do {
250         beginPass "Simplify";
251
252         (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount binds;
253
254         dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
255                   "Simplifier statistics"
256                   (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
257                          text "",
258                          pprSimplCount counts_out]);
259
260         endPass "Simplify" 
261                 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
262                 binds' ;
263
264         return (counts_out, binds', Nothing)
265     }
266   where
267     max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
268     black_list_fn  = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
269
270     iteration us iteration_no counts binds
271       -- Try and force thunks off the binds; significantly reduces
272       -- space usage, especially with -O.  JRS, 000620.
273       | let sz = coreBindsSize binds in sz == sz
274       = do {
275                 -- Occurrence analysis
276            let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
277
278            dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
279                      (pprCoreBindings tagged_binds);
280
281                 -- SIMPLIFY
282                 -- We do this with a *case* not a *let* because lazy pattern
283                 -- matching bit us with bad space leak!
284                 -- With a let, we ended up with
285                 --   let
286                 --      t = initSmpl ...
287                 --      counts' = snd t
288                 --   in
289                 --      case t of {(_,counts') -> if counts'=0 then ...
290                 -- So the conditional didn't force counts', because the
291                 -- selection got duplicated.  Sigh!
292            case initSmpl sw_chkr us1 imported_rule_ids black_list_fn 
293                          (simplTopBinds tagged_binds)
294                 of { (binds', counts') -> do {
295                         -- The imported_rule_ids are used by initSmpl to initialise
296                         -- the in-scope set.  That way, the simplifier will change any
297                         -- occurrences of the imported id to the one in the imported_rule_ids
298                         -- set, which are decorated with their rules.
299
300            let { all_counts = counts `plusSimplCount` counts' } ;
301
302                 -- Stop if nothing happened; don't dump output
303            if isZeroSimplCount counts' then
304                 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
305            else do {
306
307                 -- Dump the result of this iteration
308            dumpIfSet opt_D_dump_simpl_iterations
309                      ("Simplifier iteration " ++ show iteration_no 
310                       ++ " out of " ++ show max_iterations)
311                      (pprSimplCount counts') ;
312
313            if opt_D_dump_simpl_iterations then
314                 endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
315                         opt_D_verbose_core2core
316                         binds'
317            else
318                 return [] ;
319
320                 -- Stop if we've run out of iterations
321            if iteration_no == max_iterations then
322                 do {
323 #ifdef DEBUG
324                     if  max_iterations > 2 then
325                             hPutStr stderr ("NOTE: Simplifier still going after " ++ 
326                                     show max_iterations ++ 
327                                     " iterations; bailing out.\n")
328                     else 
329 #endif
330                         return ();
331
332                     return ("Simplifier baled out", iteration_no, all_counts, binds')
333                 }
334
335                 -- Else loop
336            else iteration us2 (iteration_no + 1) all_counts binds'
337         }  } } }
338       where
339           (us1, us2) = splitUniqSupply us
340 \end{code}