SimplCore.hs 44.1 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4
\section[SimplCore]{Driver for simplifying @Core@ programs}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

7 8
{-# LANGUAGE CPP #-}

9
module SimplCore ( core2core, simplifyExpr ) where
10 11 12

#include "HsVersions.h"

13 14
import GhcPrelude

15
import DynFlags
16
import CoreSyn
17
import HscTypes
18
import CSE              ( cseProgram )
19
import Rules            ( mkRuleBase, unionRuleBase,
20
                          extendRuleBaseList, ruleCheckProgram, addRuleInfo, )
21 22
import PprCore          ( pprCoreBindings, pprCoreExpr )
import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
23
import IdInfo
24 25
import CoreStats        ( coreBindsSize, coreBindsStats, exprSize )
import CoreUtils        ( mkTicks, stripTicksTop )
26
import CoreLint         ( endPass, lintPassResult, dumpPassResult,
Peter Wortmann's avatar
Peter Wortmann committed
27
                          lintAnnots )
28
import Simplify         ( simplTopBinds, simplExpr, simplRules )
29
import SimplUtils       ( simplEnvForGHCi, activeRule, activeUnfolding )
30
import SimplEnv
31
import SimplMonad
32
import CoreMonad
33 34 35
import qualified ErrUtils as Err
import FloatIn          ( floatInwards )
import FloatOut         ( floatOutwards )
36
import FamInstEnv
37
import Id
38
import ErrUtils         ( withTiming )
39
import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma )
40
import VarSet
41
import VarEnv
42 43 44 45
import LiberateCase     ( liberateCase )
import SAT              ( doStaticArgs )
import Specialise       ( specProgram)
import SpecConstr       ( specConstrProgram)
46
import DmdAnal          ( dmdAnalProgram )
47
import CallArity        ( callArityAnalProgram )
48
import Exitify          ( exitifyProgram )
49
import WorkWrap         ( wwTopBinds )
50
import Vectorise        ( vectorise )
51
import SrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
52
import Util
53
import Module
Matthew Pickering's avatar
Matthew Pickering committed
54 55
import Plugins          ( withPlugins,installCoreToDos )
import DynamicLoading  -- ( initializePlugins )
56

57
import Maybes
58
import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
59
import UniqFM
60
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
61
import Control.Monad
62
import qualified GHC.LanguageExtensions as LangExt
Austin Seipp's avatar
Austin Seipp committed
63 64 65
{-
************************************************************************
*                                                                      *
66
\subsection{The driver for the simplifier}
Austin Seipp's avatar
Austin Seipp committed
67 68 69
*                                                                      *
************************************************************************
-}
70

71
core2core :: HscEnv -> ModGuts -> IO ModGuts
72 73 74 75
core2core hsc_env guts@(ModGuts { mg_module  = mod
                                , mg_loc     = loc
                                , mg_deps    = deps
                                , mg_rdr_env = rdr_env })
76
  = do { us <- mkSplitUniqSupply 's'
77
       -- make sure all plugins are loaded
78 79

       ; let builtin_passes = getCoreToDo dflags
80
             orph_mods = mkModuleSet (mod : dep_orphs deps)
81
       ;
82
       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod
83
                                    orph_mods print_unqual loc $
Matthew Pickering's avatar
Matthew Pickering committed
84 85 86 87 88
                           do { hsc_env' <- getHscEnv
                              ; dflags' <- liftIO $ initializePlugins hsc_env'
                                                      (hsc_dflags hsc_env')
                              ; all_passes <- withPlugins dflags'
                                                installCoreToDos builtin_passes
89
                              ; runCorePasses all_passes guts }
90

91 92 93
       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
             "Grand total simplifier statistics"
             (pprSimplCount stats)
94

95 96 97
       ; return guts2 }
  where
    dflags         = hsc_dflags hsc_env
98
    home_pkg_rules = hptRules hsc_env (dep_mods deps)
99
    hpt_rule_base  = mkRuleBase home_pkg_rules
100
    print_unqual   = mkPrintUnqualified dflags rdr_env
101
    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
102 103 104 105
    -- This is very convienent for the users of the monad (e.g. plugins do not have to
    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
    -- would mean our cached value would go out of date.
106

Austin Seipp's avatar
Austin Seipp committed
107 108 109
{-
************************************************************************
*                                                                      *
110
           Generating the main optimisation pipeline
Austin Seipp's avatar
Austin Seipp committed
111 112 113
*                                                                      *
************************************************************************
-}
114 115 116

getCoreToDo :: DynFlags -> [CoreToDo]
getCoreToDo dflags
117
  = flatten_todos core_todo
118 119 120 121 122
  where
    opt_level     = optLevel           dflags
    phases        = simplPhases        dflags
    max_iter      = maxSimplIterations dflags
    rule_check    = ruleCheck          dflags
123
    call_arity    = gopt Opt_CallArity                    dflags
124
    exitification = gopt Opt_Exitification                dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
125 126 127 128 129 130 131
    strictness    = gopt Opt_Strictness                   dflags
    full_laziness = gopt Opt_FullLaziness                 dflags
    do_specialise = gopt Opt_Specialise                   dflags
    do_float_in   = gopt Opt_FloatIn                      dflags
    cse           = gopt Opt_CSE                          dflags
    spec_constr   = gopt Opt_SpecConstr                   dflags
    liberate_case = gopt Opt_LiberateCase                 dflags
132
    late_dmd_anal = gopt Opt_LateDmdAnal                  dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
133 134 135
    static_args   = gopt Opt_StaticArgumentTransformation dflags
    rules_on      = gopt Opt_EnableRewriteRules           dflags
    eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
136
    ww_on         = gopt Opt_WorkerWrapper                dflags
Simon Peyton Jones's avatar
Simon Peyton Jones committed
137
    vectorise_on  = gopt Opt_Vectorise                    dflags
138
    static_ptrs   = xopt LangExt.StaticPointers           dflags
139 140 141 142 143 144 145 146

    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)

    maybe_strictness_before phase
      = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness

    base_mode = SimplMode { sm_phase      = panic "base_mode"
                          , sm_names      = []
147
                          , sm_dflags     = dflags
148 149 150 151 152 153 154 155 156 157 158 159 160 161
                          , sm_rules      = rules_on
                          , sm_eta_expand = eta_expand_on
                          , sm_inline     = True
                          , sm_case_case  = True }

    simpl_phase phase names iter
      = CoreDoPasses
      $   [ maybe_strictness_before phase
          , CoreDoSimplify iter
                (base_mode { sm_phase = Phase phase
                           , sm_names = names })

          , maybe_rule_check (Phase phase) ]

162
          -- Vectorisation can introduce a fair few common sub expressions involving
163 164
          --  DPH primitives. For example, see the Reverse test from dph-examples.
          --  We need to eliminate these common sub expressions before their definitions
165
          --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings,
166
          --  so we also run simpl_gently to inline them.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
167
      ++  (if vectorise_on && phase == 3
168 169
            then [CoreCSE, simpl_gently]
            else [])
170 171

    vectorisation
Simon Peyton Jones's avatar
Simon Peyton Jones committed
172
      = runWhen vectorise_on $
173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194
          CoreDoPasses [ simpl_gently, CoreDoVectorisation ]

                -- By default, we have 2 phases before phase 0.

                -- Want to run with inline phase 2 after the specialiser to give
                -- maximum chance for fusion to work before we inline build/augment
                -- in phase 1.  This made a difference in 'ansi' where an
                -- overloaded function wasn't inlined till too late.

                -- Need phase 1 so that build/augment get
                -- inlined.  I found that spectral/hartel/genfft lost some useful
                -- strictness in the function sumcode' if augment is not inlined
                -- before strictness analysis runs
    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
                                | phase <- [phases, phases-1 .. 1] ]


        -- initial simplify: mk specialiser happy: minimum effort please
    simpl_gently = CoreDoSimplify max_iter
                       (base_mode { sm_phase = InitialPhase
                                  , sm_names = ["Gentle"]
                                  , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]
Simon Peyton Jones's avatar
Simon Peyton Jones committed
195 196
                                  , sm_inline = not vectorise_on
                                              -- See Note [Inline in InitialPhase]
197 198 199 200
                                  , sm_case_case = False })
                          -- Don't do case-of-case transformations.
                          -- This makes full laziness work better

201 202 203 204 205
    strictness_pass = if ww_on
                       then [CoreDoStrictness,CoreDoWorkerWrapper]
                       else [CoreDoStrictness]


206
    -- New demand analyser
207 208 209 210
    demand_analyser = (CoreDoPasses (
                           strictness_pass ++
                           [simpl_phase 0 ["post-worker-wrapper"] max_iter]
                           ))
211

212
    -- Static forms are moved to the top level with the FloatOut pass.
213
    -- See Note [Grand plan for static forms] in StaticPtrTable.
214
    static_ptrs_float_outwards =
lukemaurer's avatar
lukemaurer committed
215 216 217 218 219 220 221 222 223 224
      runWhen static_ptrs $ CoreDoPasses
        [ simpl_gently -- Float Out can't handle type lets (sometimes created
                       -- by simpleOptPgm via mkParallelBindings)
        , CoreDoFloatOutwards FloatOutSwitches
          { floatOutLambdas   = Just 0
          , floatOutConstants = True
          , floatOutOverSatApps = False
          , floatToTopLevelOnly = True
          }
        ]
225

226 227
    core_todo =
     if opt_level == 0 then
228
       [ vectorisation,
229
         static_ptrs_float_outwards,
230
         CoreDoSimplify max_iter
Simon Peyton Jones's avatar
Simon Peyton Jones committed
231
             (base_mode { sm_phase = Phase 0
232
                        , sm_names = ["Non-opt simplification"] })
Simon Peyton Jones's avatar
Simon Peyton Jones committed
233 234
       ]

235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
     else {- opt_level >= 1 -} [

    -- We want to do the static argument transform before full laziness as it
    -- may expose extra opportunities to float things outwards. However, to fix
    -- up the output of the transformation we need at do at least one simplify
    -- after this before anything else
        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),

        -- We run vectorisation here for now, but we might also try to run
        -- it later
        vectorisation,

        -- initial simplify: mk specialiser happy: minimum effort please
        simpl_gently,

        -- Specialisation is best done before full laziness
        -- so that overloaded functions have all their dictionary lambdas manifest
        runWhen do_specialise CoreDoSpecialising,

254
        if full_laziness then
255 256 257
           CoreDoFloatOutwards FloatOutSwitches {
                                 floatOutLambdas   = Just 0,
                                 floatOutConstants = True,
258
                                 floatOutOverSatApps = False,
259
                                 floatToTopLevelOnly = False }
260
                -- Was: gentleFloatOutSwitches
261
                --
262 263
                -- I have no idea why, but not floating constants to
                -- top level is very bad in some cases.
264
                --
265 266 267 268 269
                -- Notably: p_ident in spectral/rewrite
                --          Changing from "gentle" to "constantsOnly"
                --          improved rewrite's allocation by 19%, and
                --          made 0.0% difference to any other nofib
                --          benchmark
270
                --
271
                -- Not doing floatOutOverSatApps yet, we'll do
272 273 274 275 276
                -- that later on when we've had a chance to get more
                -- accurate arity information.  In fact it makes no
                -- difference at all to performance if we do it here,
                -- but maybe we save some unnecessary to-and-fro in
                -- the simplifier.
277 278
        else
           -- Even with full laziness turned off, we still need to float static
279 280
           -- forms to the top level. See Note [Grand plan for static forms] in
           -- StaticPtrTable.
281
           static_ptrs_float_outwards,
282

283
        simpl_phases,
284

285 286 287 288 289
                -- Phase 0: allow all Ids to be inlined now
                -- This gets foldr inlined before strictness analysis

                -- At least 3 iterations because otherwise we land up with
                -- huge dead expressions because of an infelicity in the
Gabor Greif's avatar
Gabor Greif committed
290
                -- simplifier.
291 292 293 294 295 296
                --      let k = BIG in foldr k z xs
                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
                -- Don't stop now!
        simpl_phase 0 ["main"] (max max_iter 3),

297 298 299 300 301 302 303
        runWhen do_float_in CoreDoFloatInwards,
            -- Run float-inwards immediately before the strictness analyser
            -- Doing so pushes bindings nearer their use site and hence makes
            -- them more likely to be strict. These bindings might only show
            -- up after the inlining from simplification.  Example in fulsom,
            -- Csg.calc, where an arg of timesDouble thereby becomes strict.

304 305 306 307 308
        runWhen call_arity $ CoreDoPasses
            [ CoreDoCallArity
            , simpl_phase 0 ["post-call-arity"] max_iter
            ],

309
        runWhen strictness demand_analyser,
310

311 312 313
        runWhen exitification CoreDoExitify,
            -- See note [Placement of the exitification pass]

314 315
        runWhen full_laziness $
           CoreDoFloatOutwards FloatOutSwitches {
316 317
                                 floatOutLambdas     = floatLamArgs dflags,
                                 floatOutConstants   = True,
318 319
                                 floatOutOverSatApps = True,
                                 floatToTopLevelOnly = False },
320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341
                -- nofib/spectral/hartel/wang doubles in speed if you
                -- do full laziness late in the day.  It only happens
                -- after fusion and other stuff, so the early pass doesn't
                -- catch it.  For the record, the redex is
                --        f_el22 (f_el21 r_midblock)


        runWhen cse CoreCSE,
                -- We want CSE to follow the final full-laziness pass, because it may
                -- succeed in commoning up things floated out by full laziness.
                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more

        runWhen do_float_in CoreDoFloatInwards,

        maybe_rule_check (Phase 0),

                -- Case-liberation for -O2.  This should be after
                -- strictness analysis and the simplification which follows it.
        runWhen liberate_case (CoreDoPasses [
            CoreLiberateCase,
            simpl_phase 0 ["post-liberate-case"] max_iter
            ]),         -- Run the simplifier after LiberateCase to vastly
Gabor Greif's avatar
Gabor Greif committed
342
                        -- reduce the possibility of shadowing
343
                        -- Reason: see Note [Shadowing] in SpecConstr.hs
344 345 346 347 348 349

        runWhen spec_constr CoreDoSpecConstr,

        maybe_rule_check (Phase 0),

        -- Final clean-up simplification:
350 351
        simpl_phase 0 ["final"] max_iter,

352 353 354 355
        runWhen late_dmd_anal $ CoreDoPasses (
            strictness_pass ++
            [simpl_phase 0 ["post-late-ww"] max_iter]
          ),
356

357 358 359
        -- Final run of the demand_analyser, ensures that one-shot thunks are
        -- really really one-shot thunks. Only needed if the demand analyser
        -- has run at all. See Note [Final Demand Analyser run] in DmdAnal
Simon Peyton Jones's avatar
Simon Peyton Jones committed
360 361
        -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution
        -- can become /exponentially/ more expensive. See Trac #11731, #12996.
362 363
        runWhen (strictness || late_dmd_anal) CoreDoStrictness,

364
        maybe_rule_check (Phase 0)
365 366
     ]

367 368 369 370 371 372 373
    -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.
    flatten_todos [] = []
    flatten_todos (CoreDoNothing : rest) = flatten_todos rest
    flatten_todos (CoreDoPasses passes : rest) =
      flatten_todos passes ++ flatten_todos rest
    flatten_todos (todo : rest) = todo : flatten_todos rest

Simon Peyton Jones's avatar
Simon Peyton Jones committed
374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402
{- Note [Inline in InitialPhase]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is
confusing for users because when they say INLINE they expect the function to inline
right away.

So now we do inlining immediately, even in the InitialPhase, assuming that the
Id's Activation allows it.

This is a surprisingly big deal. Compiler performance improved a lot
when I made this change:

   perf/compiler/T5837.run            T5837 [stat too good] (normal)
   perf/compiler/parsing001.run       parsing001 [stat too good] (normal)
   perf/compiler/T12234.run           T12234 [stat too good] (optasm)
   perf/compiler/T9020.run            T9020 [stat too good] (optasm)
   perf/compiler/T3064.run            T3064 [stat too good] (normal)
   perf/compiler/T9961.run            T9961 [stat too good] (normal)
   perf/compiler/T13056.run           T13056 [stat too good] (optasm)
   perf/compiler/T9872d.run           T9872d [stat too good] (normal)
   perf/compiler/T783.run             T783 [stat too good] (normal)
   perf/compiler/T12227.run           T12227 [stat too good] (normal)
   perf/should_run/lazy-bs-alloc.run  lazy-bs-alloc [stat too good] (normal)
   perf/compiler/T1969.run            T1969 [stat too good] (normal)
   perf/compiler/T9872a.run           T9872a [stat too good] (normal)
   perf/compiler/T9872c.run           T9872c [stat too good] (normal)
   perf/compiler/T9872b.run           T9872b [stat too good] (normal)
   perf/compiler/T9872d.run           T9872d [stat too good] (normal)

403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418
Note [RULEs enabled in SimplGently]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
RULES are enabled when doing "gentle" simplification.  Two reasons:

  * We really want the class-op cancellation to happen:
        op (df d1 d2) --> $cop3 d1 d2
    because this breaks the mutual recursion between 'op' and 'df'

  * I wanted the RULE
        lift String ===> ...
    to work in Template Haskell when simplifying
    splices, so we get simpler code for literal strings

But watch out: list fusion can prevent floating.  So use phase control
to switch off those rules until after floating.

Austin Seipp's avatar
Austin Seipp committed
419 420
************************************************************************
*                                                                      *
421
                  The CoreToDo interpreter
Austin Seipp's avatar
Austin Seipp committed
422 423 424
*                                                                      *
************************************************************************
-}
425 426

runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
427
runCorePasses passes guts
428 429 430
  = foldM do_pass guts passes
  where
    do_pass guts CoreDoNothing = return guts
431
    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
432
    do_pass guts pass
433 434 435 436
       = withTiming getDynFlags
                    (ppr pass <+> brackets (ppr mod))
                    (const ()) $ do
            { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
437
            ; endPass pass (mg_binds guts') (mg_rules guts')
438
            ; return guts' }
439

440 441
    mod = mg_module guts

Joachim Breitner's avatar
Joachim Breitner committed
442 443 444
doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
                                       simplifyPgm pass
445

Joachim Breitner's avatar
Joachim Breitner committed
446 447
doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}
                                       doPass cseProgram
448

Joachim Breitner's avatar
Joachim Breitner committed
449 450
doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
                                       doPassD liberateCase
451

Joachim Breitner's avatar
Joachim Breitner committed
452
doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
453
                                       floatInwards
454

Joachim Breitner's avatar
Joachim Breitner committed
455 456
doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
                                       doPassDUM (floatOutwards f)
457

Joachim Breitner's avatar
Joachim Breitner committed
458 459
doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
                                       doPassU doStaticArgs
460

461 462 463
doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}
                                       doPassD callArityAnalProgram

464 465 466
doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}
                                       doPass exitifyProgram

Joachim Breitner's avatar
Joachim Breitner committed
467 468
doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}
                                       doPassDFM dmdAnalProgram
469

Joachim Breitner's avatar
Joachim Breitner committed
470 471
doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
                                       doPassDFU wwTopBinds
472

Joachim Breitner's avatar
Joachim Breitner committed
473 474
doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
                                       specProgram
475

Joachim Breitner's avatar
Joachim Breitner committed
476 477
doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                       specConstrProgram
478

Joachim Breitner's avatar
Joachim Breitner committed
479 480
doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
                                       vectorise
481

Joachim Breitner's avatar
Joachim Breitner committed
482 483 484 485
doCorePass CoreDoPrintCore              = observe   printCore
doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
doCorePass CoreDoNothing                = return
doCorePass (CoreDoPasses passes)        = runCorePasses passes
486

Ben Gamari's avatar
Ben Gamari committed
487
#if defined(GHCI)
Joachim Breitner's avatar
Joachim Breitner committed
488
doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
489 490
#endif

Joachim Breitner's avatar
Joachim Breitner committed
491
doCorePass pass = pprPanic "doCorePass" (ppr pass)
492

Austin Seipp's avatar
Austin Seipp committed
493 494 495
{-
************************************************************************
*                                                                      *
496
\subsection{Core pass combinators}
Austin Seipp's avatar
Austin Seipp committed
497 498 499
*                                                                      *
************************************************************************
-}
500

501 502 503
printCore :: DynFlags -> CoreProgram -> IO ()
printCore dflags binds
    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
504

505
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
506 507 508 509 510 511 512
ruleCheckPass current_phase pat guts =
    withTiming getDynFlags
               (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
               (const ()) $ do
    { rb <- getRuleBase
    ; dflags <- getDynFlags
    ; vis_orphs <- getVisibleOrphanMods
Ben Gamari's avatar
Ben Gamari committed
513
    ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
Sylvain Henry's avatar
Sylvain Henry committed
514
                   (defaultDumpStyle dflags)
515 516 517
                   (ruleCheckProgram current_phase pat
                      (RuleEnv rb vis_orphs) (mg_binds guts))
    ; return guts }
518

519
doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
520 521 522 523 524
doPassDUM do_pass = doPassM $ \binds -> do
    dflags <- getDynFlags
    us     <- getUniqueSupplyM
    liftIO $ do_pass dflags us binds

525
doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
526 527
doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))

528
doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
529 530
doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)

531
doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
532 533
doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)

534
doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
535 536
doPassU do_pass = doPassDU (const do_pass)

537 538 539 540 541 542 543 544 545 546 547 548 549 550 551
doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDFM do_pass guts = do
    dflags <- getDynFlags
    p_fam_env <- getPackageFamInstEnv
    let fam_envs = (p_fam_env, mg_fam_inst_env guts)
    doPassM (liftIO . do_pass dflags fam_envs) guts

doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
doPassDFU do_pass guts = do
    dflags <- getDynFlags
    us     <- getUniqueSupplyM
    p_fam_env <- getPackageFamInstEnv
    let fam_envs = (p_fam_env, mg_fam_inst_env guts)
    doPass (do_pass dflags fam_envs us) guts

552 553
-- Most passes return no stats and don't change rules: these combinators
-- let us lift them to the full blown ModGuts+CoreM world
554
doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
555 556 557 558
doPassM bind_f guts = do
    binds' <- bind_f (mg_binds guts)
    return (guts { mg_binds = binds' })

559
doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
560
doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
561 562

-- Observer passes just peek; don't modify the bindings at all
563
observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
564 565
observe do_pass = doPassM $ \binds -> do
    dflags <- getDynFlags
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
566
    _ <- liftIO $ do_pass dflags binds
567
    return binds
568

Austin Seipp's avatar
Austin Seipp committed
569 570 571
{-
************************************************************************
*                                                                      *
572
        Gentle simplification
Austin Seipp's avatar
Austin Seipp committed
573 574 575
*                                                                      *
************************************************************************
-}
576

577
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
578 579
             -> CoreExpr
             -> IO CoreExpr
580 581 582 583 584
-- simplifyExpr is called by the driver to simplify an
-- expression typed in at the interactive prompt
--
-- Also used by Template Haskell
simplifyExpr dflags expr
585 586
  = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $
    do  {
587
        ; us <-  mkSplitUniqSupply 's'
588

589
        ; let sz = exprSize expr
pcapriotti's avatar
pcapriotti committed
590

591 592 593
        ; (expr', counts) <- initSmpl dflags emptyRuleEnv
                               emptyFamInstEnvs us sz
                               (simplExprGently (simplEnvForGHCi dflags) expr)
594

595
        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
596
                  "Simplifier statistics" (pprSimplCount counts)
597

598 599
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
                        (pprCoreExpr expr')
600

601 602
        ; return expr'
        }
603

604
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
605 606 607 608
-- Simplifies an expression
--      does occurrence analysis, then simplification
--      and repeats (twice currently) because one pass
--      alone leaves tons of crud.
609
-- Used (a) for user expressions typed in at the interactive prompt
610 611
--      (b) the LHS and RHS of a RULE
--      (c) Template Haskell splices
612
--
613
-- The name 'Gently' suggests that the SimplMode is SimplGently,
614 615 616
-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
-- enforce that; it just simplifies the expression twice

617 618 619 620 621
-- It's important that simplExprGently does eta reduction; see
-- Note [Simplifying the left-hand side of a RULE] above.  The
-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
-- but only if -O is on.

622 623
simplExprGently env expr = do
    expr1 <- simplExpr env (occurAnalyseExpr expr)
624
    simplExpr env (occurAnalyseExpr expr1)
625

Austin Seipp's avatar
Austin Seipp committed
626 627 628
{-
************************************************************************
*                                                                      *
629
\subsection{The driver for the simplifier}
Austin Seipp's avatar
Austin Seipp committed
630 631 632
*                                                                      *
************************************************************************
-}
633

634 635 636
simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm pass guts
  = do { hsc_env <- getHscEnv
637 638
       ; us <- getUniqueSupplyM
       ; rb <- getRuleBase
639 640
       ; liftIOWithCount $
         simplifyPgmIO pass hsc_env us rb guts }
641

642
simplifyPgmIO :: CoreToDo
643 644 645 646 647
              -> HscEnv
              -> UniqSupply
              -> RuleBase
              -> ModGuts
              -> IO (SimplCount, ModGuts)  -- New bindings
648

649
simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
650
              hsc_env us hpt_rule_base
651
              guts@(ModGuts { mg_module = this_mod
652
                            , mg_rdr_env = rdr_env
653
                            , mg_deps = deps
654
                            , mg_binds = binds, mg_rules = rules
655
                            , mg_fam_inst_env = fam_inst_env })
656 657
  = do { (termination_msg, it_count, counts_out, guts')
           <- do_iteration us 1 [] binds rules
658

Jan Stolarek's avatar
Jan Stolarek committed
659 660
        ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&
                                dopt Opt_D_dump_simpl_stats  dflags)
661
                  "Simplifier statistics for following pass"
Jan Stolarek's avatar
Jan Stolarek committed
662 663
                  (vcat [text termination_msg <+> text "after" <+> ppr it_count
                                              <+> text "iterations",
664 665
                         blankLine,
                         pprSimplCount counts_out])
666

667
        ; return (counts_out, guts')
668 669
    }
  where
670 671 672
    dflags       = hsc_dflags hsc_env
    print_unqual = mkPrintUnqualified dflags rdr_env
    simpl_env    = mkSimplEnv mode
673 674
    active_rule  = activeRule mode
    active_unf   = activeUnfolding mode
675

676
    do_iteration :: UniqSupply
677 678 679 680 681
                 -> Int          -- Counts iterations
                 -> [SimplCount] -- Counts from earlier iterations, reversed
                 -> CoreProgram  -- Bindings in
                 -> [CoreRule]   -- and orphan rules
                 -> IO (String, Int, SimplCount, ModGuts)
682

683
    do_iteration us iteration_no counts_so_far binds rules
684 685 686
        -- iteration_no is the number of the iteration we are
        -- about to begin, with '1' for the first
      | iteration_no > max_iterations   -- Stop if we've run out of iterations
687
      = WARN( debugIsOn && (max_iterations > 2)
688 689
            , hang (text "Simplifier bailing out after" <+> int max_iterations
                    <+> text "iterations"
690 691
                    <+> (brackets $ hsep $ punctuate comma $
                         map (int . simplCountN) (reverse counts_so_far)))
692
                 2 (text "Size =" <+> ppr (coreBindsStats binds)))
693

694 695 696
                -- Subtract 1 from iteration_no to get the
                -- number of iterations we actually completed
        return ( "Simplifier baled out", iteration_no - 1
697 698
               , totalise counts_so_far
               , guts { mg_binds = binds, mg_rules = rules } )
699

700 701
      -- Try and force thunks off the binds; significantly reduces
      -- space usage, especially with -O.  JRS, 000620.
702
      | let sz = coreBindsSize binds
703
      , () <- sz `seq` ()     -- Force it
704
      = do {
705
                -- Occurrence analysis
Gabor Greif's avatar
Gabor Greif committed
706
           let {   -- Note [Vectorisation declarations and occurrences]
707 708
                   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                   -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure
709
                   -- that the right-hand sides of vectorisation declarations are taken into
710 711 712 713
                   -- account during occurrence analysis. After the 'InitialPhase', we need to ensure
                   -- that the binders representing variable vectorisation declarations are kept alive.
                   -- (In contrast to automatically vectorised variables, their unvectorised versions
                   -- don't depend on them.)
714
                 vectVars = mkVarSet $
niteria's avatar
niteria committed
715
                              catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr
716
                                        | Vect bndr _ <- mg_vect_decls guts]
717
                              ++
niteria's avatar
niteria committed
718
                              catMaybes [ fmap snd $ lookupDVarEnv (vectInfoVar (mg_vect_info guts)) bndr
719 720 721 722
                                        | bndr <- bindersOfBinds binds]
                                        -- FIXME: This second comprehensions is only needed as long as we
                                        --        have vectorised bindings where we get "Could NOT call
                                        --        vectorised from original version".
723
              ;  (maybeVects, maybeVectVars)
724 725 726
                   = case sm_phase mode of
                       InitialPhase -> (mg_vect_decls guts, vectVars)
                       _            -> ([], vectVars)
727
               ; tagged_binds = {-# SCC "OccAnal" #-}
728
                     occurAnalysePgm this_mod active_unf active_rule rules
729
                                     maybeVects maybeVectVars binds
730 731 732
               } ;
           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                     (pprCoreBindings tagged_binds);
733

734
                -- Get any new rules, and extend the rule base
735
                -- See Note [Overall plumbing for rules] in Rules.hs
736 737 738 739 740 741 742
                -- We need to do this regularly, because simplification can
                -- poke on IdInfo thunks, which in turn brings in new rules
                -- behind the scenes.  Otherwise there's a danger we'll simply
                -- miss the rules for Ids hidden inside imported inlinings
           eps <- hscEPS hsc_env ;
           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
                ; rule_base2 = extendRuleBaseList rule_base1 rules
743 744
                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)
                ; vis_orphs = this_mod : dep_orphs deps } ;
745 746

                -- Simplify the program
747 748
           ((binds1, rules1), counts1) <-
             initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $
749 750
               do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}
                                      simplTopBinds simpl_env tagged_binds
751 752 753 754 755

                      -- Apply the substitution to rules defined in this module
                      -- for imported Ids.  Eg  RULE map my_f = blah
                      -- If we have a substitution my_f :-> other_f, we'd better
                      -- apply it to the rule to, or it'll never match
756
                  ; rules1 <- simplRules env1 Nothing rules
757

758
                  ; return (getTopFloatBinds floats, rules1) } ;
759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776

                -- Stop if nothing happened; don't dump output
           if isZeroSimplCount counts1 then
                return ( "Simplifier reached fixed point", iteration_no
                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks
                       , guts { mg_binds = binds1, mg_rules = rules1 } )
           else do {
                -- Short out indirections
                -- We do this *after* at least one run of the simplifier
                -- because indirection-shorting uses the export flag on *occurrences*
                -- and that isn't guaranteed to be ok until after the first run propagates
                -- stuff from the binding site to its occurrences
                --
                -- ToDo: alas, this means that indirection-shorting does not happen at all
                --       if the simplifier does nothing (not common, I know, but unsavoury)
           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;

                -- Dump the result of this iteration
777
           dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;
778
           lintPassResult hsc_env pass binds2 ;
779 780 781

                -- Loop
           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
pcapriotti's avatar
pcapriotti committed
782
           } }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
783
      | otherwise = panic "do_iteration"
784
      where
785
        (us1, us2) = splitUniqSupply us
786

787
        -- Remember the counts_so_far are reversed
788
        totalise :: [SimplCount] -> SimplCount
789 790
        totalise = foldr (\c acc -> acc `plusSimplCount` c)
                         (zeroSimplCount dflags)
791

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
792 793
simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"

794
-------------------
795 796 797 798
dump_end_iteration :: DynFlags -> PrintUnqualified -> Int
                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
dump_end_iteration dflags print_unqual iteration_no counts binds rules
  = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules
799
  where
Jan Stolarek's avatar
Jan Stolarek committed
800
    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations
801 802
            | otherwise                               = Nothing
            -- Show details if Opt_D_dump_simpl_iterations is on
803

804 805
    hdr = text "Simplifier iteration=" <> int iteration_no
    pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr
806
                     , pprSimplCount counts
807
                     , text "---- End of simplifier counts for" <+> hdr ]
808

Austin Seipp's avatar
Austin Seipp committed
809 810 811
{-
************************************************************************
*                                                                      *
812
                Shorting out indirections
Austin Seipp's avatar
Austin Seipp committed
813 814
*                                                                      *
************************************************************************
815

816
If we have this:
817

818 819 820
        x_local = <expression>
        ...bindings...
        x_exported = x_local
821 822 823

where x_exported is exported, and x_local is not, then we replace it with this:

824 825 826
        x_exported = <expression>
        x_local = x_exported
        ...bindings...
827 828 829 830 831 832

Without this we never get rid of the x_exported = x_local thing.  This
save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
makes strictness information propagate better.  This used to happen in
the final phase, but it's tidier to do it here.

833 834 835 836
Note [Transferring IdInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to propagage any useful IdInfo on x_local to x_exported.

837 838 839 840 841 842
STRICTNESS: if we have done strictness analysis, we want the strictness info on
x_local to transfer to x_exported.  Hence the copyIdInfo call.

RULES: we want to *add* any RULES for x_local to x_exported.


simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
843
Note [Messing up the exported Id's RULES]
844
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
845 846 847
We must be careful about discarding (obviously) or even merging the
RULES on the exported Id. The example that went bad on me at one stage
was this one:
848

849
    iterate :: (a -> a) -> a -> [a]
850 851 852
        [Exported]
    iterate = iterateList

853 854
    iterateFB c f x = x `c` iterateFB c f (f x)
    iterateList f x =  x : iterateList f (f x)
855 856
        [Not exported]

857
    {-# RULES