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