SimplCore.lhs 36.8 KB
Newer Older
1 2 3 4 5 6
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[SimplCore]{Driver for simplifying @Core@ programs}

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
7 8 9 10 11 12 13
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

14
module SimplCore ( core2core, simplifyExpr ) where
15 16 17

#include "HsVersions.h"

18
import DynFlags
19
import CoreSyn
20
import CoreSubst
21
import HscTypes
22 23 24 25 26
import CSE              ( cseProgram )
import Rules            ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
                          extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
import PprCore          ( pprCoreBindings, pprCoreExpr )
import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
27
import IdInfo
28
import CoreUtils        ( coreBindsSize, coreBindsStats, exprSize )
29 30
import Simplify         ( simplTopBinds, simplExpr )
import SimplUtils       ( simplEnvForGHCi, activeRule )
31
import SimplEnv
32
import SimplMonad
33
import CoreMonad
34 35 36
import qualified ErrUtils as Err
import FloatIn          ( floatInwards )
import FloatOut         ( floatOutwards )
37
import FamInstEnv
38
import Id
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 WorkWrap         ( wwTopBinds )
48
import Vectorise        ( vectorise )
49
import FastString
50
import SrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
51
import Util
52

53
import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
54
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
55
import Control.Monad
56 57

#ifdef GHCI
58 59 60 61
import Type             ( mkTyConTy )
import RdrName          ( mkRdrQual )
import OccName          ( mkVarOcc )
import PrelNames        ( pluginTyConName )
62
import DynamicLoading   ( forceLoadTyCon, lookupRdrNameInModule, getValueSafely )
63
import Module           ( ModuleName )
64 65
import Panic
#endif
66 67 68
\end{code}

%************************************************************************
69
%*                                                                      *
70
\subsection{The driver for the simplifier}
71
%*                                                                      *
72 73 74
%************************************************************************

\begin{code}
75
core2core :: HscEnv -> ModGuts -> IO ModGuts
76
core2core hsc_env guts
77
  = do { us <- mkSplitUniqSupply 's'
78
       -- make sure all plugins are loaded
79 80

       ; let builtin_passes = getCoreToDo dflags
81
       ;
82 83 84
       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $
                        do { all_passes <- addPluginPasses dflags builtin_passes
                           ; runCorePasses all_passes guts }
85

86
{--
87 88 89
       ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline
             "Plugin information" "" -- TODO FIXME: dump plugin info
--}
90 91 92
       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
             "Grand total simplifier statistics"
             (pprSimplCount stats)
93

94 95 96 97 98 99 100
       ; return guts2 }
  where
    dflags         = hsc_dflags hsc_env
    home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
    hpt_rule_base  = mkRuleBase home_pkg_rules
    mod            = mg_module guts
    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
101 102 103 104
    -- 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.
105 106 107 108
\end{code}


%************************************************************************
109
%*                                                                      *
110
           Generating the main optimisation pipeline
111
%*                                                                      *
112 113 114 115 116 117 118 119 120 121 122
%************************************************************************

\begin{code}
getCoreToDo :: DynFlags -> [CoreToDo]
getCoreToDo dflags
  = core_todo
  where
    opt_level     = optLevel           dflags
    phases        = simplPhases        dflags
    max_iter      = maxSimplIterations dflags
    rule_check    = ruleCheck          dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
123 124 125 126 127 128 129 130 131 132
    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
    static_args   = gopt Opt_StaticArgumentTransformation dflags
    rules_on      = gopt Opt_EnableRewriteRules           dflags
    eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154

    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      = []
                          , 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) ]

155
          -- Vectorisation can introduce a fair few common sub expressions involving
156 157
          --  DPH primitives. For example, see the Reverse test from dph-examples.
          --  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.
ian@well-typed.com's avatar
ian@well-typed.com committed
160
      ++  (if gopt Opt_Vectorise dflags && phase == 3
161 162
            then [CoreCSE, simpl_gently]
            else [])
163 164

    vectorisation
ian@well-typed.com's avatar
ian@well-typed.com committed
165
      = runWhen (gopt Opt_Vectorise dflags) $
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192
          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]
                                  , sm_inline = False
                                  , sm_case_case = False })
                          -- Don't do case-of-case transformations.
                          -- This makes full laziness work better

193 194 195 196 197 198 199
    -- New demand analyser
    demand_analyser = (CoreDoPasses ([
                           CoreDoStrictness,
                           CoreDoWorkerWrapper,
                           simpl_phase 0 ["post-worker-wrapper"] max_iter
                           ]))

200 201
    core_todo =
     if opt_level == 0 then
Simon Peyton Jones's avatar
Simon Peyton Jones committed
202 203 204 205 206 207
       [ vectorisation
       , CoreDoSimplify max_iter
             (base_mode { sm_phase = Phase 0
                        , sm_names = ["Non-opt simplification"] }) 
       ]

208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231
     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,

        runWhen full_laziness $
           CoreDoFloatOutwards FloatOutSwitches {
                                 floatOutLambdas   = Just 0,
                                 floatOutConstants = True,
                                 floatOutPartialApplications = False },
232
                -- Was: gentleFloatOutSwitches
233
                --
234 235
                -- I have no idea why, but not floating constants to
                -- top level is very bad in some cases.
236
                --
237 238 239 240 241
                -- 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
242 243 244 245 246 247 248
                --
                -- Not doing floatOutPartialApplications yet, we'll do
                -- 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.
249

250
        runWhen do_float_in CoreDoFloatInwards,
251

252
        simpl_phases,
253

254 255 256 257 258 259 260 261 262 263 264 265
                -- 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
                -- simpifier.
                --      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),

266
        runWhen strictness demand_analyser,
267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314

        runWhen full_laziness $
           CoreDoFloatOutwards FloatOutSwitches {
                                 floatOutLambdas   = floatLamArgs dflags,
                                 floatOutConstants = True,
                                 floatOutPartialApplications = True },
                -- 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
                        -- reduce the possiblility of shadowing
                        -- Reason: see Note [Shadowing] in SpecConstr.lhs

        runWhen spec_constr CoreDoSpecConstr,

        maybe_rule_check (Phase 0),

        -- Final clean-up simplification:
        simpl_phase 0 ["final"] max_iter
     ]
\end{code}

Loading plugins

\begin{code}
addPluginPasses :: DynFlags -> [CoreToDo] -> CoreM [CoreToDo]
#ifndef GHCI
addPluginPasses _ builtin_passes = return builtin_passes
#else
addPluginPasses dflags builtin_passes
315
  = do { hsc_env <- getHscEnv
316 317 318
       ; named_plugins <- liftIO (loadPlugins hsc_env)
       ; foldM query_plug builtin_passes named_plugins }
  where
319
    query_plug todos (mod_nm, plug)
320
       = installCoreToDos plug options todos
321
       where
322 323 324 325 326 327 328 329 330 331 332 333
         options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
                            , opt_mod_nm == mod_nm ]

loadPlugins :: HscEnv -> IO [(ModuleName, Plugin)]
loadPlugins hsc_env
  = do { let to_load = pluginModNames (hsc_dflags hsc_env)
       ; plugins <- mapM (loadPlugin hsc_env) to_load
       ; return $ to_load `zip` plugins }

loadPlugin :: HscEnv -> ModuleName -> IO Plugin
loadPlugin hsc_env mod_name
  = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin")
Ian Lynagh's avatar
Ian Lynagh committed
334
             dflags = hsc_dflags hsc_env
335 336
       ; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name
       ; case mb_name of {
Ian Lynagh's avatar
Ian Lynagh committed
337
            Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep
338 339 340
                          [ ptext (sLit "The module"), ppr mod_name
                          , ptext (sLit "did not export the plugin name")
                          , ppr plugin_rdr_name ]) ;
341
            Just name ->
342 343 344 345

     do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName
        ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
        ; case mb_plugin of
Ian Lynagh's avatar
Ian Lynagh committed
346
            Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep
347
                          [ ptext (sLit "The value"), ppr name
348 349 350 351 352 353 354
                          , ptext (sLit "did not have the type")
                          , ppr pluginTyConName, ptext (sLit "as required")])
            Just plugin -> return plugin } } }
#endif
\end{code}

%************************************************************************
355
%*                                                                      *
356
                  The CoreToDo interpreter
357
%*                                                                      *
358 359 360 361
%************************************************************************

\begin{code}
runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
362
runCorePasses passes guts
363 364 365
  = foldM do_pass guts passes
  where
    do_pass guts CoreDoNothing = return guts
366
    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
367
    do_pass guts pass
368
       = do { dflags <- getDynFlags
369
            ; liftIO $ showPass dflags pass
370
            ; guts' <- doCorePass dflags pass guts
371 372
            ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
            ; return guts' }
373

374 375 376
doCorePass :: DynFlags -> CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass _      pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
                                              simplifyPgm pass
377

378 379
doCorePass _      CoreCSE                   = {-# SCC "CommonSubExpr" #-}
                                              doPass cseProgram
380

381 382
doCorePass _      CoreLiberateCase          = {-# SCC "LiberateCase" #-}
                                              doPassD liberateCase
383

384 385
doCorePass dflags CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
                                              doPass (floatInwards dflags)
386

387 388
doCorePass _      (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
                                              doPassDUM (floatOutwards f)
389

390 391
doCorePass _      CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
                                              doPassU doStaticArgs
392

393 394
doCorePass _      CoreDoStrictness          = {-# SCC "NewStranal" #-}
                                              doPassDM dmdAnalProgram
395

396 397
doCorePass dflags CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
                                              doPassU (wwTopBinds dflags)
398

399 400
doCorePass dflags CoreDoSpecialising        = {-# SCC "Specialise" #-}
                                              specProgram dflags
401

402 403
doCorePass _      CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                              specConstrProgram
404

405 406
doCorePass _      CoreDoVectorisation       = {-# SCC "Vectorise" #-}
                                              vectorise
407

408 409 410 411
doCorePass _      CoreDoPrintCore              = observe   printCore
doCorePass _      (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
doCorePass _      CoreDoNothing                = return
doCorePass _      (CoreDoPasses passes)        = runCorePasses passes
412 413

#ifdef GHCI
414
doCorePass _      (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
415 416
#endif

417
doCorePass _      pass = pprPanic "doCorePass" (ppr pass)
418 419 420
\end{code}

%************************************************************************
421
%*                                                                      *
422
\subsection{Core pass combinators}
423
%*                                                                      *
424 425 426
%************************************************************************

\begin{code}
427 428 429
printCore :: DynFlags -> CoreProgram -> IO ()
printCore dflags binds
    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
430

431 432
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass current_phase pat guts = do
433 434 435
    rb <- getRuleBase
    dflags <- getDynFlags
    liftIO $ Err.showPass dflags "RuleCheck"
Ian Lynagh's avatar
Ian Lynagh committed
436
    liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
437
                 (ruleCheckProgram current_phase pat rb (mg_binds guts))
438 439 440
    return guts


441
doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
442 443 444 445 446
doPassDUM do_pass = doPassM $ \binds -> do
    dflags <- getDynFlags
    us     <- getUniqueSupplyM
    liftIO $ do_pass dflags us binds

447
doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
448 449
doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))

450
doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
451 452
doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)

453
doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
454 455
doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)

456
doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
457 458 459 460
doPassU do_pass = doPassDU (const do_pass)

-- Most passes return no stats and don't change rules: these combinators
-- let us lift them to the full blown ModGuts+CoreM world
461
doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
462 463 464 465
doPassM bind_f guts = do
    binds' <- bind_f (mg_binds guts)
    return (guts { mg_binds = binds' })

466
doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
467
doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
468 469

-- Observer passes just peek; don't modify the bindings at all
470
observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
471 472
observe do_pass = doPassM $ \binds -> do
    dflags <- getDynFlags
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
473
    _ <- liftIO $ do_pass dflags binds
474
    return binds
475 476 477 478
\end{code}


%************************************************************************
479 480 481
%*                                                                      *
        Gentle simplification
%*                                                                      *
482 483 484
%************************************************************************

\begin{code}
485
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
486 487
             -> CoreExpr
             -> IO CoreExpr
488 489 490 491 492
-- simplifyExpr is called by the driver to simplify an
-- expression typed in at the interactive prompt
--
-- Also used by Template Haskell
simplifyExpr dflags expr
493 494
  = do  {
        ; Err.showPass dflags "Simplify"
495

496
        ; us <-  mkSplitUniqSupply 's'
497

498
	; let sz = exprSize expr
pcapriotti's avatar
pcapriotti committed
499 500

        ; (expr', counts) <- initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
501
				 simplExprGently (simplEnvForGHCi dflags) expr
502

503
        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
504
                  "Simplifier statistics" (pprSimplCount counts)
505 506 507

	; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
			(pprCoreExpr expr')
508

509 510
        ; return expr'
        }
511

512
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
513 514 515 516
-- Simplifies an expression
--      does occurrence analysis, then simplification
--      and repeats (twice currently) because one pass
--      alone leaves tons of crud.
517
-- Used (a) for user expressions typed in at the interactive prompt
518 519
--      (b) the LHS and RHS of a RULE
--      (c) Template Haskell splices
520 521 522 523 524
--
-- The name 'Gently' suggests that the SimplifierMode is SimplGently,
-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
-- enforce that; it just simplifies the expression twice

525 526 527 528 529
-- 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.

530 531
simplExprGently env expr = do
    expr1 <- simplExpr env (occurAnalyseExpr expr)
532
    simplExpr env (occurAnalyseExpr expr1)
533 534
\end{code}

535

536
%************************************************************************
537
%*                                                                      *
538
\subsection{The driver for the simplifier}
539
%*                                                                      *
540 541 542
%************************************************************************

\begin{code}
543 544 545
simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm pass guts
  = do { hsc_env <- getHscEnv
546 547
       ; us <- getUniqueSupplyM
       ; rb <- getRuleBase
548 549
       ; liftIOWithCount $
         simplifyPgmIO pass hsc_env us rb guts }
550

551
simplifyPgmIO :: CoreToDo
552 553 554 555 556
              -> HscEnv
              -> UniqSupply
              -> RuleBase
              -> ModGuts
              -> IO (SimplCount, ModGuts)  -- New bindings
557

558
simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
559
              hsc_env us hpt_rule_base
560 561
              guts@(ModGuts { mg_module = this_mod
                            , mg_binds = binds, mg_rules = rules
562
                            , mg_fam_inst_env = fam_inst_env })
563 564
  = do { (termination_msg, it_count, counts_out, guts')
           <- do_iteration us 1 [] binds rules
565

566
        ; Err.dumpIfSet dflags (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
567 568 569 570
                  "Simplifier statistics for following pass"
                  (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
                         blankLine,
                         pprSimplCount counts_out])
571

572
        ; return (counts_out, guts')
573 574
    }
  where
575 576 577
    dflags      = hsc_dflags hsc_env
    dump_phase  = dumpSimplPhase dflags mode
    simpl_env   = mkSimplEnv mode
578
    active_rule = activeRule simpl_env
579

580
    do_iteration :: UniqSupply
581 582 583 584 585
                 -> Int          -- Counts iterations
                 -> [SimplCount] -- Counts from earlier iterations, reversed
                 -> CoreProgram  -- Bindings in
                 -> [CoreRule]   -- and orphan rules
                 -> IO (String, Int, SimplCount, ModGuts)
586

587
    do_iteration us iteration_no counts_so_far binds rules
588 589 590
        -- 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
591
      = WARN( debugIsOn && (max_iterations > 2)
592
            , hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations
593 594 595 596
                    <+> ptext (sLit "iterations")
                    <+> (brackets $ hsep $ punctuate comma $
                         map (int . simplCountN) (reverse counts_so_far)))
                 2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds)))
597

598 599 600
                -- Subtract 1 from iteration_no to get the
                -- number of iterations we actually completed
        return ( "Simplifier baled out", iteration_no - 1
601 602
               , totalise counts_so_far
               , guts { mg_binds = binds, mg_rules = rules } )
603

604 605
      -- Try and force thunks off the binds; significantly reduces
      -- space usage, especially with -O.  JRS, 000620.
606
      | let sz = coreBindsSize binds
607
      , sz == sz     -- Force it
608
      = do {
609 610
                -- Occurrence analysis
           let {   -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure
611
                   -- that the right-hand sides of vectorisation declarations are taken into
612 613 614 615
                   -- account during occurence analysis.
                 maybeVects   = case sm_phase mode of
                                  InitialPhase -> mg_vect_decls guts
                                  _            -> []
616 617
               ; tagged_binds = {-# SCC "OccAnal" #-}
                     occurAnalysePgm this_mod active_rule rules maybeVects binds
618 619 620
               } ;
           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                     (pprCoreBindings tagged_binds);
621

622 623 624 625 626 627 628 629 630 631 632 633 634 635
                -- Get any new rules, and extend the rule base
                -- See Note [Overall plumbing for rules] in Rules.lhs
                -- 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
                ; simpl_binds = {-# SCC "SimplTopBinds" #-}
                                simplTopBinds simpl_env tagged_binds
                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;

                -- Simplify the program
pcapriotti's avatar
pcapriotti committed
636
           (env1, counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz simpl_binds ;
637

638
           let  { binds1 = getFloatBinds env1
639
                ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662
                } ;

                -- 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
           end_iteration dflags pass iteration_no counts1 binds2 rules1 ;

                -- Loop
           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
pcapriotti's avatar
pcapriotti committed
663
           } }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
664
      | otherwise = panic "do_iteration"
665
      where
666
        (us1, us2) = splitUniqSupply us
667

668
        -- Remember the counts_so_far are reversed
669
        totalise :: [SimplCount] -> SimplCount
670 671
        totalise = foldr (\c acc -> acc `plusSimplCount` c)
                         (zeroSimplCount dflags)
672

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
673 674
simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"

675
-------------------
676
end_iteration :: DynFlags -> CoreToDo -> Int
677
             -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
678
end_iteration dflags pass iteration_no counts binds rules
679 680 681
  = do { dumpPassResult dflags mb_flag hdr pp_counts binds rules
       ; lintPassResult dflags pass binds }
  where
682
    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases
683 684
            | otherwise                               = Nothing
            -- Show details if Opt_D_dump_simpl_iterations is on
685 686 687

    hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no
    pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr
688
                     , pprSimplCount counts
689
                     , ptext (sLit "---- End of simplifier counts for") <+> hdr ]
690
\end{code}
691 692 693


%************************************************************************
694 695 696
%*                                                                      *
                Shorting out indirections
%*                                                                      *
697 698
%************************************************************************

699
If we have this:
700

701 702 703
        x_local = <expression>
        ...bindings...
        x_exported = x_local
704 705 706

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

707 708 709
        x_exported = <expression>
        x_local = x_exported
        ...bindings...
710 711 712 713 714 715

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.

716 717 718 719
Note [Transferring IdInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~
We want to propagage any useful IdInfo on x_local to x_exported.

720 721 722 723 724 725
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
726
Note [Messing up the exported Id's RULES]
727
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
728 729 730
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:
731

732
    iterate :: (a -> a) -> a -> [a]
733 734 735
        [Exported]
    iterate = iterateList

736 737
    iterateFB c f x = x `c` iterateFB c f (f x)
    iterateList f x =  x : iterateList f (f x)
738 739
        [Not exported]

740
    {-# RULES
741 742
    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
    "iterateFB"                 iterateFB (:) = iterateList
743 744 745 746 747 748
     #-}

This got shorted out to:

    iterateList :: (a -> a) -> a -> [a]
    iterateList = iterate
749

750 751
    iterateFB c f x = x `c` iterateFB c f (f x)
    iterate f x =  x : iterate f (f x)
752

753
    {-# RULES
754 755
    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
    "iterateFB"                 iterateFB (:) = iterate
756 757
     #-}

758 759 760 761
And now we get an infinite loop in the rule system
        iterate f x -> build (\cn -> iterateFB c f x)
                    -> iterateFB (:) f x
                    -> iterate f x
762

763 764 765
Old "solution":
        use rule switching-off pragmas to get rid
        of iterateList in the first place
766

767 768 769 770 771 772 773 774 775 776 777 778 779 780
But in principle the user *might* want rules that only apply to the Id
he says.  And inline pragmas are similar
   {-# NOINLINE f #-}
   f = local
   local = <stuff>
Then we do not want to get rid of the NOINLINE.

Hence hasShortableIdinfo.


Note [Rules and indirection-zapping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Problem: what if x_exported has a RULE that mentions something in ...bindings...?
Then the things mentioned can be out of scope!  Solution
781 782 783
 a) Make sure that in this pass the usage-info from x_exported is
        available for ...bindings...
 b) If there are any such RULES, rec-ify the entire top-level.
784
    It'll get sorted out next time round
785 786 787 788 789 790

Other remarks
~~~~~~~~~~~~~
If more than one exported thing is equal to a local thing (i.e., the
local thing really is shared), then we do one only:
\begin{verbatim}
791 792 793
        x_local = ....
        x_exported1 = x_local
        x_exported2 = x_local
794
==>
795
        x_exported1 = ....
796

797
        x_exported2 = x_exported1
798 799 800 801
\end{verbatim}

We rely on prior eta reduction to simplify things like
\begin{verbatim}
802
        x_exported = /\ tyvars -> x_local tyvars
803
==>
804
        x_exported = x_local
805 806 807
\end{verbatim}
Hence,there's a possibility of leaving unchanged something like this:
\begin{verbatim}
808 809
        x_local = ....
        x_exported1 = x_local Int
810
\end{verbatim}
811
By the time we've thrown away the types in STG land this
812
could be eliminated.  But I don't think it's very common
813
and it's dangerous to do this fiddling in STG land
814 815 816 817
because we might elminate a binding that's mentioned in the
unfolding for something.

\begin{code}
818
type IndEnv = IdEnv Id          -- Maps local_id -> exported_id
819

820
shortOutIndirections :: CoreProgram -> CoreProgram
821 822
shortOutIndirections binds
  | isEmptyVarEnv ind_env = binds
823 824
  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]
  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
825
  where
826 827 828
    ind_env            = makeIndEnv binds
    exp_ids            = varSetElems ind_env    -- These exported Ids are the subjects
    exp_id_set         = mkVarSet exp_ids       -- of the indirection-elimination
829
    no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
830
    binds'             = concatMap zap binds
831 832

    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
833
    zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
834 835

    zapPair (bndr, rhs)
836 837 838 839 840
        | bndr `elemVarSet` exp_id_set             = []
        | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
                                                      (bndr, Var exp_id)]
        | otherwise                                = [(bndr,rhs)]

841 842 843 844 845 846
makeIndEnv :: [CoreBind] -> IndEnv
makeIndEnv binds
  = foldr add_bind emptyVarEnv binds
  where
    add_bind :: CoreBind -> IndEnv -> IndEnv
    add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
847
    add_bind (Rec pairs)              env = foldr add_pair env pairs
848 849 850

    add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
    add_pair (exported_id, Var local_id) env
851
        | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
852
    add_pair _ env = env
853

854
-----------------
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
855
shortMeOut :: IndEnv -> Id -> Id -> Bool
856 857
shortMeOut ind_env exported_id local_id
-- The if-then-else stuff is just so I can get a pprTrace to see
Gabor Greif's avatar
typos  
Gabor Greif committed
858
-- how often I don't get shorting out because of IdInfo stuff
859 860 861 862 863
  = if isExportedId exported_id &&              -- Only if this is exported

       isLocalId local_id &&                    -- Only if this one is defined in this
                                                --      module, so that we *can* change its
                                                --      binding to be the exported thing!
864

865 866
       not (isExportedId local_id) &&           -- Only if this one is not itself exported,
                                                --      since the transformation will nuke it
867

868
       not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for
869
    then
870 871 872
        if hasShortableIdInfo exported_id
        then True       -- See Note [Messing up the exported Id's IdInfo]
        else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
873
             False
874
    else
875
        False
876

877 878 879 880 881 882 883 884
-----------------
hasShortableIdInfo :: Id -> Bool
-- True if there is no user-attached IdInfo on exported_id,
-- so we can safely discard it
-- See Note [Messing up the exported Id's IdInfo]
hasShortableIdInfo id
  =  isEmptySpecInfo (specInfo info)
  && isDefaultInlinePragma (inlinePragInfo info)
885
  && not (isStableUnfolding (unfoldingInfo info))
886 887
  where
     info = idInfo id
888 889 890

-----------------
transferIdInfo :: Id -> Id -> Id
891
-- See Note [Transferring IdInfo]
892
-- If we have
893
--      lcl_id = e; exp_id = lcl_id
894
-- and lcl_id has useful IdInfo, we don't want to discard it by going
895
--      gbl_id = e; lcl_id = gbl_id
896 897
-- Instead, transfer IdInfo from lcl_id to exp_id
-- Overwriting, rather than merging, seems to work ok.
898 899 900 901
transferIdInfo exported_id local_id
  = modifyIdInfo transfer exported_id
  where
    local_info = idInfo local_id
902
    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info
903 904 905 906 907 908 909
                                 `setUnfoldingInfo`     unfoldingInfo local_info
                                 `setInlinePragInfo`    inlinePragInfo local_info
                                 `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
    new_info = setSpecInfoHead (idName exported_id)
                               (specInfo local_info)
        -- Remember to set the function-name field of the
        -- rules as we transfer them from one function to another
910
\end{code}