4456f6e93468ffc4bd7d281bae4ee355f63465e9
[ghc.git] / 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 {-# LANGUAGE CPP #-}
8
9 module SimplCore ( core2core, simplifyExpr ) where
10
11 #include "HsVersions.h"
12
13 import DynFlags
14 import CoreSyn
15 import CoreSubst
16 import HscTypes
17 import CSE              ( cseProgram )
18 import Rules            ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
19                           extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
20 import PprCore          ( pprCoreBindings, pprCoreExpr )
21 import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
22 import IdInfo
23 import CoreUtils        ( coreBindsSize, coreBindsStats, exprSize )
24 import Simplify         ( simplTopBinds, simplExpr )
25 import SimplUtils       ( simplEnvForGHCi, activeRule )
26 import SimplEnv
27 import SimplMonad
28 import CoreMonad
29 import qualified ErrUtils as Err
30 import FloatIn          ( floatInwards )
31 import FloatOut         ( floatOutwards )
32 import FamInstEnv
33 import Id
34 import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma )
35 import VarSet
36 import VarEnv
37 import LiberateCase     ( liberateCase )
38 import SAT              ( doStaticArgs )
39 import Specialise       ( specProgram)
40 import SpecConstr       ( specConstrProgram)
41 import DmdAnal          ( dmdAnalProgram )
42 import CallArity        ( callArityAnalProgram )
43 import WorkWrap         ( wwTopBinds )
44 import Vectorise        ( vectorise )
45 import FastString
46 import SrcLoc
47 import Util
48
49 import Maybes
50 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
51 import Outputable
52 import Control.Monad
53
54 #ifdef GHCI
55 import Type             ( mkTyConTy )
56 import RdrName          ( mkRdrQual )
57 import OccName          ( mkVarOcc )
58 import PrelNames        ( pluginTyConName )
59 import DynamicLoading   ( forceLoadTyCon, lookupRdrNameInModuleForPlugins, getValueSafely )
60 import Module           ( ModuleName )
61 import Panic
62 #endif
63 \end{code}
64
65 %************************************************************************
66 %*                                                                      *
67 \subsection{The driver for the simplifier}
68 %*                                                                      *
69 %************************************************************************
70
71 \begin{code}
72 core2core :: HscEnv -> ModGuts -> IO ModGuts
73 core2core hsc_env guts
74   = do { us <- mkSplitUniqSupply 's'
75        -- make sure all plugins are loaded
76
77        ; let builtin_passes = getCoreToDo dflags
78        ;
79        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $
80                            do { all_passes <- addPluginPasses dflags builtin_passes
81                               ; runCorePasses all_passes guts }
82
83 {--
84        ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline
85              "Plugin information" "" -- TODO FIXME: dump plugin info
86 --}
87        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
88              "Grand total simplifier statistics"
89              (pprSimplCount stats)
90
91        ; return guts2 }
92   where
93     dflags         = hsc_dflags hsc_env
94     home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
95     hpt_rule_base  = mkRuleBase home_pkg_rules
96     mod            = mg_module guts
97     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
98     -- This is very convienent for the users of the monad (e.g. plugins do not have to
99     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
100     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
101     -- would mean our cached value would go out of date.
102     print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
103 \end{code}
104
105
106 %************************************************************************
107 %*                                                                      *
108            Generating the main optimisation pipeline
109 %*                                                                      *
110 %************************************************************************
111
112 \begin{code}
113 getCoreToDo :: DynFlags -> [CoreToDo]
114 getCoreToDo dflags
115   = core_todo
116   where
117     opt_level     = optLevel           dflags
118     phases        = simplPhases        dflags
119     max_iter      = maxSimplIterations dflags
120     rule_check    = ruleCheck          dflags
121     call_arity    = gopt Opt_CallArity                    dflags
122     strictness    = gopt Opt_Strictness                   dflags
123     full_laziness = gopt Opt_FullLaziness                 dflags
124     do_specialise = gopt Opt_Specialise                   dflags
125     do_float_in   = gopt Opt_FloatIn                      dflags
126     cse           = gopt Opt_CSE                          dflags
127     spec_constr   = gopt Opt_SpecConstr                   dflags
128     liberate_case = gopt Opt_LiberateCase                 dflags
129     late_dmd_anal = gopt Opt_LateDmdAnal                  dflags
130     static_args   = gopt Opt_StaticArgumentTransformation dflags
131     rules_on      = gopt Opt_EnableRewriteRules           dflags
132     eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
133
134     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
135
136     maybe_strictness_before phase
137       = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
138
139     base_mode = SimplMode { sm_phase      = panic "base_mode"
140                           , sm_names      = []
141                           , sm_rules      = rules_on
142                           , sm_eta_expand = eta_expand_on
143                           , sm_inline     = True
144                           , sm_case_case  = True }
145
146     simpl_phase phase names iter
147       = CoreDoPasses
148       $   [ maybe_strictness_before phase
149           , CoreDoSimplify iter
150                 (base_mode { sm_phase = Phase phase
151                            , sm_names = names })
152
153           , maybe_rule_check (Phase phase) ]
154
155           -- Vectorisation can introduce a fair few common sub expressions involving
156           --  DPH primitives. For example, see the Reverse test from dph-examples.
157           --  We need to eliminate these common sub expressions before their definitions
158           --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings,
159           --  so we also run simpl_gently to inline them.
160       ++  (if gopt Opt_Vectorise dflags && phase == 3
161             then [CoreCSE, simpl_gently]
162             else [])
163
164     vectorisation
165       = runWhen (gopt Opt_Vectorise dflags) $
166           CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
167
168                 -- By default, we have 2 phases before phase 0.
169
170                 -- Want to run with inline phase 2 after the specialiser to give
171                 -- maximum chance for fusion to work before we inline build/augment
172                 -- in phase 1.  This made a difference in 'ansi' where an
173                 -- overloaded function wasn't inlined till too late.
174
175                 -- Need phase 1 so that build/augment get
176                 -- inlined.  I found that spectral/hartel/genfft lost some useful
177                 -- strictness in the function sumcode' if augment is not inlined
178                 -- before strictness analysis runs
179     simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
180                                 | phase <- [phases, phases-1 .. 1] ]
181
182
183         -- initial simplify: mk specialiser happy: minimum effort please
184     simpl_gently = CoreDoSimplify max_iter
185                        (base_mode { sm_phase = InitialPhase
186                                   , sm_names = ["Gentle"]
187                                   , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]
188                                   , sm_inline = False
189                                   , sm_case_case = False })
190                           -- Don't do case-of-case transformations.
191                           -- This makes full laziness work better
192
193     -- New demand analyser
194     demand_analyser = (CoreDoPasses ([
195                            CoreDoStrictness,
196                            CoreDoWorkerWrapper,
197                            simpl_phase 0 ["post-worker-wrapper"] max_iter
198                            ]))
199
200     core_todo =
201      if opt_level == 0 then
202        [ vectorisation
203        , CoreDoSimplify max_iter
204              (base_mode { sm_phase = Phase 0
205                         , sm_names = ["Non-opt simplification"] })
206        ]
207
208      else {- opt_level >= 1 -} [
209
210     -- We want to do the static argument transform before full laziness as it
211     -- may expose extra opportunities to float things outwards. However, to fix
212     -- up the output of the transformation we need at do at least one simplify
213     -- after this before anything else
214         runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
215
216         -- We run vectorisation here for now, but we might also try to run
217         -- it later
218         vectorisation,
219
220         -- initial simplify: mk specialiser happy: minimum effort please
221         simpl_gently,
222
223         -- Specialisation is best done before full laziness
224         -- so that overloaded functions have all their dictionary lambdas manifest
225         runWhen do_specialise CoreDoSpecialising,
226
227         runWhen full_laziness $
228            CoreDoFloatOutwards FloatOutSwitches {
229                                  floatOutLambdas   = Just 0,
230                                  floatOutConstants = True,
231                                  floatOutOverSatApps = False },
232                 -- Was: gentleFloatOutSwitches
233                 --
234                 -- I have no idea why, but not floating constants to
235                 -- top level is very bad in some cases.
236                 --
237                 -- Notably: p_ident in spectral/rewrite
238                 --          Changing from "gentle" to "constantsOnly"
239                 --          improved rewrite's allocation by 19%, and
240                 --          made 0.0% difference to any other nofib
241                 --          benchmark
242                 --
243                 -- Not doing floatOutOverSatApps yet, we'll do
244                 -- that later on when we've had a chance to get more
245                 -- accurate arity information.  In fact it makes no
246                 -- difference at all to performance if we do it here,
247                 -- but maybe we save some unnecessary to-and-fro in
248                 -- the simplifier.
249
250         simpl_phases,
251
252                 -- Phase 0: allow all Ids to be inlined now
253                 -- This gets foldr inlined before strictness analysis
254
255                 -- At least 3 iterations because otherwise we land up with
256                 -- huge dead expressions because of an infelicity in the
257                 -- simpifier.
258                 --      let k = BIG in foldr k z xs
259                 -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
260                 -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
261                 -- Don't stop now!
262         simpl_phase 0 ["main"] (max max_iter 3),
263
264         runWhen do_float_in CoreDoFloatInwards,
265             -- Run float-inwards immediately before the strictness analyser
266             -- Doing so pushes bindings nearer their use site and hence makes
267             -- them more likely to be strict. These bindings might only show
268             -- up after the inlining from simplification.  Example in fulsom,
269             -- Csg.calc, where an arg of timesDouble thereby becomes strict.
270
271         runWhen call_arity $ CoreDoPasses
272             [ CoreDoCallArity
273             , simpl_phase 0 ["post-call-arity"] max_iter
274             ],
275
276         runWhen strictness demand_analyser,
277
278         runWhen full_laziness $
279            CoreDoFloatOutwards FloatOutSwitches {
280                                  floatOutLambdas     = floatLamArgs dflags,
281                                  floatOutConstants   = True,
282                                  floatOutOverSatApps = True },
283                 -- nofib/spectral/hartel/wang doubles in speed if you
284                 -- do full laziness late in the day.  It only happens
285                 -- after fusion and other stuff, so the early pass doesn't
286                 -- catch it.  For the record, the redex is
287                 --        f_el22 (f_el21 r_midblock)
288
289
290         runWhen cse CoreCSE,
291                 -- We want CSE to follow the final full-laziness pass, because it may
292                 -- succeed in commoning up things floated out by full laziness.
293                 -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
294
295         runWhen do_float_in CoreDoFloatInwards,
296
297         maybe_rule_check (Phase 0),
298
299                 -- Case-liberation for -O2.  This should be after
300                 -- strictness analysis and the simplification which follows it.
301         runWhen liberate_case (CoreDoPasses [
302             CoreLiberateCase,
303             simpl_phase 0 ["post-liberate-case"] max_iter
304             ]),         -- Run the simplifier after LiberateCase to vastly
305                         -- reduce the possiblility of shadowing
306                         -- Reason: see Note [Shadowing] in SpecConstr.lhs
307
308         runWhen spec_constr CoreDoSpecConstr,
309
310         maybe_rule_check (Phase 0),
311
312         -- Final clean-up simplification:
313         simpl_phase 0 ["final"] max_iter,
314
315         runWhen late_dmd_anal $ CoreDoPasses [
316             CoreDoStrictness,
317             CoreDoWorkerWrapper,
318             simpl_phase 0 ["post-late-ww"] max_iter
319           ],
320
321         maybe_rule_check (Phase 0)
322      ]
323 \end{code}
324
325 Loading plugins
326
327 \begin{code}
328 addPluginPasses :: DynFlags -> [CoreToDo] -> CoreM [CoreToDo]
329 #ifndef GHCI
330 addPluginPasses _ builtin_passes = return builtin_passes
331 #else
332 addPluginPasses dflags builtin_passes
333   = do { hsc_env <- getHscEnv
334        ; named_plugins <- liftIO (loadPlugins hsc_env)
335        ; foldM query_plug builtin_passes named_plugins }
336   where
337     query_plug todos (mod_nm, plug)
338        = installCoreToDos plug options todos
339        where
340          options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
341                             , opt_mod_nm == mod_nm ]
342
343 loadPlugins :: HscEnv -> IO [(ModuleName, Plugin)]
344 loadPlugins hsc_env
345   = do { let to_load = pluginModNames (hsc_dflags hsc_env)
346        ; plugins <- mapM (loadPlugin hsc_env) to_load
347        ; return $ to_load `zip` plugins }
348
349 loadPlugin :: HscEnv -> ModuleName -> IO Plugin
350 loadPlugin hsc_env mod_name
351   = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin")
352              dflags = hsc_dflags hsc_env
353        ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name plugin_rdr_name
354        ; case mb_name of {
355             Nothing ->
356                 throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
357                           [ ptext (sLit "The module"), ppr mod_name
358                           , ptext (sLit "did not export the plugin name")
359                           , ppr plugin_rdr_name ]) ;
360             Just name ->
361
362      do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName
363         ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
364         ; case mb_plugin of
365             Nothing ->
366                 throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
367                           [ ptext (sLit "The value"), ppr name
368                           , ptext (sLit "did not have the type")
369                           , ppr pluginTyConName, ptext (sLit "as required")])
370             Just plugin -> return plugin } } }
371 #endif
372 \end{code}
373
374 %************************************************************************
375 %*                                                                      *
376                   The CoreToDo interpreter
377 %*                                                                      *
378 %************************************************************************
379
380 \begin{code}
381 runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
382 runCorePasses passes guts
383   = foldM do_pass guts passes
384   where
385     do_pass guts CoreDoNothing = return guts
386     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
387     do_pass guts pass
388        = do { showPass pass
389             ; guts' <- doCorePass pass guts
390             ; endPass pass (mg_binds guts') (mg_rules guts')
391             ; return guts' }
392
393 doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
394 doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
395                                        simplifyPgm pass
396
397 doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}
398                                        doPass cseProgram
399
400 doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
401                                        doPassD liberateCase
402
403 doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
404                                        doPassD floatInwards
405
406 doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
407                                        doPassDUM (floatOutwards f)
408
409 doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
410                                        doPassU doStaticArgs
411
412 doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}
413                                        doPassD callArityAnalProgram
414
415 doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}
416                                        doPassDFM dmdAnalProgram
417
418 doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
419                                        doPassDFU wwTopBinds
420
421 doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
422                                        specProgram
423
424 doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
425                                        specConstrProgram
426
427 doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
428                                        vectorise
429
430 doCorePass CoreDoPrintCore              = observe   printCore
431 doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
432 doCorePass CoreDoNothing                = return
433 doCorePass (CoreDoPasses passes)        = runCorePasses passes
434
435 #ifdef GHCI
436 doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
437 #endif
438
439 doCorePass pass = pprPanic "doCorePass" (ppr pass)
440 \end{code}
441
442 %************************************************************************
443 %*                                                                      *
444 \subsection{Core pass combinators}
445 %*                                                                      *
446 %************************************************************************
447
448 \begin{code}
449 printCore :: DynFlags -> CoreProgram -> IO ()
450 printCore dflags binds
451     = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
452
453 ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
454 ruleCheckPass current_phase pat guts = do
455     rb <- getRuleBase
456     dflags <- getDynFlags
457     liftIO $ Err.showPass dflags "RuleCheck"
458     liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
459                  (ruleCheckProgram current_phase pat rb (mg_binds guts))
460     return guts
461
462
463 doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
464 doPassDUM do_pass = doPassM $ \binds -> do
465     dflags <- getDynFlags
466     us     <- getUniqueSupplyM
467     liftIO $ do_pass dflags us binds
468
469 doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
470 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
471
472 doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
473 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
474
475 doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
476 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
477
478 doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
479 doPassU do_pass = doPassDU (const do_pass)
480
481 doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
482 doPassDFM do_pass guts = do
483     dflags <- getDynFlags
484     p_fam_env <- getPackageFamInstEnv
485     let fam_envs = (p_fam_env, mg_fam_inst_env guts)
486     doPassM (liftIO . do_pass dflags fam_envs) guts
487
488 doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
489 doPassDFU do_pass guts = do
490     dflags <- getDynFlags
491     us     <- getUniqueSupplyM
492     p_fam_env <- getPackageFamInstEnv
493     let fam_envs = (p_fam_env, mg_fam_inst_env guts)
494     doPass (do_pass dflags fam_envs us) guts
495
496 -- Most passes return no stats and don't change rules: these combinators
497 -- let us lift them to the full blown ModGuts+CoreM world
498 doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
499 doPassM bind_f guts = do
500     binds' <- bind_f (mg_binds guts)
501     return (guts { mg_binds = binds' })
502
503 doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
504 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
505
506 -- Observer passes just peek; don't modify the bindings at all
507 observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
508 observe do_pass = doPassM $ \binds -> do
509     dflags <- getDynFlags
510     _ <- liftIO $ do_pass dflags binds
511     return binds
512 \end{code}
513
514
515 %************************************************************************
516 %*                                                                      *
517         Gentle simplification
518 %*                                                                      *
519 %************************************************************************
520
521 \begin{code}
522 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
523              -> CoreExpr
524              -> IO CoreExpr
525 -- simplifyExpr is called by the driver to simplify an
526 -- expression typed in at the interactive prompt
527 --
528 -- Also used by Template Haskell
529 simplifyExpr dflags expr
530   = do  {
531         ; Err.showPass dflags "Simplify"
532
533         ; us <-  mkSplitUniqSupply 's'
534
535         ; let sz = exprSize expr
536
537         ; (expr', counts) <- initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
538                                  simplExprGently (simplEnvForGHCi dflags) expr
539
540         ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
541                   "Simplifier statistics" (pprSimplCount counts)
542
543         ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
544                         (pprCoreExpr expr')
545
546         ; return expr'
547         }
548
549 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
550 -- Simplifies an expression
551 --      does occurrence analysis, then simplification
552 --      and repeats (twice currently) because one pass
553 --      alone leaves tons of crud.
554 -- Used (a) for user expressions typed in at the interactive prompt
555 --      (b) the LHS and RHS of a RULE
556 --      (c) Template Haskell splices
557 --
558 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
559 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
560 -- enforce that; it just simplifies the expression twice
561
562 -- It's important that simplExprGently does eta reduction; see
563 -- Note [Simplifying the left-hand side of a RULE] above.  The
564 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
565 -- but only if -O is on.
566
567 simplExprGently env expr = do
568     expr1 <- simplExpr env (occurAnalyseExpr expr)
569     simplExpr env (occurAnalyseExpr expr1)
570 \end{code}
571
572
573 %************************************************************************
574 %*                                                                      *
575 \subsection{The driver for the simplifier}
576 %*                                                                      *
577 %************************************************************************
578
579 \begin{code}
580 simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
581 simplifyPgm pass guts
582   = do { hsc_env <- getHscEnv
583        ; us <- getUniqueSupplyM
584        ; rb <- getRuleBase
585        ; liftIOWithCount $
586          simplifyPgmIO pass hsc_env us rb guts }
587
588 simplifyPgmIO :: CoreToDo
589               -> HscEnv
590               -> UniqSupply
591               -> RuleBase
592               -> ModGuts
593               -> IO (SimplCount, ModGuts)  -- New bindings
594
595 simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
596               hsc_env us hpt_rule_base
597               guts@(ModGuts { mg_module = this_mod
598                             , mg_rdr_env = rdr_env
599                             , mg_binds = binds, mg_rules = rules
600                             , mg_fam_inst_env = fam_inst_env })
601   = do { (termination_msg, it_count, counts_out, guts')
602            <- do_iteration us 1 [] binds rules
603
604         ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&
605                                 dopt Opt_D_dump_simpl_stats  dflags)
606                   "Simplifier statistics for following pass"
607                   (vcat [text termination_msg <+> text "after" <+> ppr it_count
608                                               <+> text "iterations",
609                          blankLine,
610                          pprSimplCount counts_out])
611
612         ; return (counts_out, guts')
613     }
614   where
615     dflags       = hsc_dflags hsc_env
616     print_unqual = mkPrintUnqualified dflags rdr_env
617     simpl_env    = mkSimplEnv mode
618     active_rule  = activeRule simpl_env
619
620     do_iteration :: UniqSupply
621                  -> Int          -- Counts iterations
622                  -> [SimplCount] -- Counts from earlier iterations, reversed
623                  -> CoreProgram  -- Bindings in
624                  -> [CoreRule]   -- and orphan rules
625                  -> IO (String, Int, SimplCount, ModGuts)
626
627     do_iteration us iteration_no counts_so_far binds rules
628         -- iteration_no is the number of the iteration we are
629         -- about to begin, with '1' for the first
630       | iteration_no > max_iterations   -- Stop if we've run out of iterations
631       = WARN( debugIsOn && (max_iterations > 2)
632             , hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations
633                     <+> ptext (sLit "iterations")
634                     <+> (brackets $ hsep $ punctuate comma $
635                          map (int . simplCountN) (reverse counts_so_far)))
636                  2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds)))
637
638                 -- Subtract 1 from iteration_no to get the
639                 -- number of iterations we actually completed
640         return ( "Simplifier baled out", iteration_no - 1
641                , totalise counts_so_far
642                , guts { mg_binds = binds, mg_rules = rules } )
643
644       -- Try and force thunks off the binds; significantly reduces
645       -- space usage, especially with -O.  JRS, 000620.
646       | let sz = coreBindsSize binds
647       , sz == sz     -- Force it
648       = do {
649                 -- Occurrence analysis
650            let {   -- Note [Vectorisation declarations and occurrences]
651                    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
652                    -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure
653                    -- that the right-hand sides of vectorisation declarations are taken into
654                    -- account during occurrence analysis. After the 'InitialPhase', we need to ensure
655                    -- that the binders representing variable vectorisation declarations are kept alive.
656                    -- (In contrast to automatically vectorised variables, their unvectorised versions
657                    -- don't depend on them.)
658                  vectVars = mkVarSet $
659                               catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr
660                                         | Vect bndr _ <- mg_vect_decls guts]
661                               ++
662                               catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr
663                                         | bndr <- bindersOfBinds binds]
664                                         -- FIXME: This second comprehensions is only needed as long as we
665                                         --        have vectorised bindings where we get "Could NOT call
666                                         --        vectorised from original version".
667               ;  (maybeVects, maybeVectVars)
668                    = case sm_phase mode of
669                        InitialPhase -> (mg_vect_decls guts, vectVars)
670                        _            -> ([], vectVars)
671                ; tagged_binds = {-# SCC "OccAnal" #-}
672                      occurAnalysePgm this_mod active_rule rules maybeVects maybeVectVars binds
673                } ;
674            Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
675                      (pprCoreBindings tagged_binds);
676
677                 -- Get any new rules, and extend the rule base
678                 -- See Note [Overall plumbing for rules] in Rules.lhs
679                 -- We need to do this regularly, because simplification can
680                 -- poke on IdInfo thunks, which in turn brings in new rules
681                 -- behind the scenes.  Otherwise there's a danger we'll simply
682                 -- miss the rules for Ids hidden inside imported inlinings
683            eps <- hscEPS hsc_env ;
684            let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
685                 ; rule_base2 = extendRuleBaseList rule_base1 rules
686                 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
687                                 simplTopBinds simpl_env tagged_binds
688                 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
689
690                 -- Simplify the program
691            (env1, counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds ;
692
693            let  { binds1 = getFloatBinds env1
694                 ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
695                 } ;
696
697                 -- Stop if nothing happened; don't dump output
698            if isZeroSimplCount counts1 then
699                 return ( "Simplifier reached fixed point", iteration_no
700                        , totalise (counts1 : counts_so_far)  -- Include "free" ticks
701                        , guts { mg_binds = binds1, mg_rules = rules1 } )
702            else do {
703                 -- Short out indirections
704                 -- We do this *after* at least one run of the simplifier
705                 -- because indirection-shorting uses the export flag on *occurrences*
706                 -- and that isn't guaranteed to be ok until after the first run propagates
707                 -- stuff from the binding site to its occurrences
708                 --
709                 -- ToDo: alas, this means that indirection-shorting does not happen at all
710                 --       if the simplifier does nothing (not common, I know, but unsavoury)
711            let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
712
713                 -- Dump the result of this iteration
714            dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;
715            lintPassResult hsc_env pass binds2 ;
716
717                 -- Loop
718            do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
719            } }
720       | otherwise = panic "do_iteration"
721       where
722         (us1, us2) = splitUniqSupply us
723
724         -- Remember the counts_so_far are reversed
725         totalise :: [SimplCount] -> SimplCount
726         totalise = foldr (\c acc -> acc `plusSimplCount` c)
727                          (zeroSimplCount dflags)
728
729 simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
730
731 -------------------
732 dump_end_iteration :: DynFlags -> PrintUnqualified -> Int
733                    -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
734 dump_end_iteration dflags print_unqual iteration_no counts binds rules
735   = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules
736   where
737     mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations
738             | otherwise                               = Nothing
739             -- Show details if Opt_D_dump_simpl_iterations is on
740
741     hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no
742     pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr
743                      , pprSimplCount counts
744                      , ptext (sLit "---- End of simplifier counts for") <+> hdr ]
745 \end{code}
746
747
748 %************************************************************************
749 %*                                                                      *
750                 Shorting out indirections
751 %*                                                                      *
752 %************************************************************************
753
754 If we have this:
755
756         x_local = <expression>
757         ...bindings...
758         x_exported = x_local
759
760 where x_exported is exported, and x_local is not, then we replace it with this:
761
762         x_exported = <expression>
763         x_local = x_exported
764         ...bindings...
765
766 Without this we never get rid of the x_exported = x_local thing.  This
767 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
768 makes strictness information propagate better.  This used to happen in
769 the final phase, but it's tidier to do it here.
770
771 Note [Transferring IdInfo]
772 ~~~~~~~~~~~~~~~~~~~~~~~~~~
773 We want to propagage any useful IdInfo on x_local to x_exported.
774
775 STRICTNESS: if we have done strictness analysis, we want the strictness info on
776 x_local to transfer to x_exported.  Hence the copyIdInfo call.
777
778 RULES: we want to *add* any RULES for x_local to x_exported.
779
780
781 Note [Messing up the exported Id's RULES]
782 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
783 We must be careful about discarding (obviously) or even merging the
784 RULES on the exported Id. The example that went bad on me at one stage
785 was this one:
786
787     iterate :: (a -> a) -> a -> [a]
788         [Exported]
789     iterate = iterateList
790
791     iterateFB c f x = x `c` iterateFB c f (f x)
792     iterateList f x =  x : iterateList f (f x)
793         [Not exported]
794
795     {-# RULES
796     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
797     "iterateFB"                 iterateFB (:) = iterateList
798      #-}
799
800 This got shorted out to:
801
802     iterateList :: (a -> a) -> a -> [a]
803     iterateList = iterate
804
805     iterateFB c f x = x `c` iterateFB c f (f x)
806     iterate f x =  x : iterate f (f x)
807
808     {-# RULES
809     "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
810     "iterateFB"                 iterateFB (:) = iterate
811      #-}
812
813 And now we get an infinite loop in the rule system
814         iterate f x -> build (\cn -> iterateFB c f x)
815                     -> iterateFB (:) f x
816                     -> iterate f x
817
818 Old "solution":
819         use rule switching-off pragmas to get rid
820         of iterateList in the first place
821
822 But in principle the user *might* want rules that only apply to the Id
823 he says.  And inline pragmas are similar
824    {-# NOINLINE f #-}
825    f = local
826    local = <stuff>
827 Then we do not want to get rid of the NOINLINE.
828
829 Hence hasShortableIdinfo.
830
831
832 Note [Rules and indirection-zapping]
833 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
834 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
835 Then the things mentioned can be out of scope!  Solution
836  a) Make sure that in this pass the usage-info from x_exported is
837         available for ...bindings...
838  b) If there are any such RULES, rec-ify the entire top-level.
839     It'll get sorted out next time round
840
841 Other remarks
842 ~~~~~~~~~~~~~
843 If more than one exported thing is equal to a local thing (i.e., the
844 local thing really is shared), then we do one only:
845 \begin{verbatim}
846         x_local = ....
847         x_exported1 = x_local
848         x_exported2 = x_local
849 ==>
850         x_exported1 = ....
851
852         x_exported2 = x_exported1
853 \end{verbatim}
854
855 We rely on prior eta reduction to simplify things like
856 \begin{verbatim}
857         x_exported = /\ tyvars -> x_local tyvars
858 ==>
859         x_exported = x_local
860 \end{verbatim}
861 Hence,there's a possibility of leaving unchanged something like this:
862 \begin{verbatim}
863         x_local = ....
864         x_exported1 = x_local Int
865 \end{verbatim}
866 By the time we've thrown away the types in STG land this
867 could be eliminated.  But I don't think it's very common
868 and it's dangerous to do this fiddling in STG land
869 because we might elminate a binding that's mentioned in the
870 unfolding for something.
871
872 \begin{code}
873 type IndEnv = IdEnv Id          -- Maps local_id -> exported_id
874
875 shortOutIndirections :: CoreProgram -> CoreProgram
876 shortOutIndirections binds
877   | isEmptyVarEnv ind_env = binds
878   | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]
879   | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
880   where
881     ind_env            = makeIndEnv binds
882     exp_ids            = varSetElems ind_env    -- These exported Ids are the subjects
883     exp_id_set         = mkVarSet exp_ids       -- of the indirection-elimination
884     no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
885     binds'             = concatMap zap binds
886
887     zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
888     zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
889
890     zapPair (bndr, rhs)
891         | bndr `elemVarSet` exp_id_set             = []
892         | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
893                                                       (bndr, Var exp_id)]
894         | otherwise                                = [(bndr,rhs)]
895
896 makeIndEnv :: [CoreBind] -> IndEnv
897 makeIndEnv binds
898   = foldr add_bind emptyVarEnv binds
899   where
900     add_bind :: CoreBind -> IndEnv -> IndEnv
901     add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
902     add_bind (Rec pairs)              env = foldr add_pair env pairs
903
904     add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
905     add_pair (exported_id, Var local_id) env
906         | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
907     add_pair _ env = env
908
909 -----------------
910 shortMeOut :: IndEnv -> Id -> Id -> Bool
911 shortMeOut ind_env exported_id local_id
912 -- The if-then-else stuff is just so I can get a pprTrace to see
913 -- how often I don't get shorting out because of IdInfo stuff
914   = if isExportedId exported_id &&              -- Only if this is exported
915
916        isLocalId local_id &&                    -- Only if this one is defined in this
917                                                 --      module, so that we *can* change its
918                                                 --      binding to be the exported thing!
919
920        not (isExportedId local_id) &&           -- Only if this one is not itself exported,
921                                                 --      since the transformation will nuke it
922
923        not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for
924     then
925         if hasShortableIdInfo exported_id
926         then True       -- See Note [Messing up the exported Id's IdInfo]
927         else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
928              False
929     else
930         False
931
932 -----------------
933 hasShortableIdInfo :: Id -> Bool
934 -- True if there is no user-attached IdInfo on exported_id,
935 -- so we can safely discard it
936 -- See Note [Messing up the exported Id's IdInfo]
937 hasShortableIdInfo id
938   =  isEmptySpecInfo (specInfo info)
939   && isDefaultInlinePragma (inlinePragInfo info)
940   && not (isStableUnfolding (unfoldingInfo info))
941   where
942      info = idInfo id
943
944 -----------------
945 transferIdInfo :: Id -> Id -> Id
946 -- See Note [Transferring IdInfo]
947 -- If we have
948 --      lcl_id = e; exp_id = lcl_id
949 -- and lcl_id has useful IdInfo, we don't want to discard it by going
950 --      gbl_id = e; lcl_id = gbl_id
951 -- Instead, transfer IdInfo from lcl_id to exp_id
952 -- Overwriting, rather than merging, seems to work ok.
953 transferIdInfo exported_id local_id
954   = modifyIdInfo transfer exported_id
955   where
956     local_info = idInfo local_id
957     transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info
958                                  `setUnfoldingInfo`     unfoldingInfo local_info
959                                  `setInlinePragInfo`    inlinePragInfo local_info
960                                  `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
961     new_info = setSpecInfoHead (idName exported_id)
962                                (specInfo local_info)
963         -- Remember to set the function-name field of the
964         -- rules as we transfer them from one function to another
965 \end{code}