content: {-
  (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
  
  \section[SimplCore]{Driver for simplifying @Core@ programs}
  -}
  
  {-# LANGUAGE CPP #-}
  
  module Eta.SimplCore.SimplCore ( core2core, simplifyExpr ) where
  
  #include "HsVersions.h"
  
  import Eta.Main.DynFlags
  import Eta.Core.CoreSyn
  import Eta.Main.HscTypes
  import Eta.SimplCore.CSE              ( cseProgram )
  import Eta.Specialise.Rules            ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
                            extendRuleBaseList, ruleCheckProgram, addRuleInfo, )
  import Eta.Core.PprCore          ( pprCoreBindings, pprCoreExpr )
  import Eta.SimplCore.OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
  import Eta.BasicTypes.IdInfo
  import Eta.Core.CoreUtils        ( coreBindsSize, coreBindsStats, exprSize,
                            mkTicks, stripTicksTop )
  import Eta.Core.CoreLint         ( showPass, endPass, lintPassResult, dumpPassResult,
                            lintAnnots )
  import Eta.SimplCore.Simplify         ( simplTopBinds, simplExpr, simplRules )
  import Eta.SimplCore.SimplUtils       ( simplEnvForGHCi, activeRule )
  import Eta.SimplCore.SimplEnv
  import Eta.SimplCore.SimplMonad
  import Eta.SimplCore.CoreMonad
  import qualified Eta.Main.ErrUtils as Err
  import Eta.SimplCore.FloatIn          ( floatInwards )
  import Eta.SimplCore.FloatOut         ( floatOutwards )
  import Eta.Types.FamInstEnv
  import Eta.BasicTypes.Id
  import Eta.BasicTypes.BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma )
  import Eta.BasicTypes.VarSet
  import Eta.BasicTypes.VarEnv
  import Eta.SimplCore.LiberateCase     ( liberateCase )
  import Eta.SimplCore.SAT              ( doStaticArgs )
  import Eta.Specialise.Specialise       ( specProgram)
  import Eta.Specialise.SpecConstr       ( specConstrProgram)
  import Eta.StrAnal.DmdAnal          ( dmdAnalProgram )
  import Eta.SimplCore.CallArity        ( callArityAnalProgram )
  import Eta.StrAnal.WorkWrap         ( wwTopBinds )
  --import Vectorise        ( vectorise ) TODO: Vectorization disabled
  import Eta.Utils.FastString
  import Eta.BasicTypes.SrcLoc
  import Eta.Utils.Util
  
  import Eta.Utils.Maybes
  import Eta.BasicTypes.UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
  import Eta.Utils.Outputable
  import Control.Monad
  
  {-
  ************************************************************************
  *                                                                      *
  \subsection{The driver for the simplifier}
  *                                                                      *
  ************************************************************************
  -}
  
  core2core :: HscEnv -> ModGuts -> IO ModGuts
  core2core hsc_env guts
    = do { us <- mkSplitUniqSupply 's'
         -- make sure all plugins are loaded
  
         ; let builtin_passes = getCoreToDo dflags
         ;
         ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $
                             do { all_passes <- addPluginPasses builtin_passes
                                ; runCorePasses all_passes guts }
  
         ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
               "Grand total simplifier statistics"
               (pprSimplCount stats)
  
         ; 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.
      -- 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.
      print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
  
  {-
  ************************************************************************
  *                                                                      *
             Generating the main optimisation pipeline
  *                                                                      *
  ************************************************************************
  -}
  
  getCoreToDo :: DynFlags -> [CoreToDo]
  getCoreToDo dflags
    = core_todo
    where
      opt_level     = optLevel           dflags
      phases        = simplPhases        dflags
      max_iter      = maxSimplIterations dflags
      rule_check    = ruleCheck          dflags
      call_arity    = gopt Opt_CallArity                    dflags
      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
      late_dmd_anal = gopt Opt_LateDmdAnal                  dflags
      static_args   = gopt Opt_StaticArgumentTransformation dflags
      rules_on      = gopt Opt_EnableRewriteRules           dflags
      eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
  
      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) ]
  
            -- Vectorisation can introduce a fair few common sub expressions involving
            --  DPH primitives. For example, see the Reverse test from dph-examples.
            --  We need to eliminate these common sub expressions before their definitions
            --  are inlined in phase 2. The CSE introduces lots of  v1 = v2 bindings,
            --  so we also run simpl_gently to inline them.
        ++  (if gopt Opt_Vectorise dflags && phase == 3
              then [CoreCSE, simpl_gently]
              else [])
  
      vectorisation
        = runWhen (gopt Opt_Vectorise dflags) $
            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
  
      -- New demand analyser
      demand_analyser = (CoreDoPasses ([
                             CoreDoStrictness,
                             CoreDoWorkerWrapper,
                             simpl_phase 0 ["post-worker-wrapper"] max_iter
                             ]))
  
      core_todo =
       if opt_level == 0 then
         [ vectorisation
         , CoreDoSimplify max_iter
               (base_mode { sm_phase = Phase 0
                          , sm_names = ["Non-opt simplification"] })
         ]
  
       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,
                                   floatOutOverSatApps = False },
                  -- Was: gentleFloatOutSwitches
                  --
                  -- I have no idea why, but not floating constants to
                  -- top level is very bad in some cases.
                  --
                  -- 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
                  --
                  -- Not doing floatOutOverSatApps 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.
  
          simpl_phases,
  
                  -- 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),
  
          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.
  
          runWhen call_arity $ CoreDoPasses
              [ CoreDoCallArity
              , simpl_phase 0 ["post-call-arity"] max_iter
              ],
  
          runWhen strictness demand_analyser,
  
          runWhen full_laziness $
             CoreDoFloatOutwards FloatOutSwitches {
                                   floatOutLambdas     = floatLamArgs dflags,
                                   floatOutConstants   = True,
                                   floatOutOverSatApps = 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,
  
          runWhen late_dmd_anal $ CoreDoPasses [
              CoreDoStrictness,
              CoreDoWorkerWrapper,
              simpl_phase 0 ["post-late-ww"] max_iter
            ],
  
          maybe_rule_check (Phase 0)
       ]
  
  -- Loading plugins
  
  addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo]
  addPluginPasses builtin_passes = return builtin_passes
  
  {-
  ************************************************************************
  *                                                                      *
                    The CoreToDo interpreter
  *                                                                      *
  ************************************************************************
  -}
  
  runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
  runCorePasses passes guts
    = foldM do_pass guts passes
    where
      do_pass guts CoreDoNothing = return guts
      do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
      do_pass guts pass
         = do { showPass pass
              ; guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
              ; endPass pass (mg_binds guts') (mg_rules guts')
              ; return guts' }
  
  doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
  doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
                                         simplifyPgm pass
  
  doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}
                                         doPass cseProgram
  
  doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
                                         doPassD liberateCase
  
  doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
                                         doPassD floatInwards
  
  doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
                                         doPassDUM (floatOutwards f)
  
  doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
                                         doPassU doStaticArgs
  
  doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}
                                         doPassD callArityAnalProgram
  
  doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}
                                         doPassDFM dmdAnalProgram
  
  doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
                                         doPassDFU wwTopBinds
  
  doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
                                         specProgram
  
  doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
                                         specConstrProgram
  
  doCorePass CoreDoVectorisation       = {-# SCC "Vectorise" #-}
                                         panic "doCorePass: CoreDoVectorisation not supported!"
  
  doCorePass CoreDoPrintCore              = observe   printCore
  doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
  doCorePass CoreDoNothing                = return
  doCorePass (CoreDoPasses passes)        = runCorePasses passes
  doCorePass pass = pprPanic "doCorePass" (ppr pass)
  
  {-
  ************************************************************************
  *                                                                      *
  \subsection{Core pass combinators}
  *                                                                      *
  ************************************************************************
  -}
  
  printCore :: DynFlags -> CoreProgram -> IO ()
  printCore dflags binds
      = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
  
  ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
  ruleCheckPass current_phase pat guts = do
      rb <- getRuleBase
      dflags <- getDynFlags
      liftIO $ Err.showPass dflags "RuleCheck"
      liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan (defaultDumpStyle dflags)
                   (ruleCheckProgram current_phase pat rb (mg_binds guts))
      return guts
  
  
  doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
  doPassDUM do_pass = doPassM $ \binds -> do
      dflags <- getDynFlags
      us     <- getUniqueSupplyM
      liftIO $ do_pass dflags us binds
  
  doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
  doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
  
  doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
  doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
  
  doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
  doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
  
  doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
  doPassU do_pass = doPassDU (const do_pass)
  
  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
  
  -- Most passes return no stats and don't change rules: these combinators
  -- let us lift them to the full blown ModGuts+CoreM world
  doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
  doPassM bind_f guts = do
      binds' <- bind_f (mg_binds guts)
      return (guts { mg_binds = binds' })
  
  doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
  doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
  
  -- Observer passes just peek; don't modify the bindings at all
  observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
  observe do_pass = doPassM $ \binds -> do
      dflags <- getDynFlags
      _ <- liftIO $ do_pass dflags binds
      return binds
  
  {-
  ************************************************************************
  *                                                                      *
          Gentle simplification
  *                                                                      *
  ************************************************************************
  -}
  
  simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
               -> CoreExpr
               -> IO CoreExpr
  -- simplifyExpr is called by the driver to simplify an
  -- expression typed in at the interactive prompt
  --
  -- Also used by Template Haskell
  simplifyExpr dflags expr
    = do  {
          ; Err.showPass dflags "Simplify"
  
          ; us <-  mkSplitUniqSupply 's'
  
          ; let sz = exprSize expr
  
          ; (expr', counts) <- initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
                                   simplExprGently (simplEnvForGHCi dflags) expr
  
          ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
                    "Simplifier statistics" (pprSimplCount counts)
  
          ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
                          (pprCoreExpr expr')
  
          ; return expr'
          }
  
  simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
  -- Simplifies an expression
  --      does occurrence analysis, then simplification
  --      and repeats (twice currently) because one pass
  --      alone leaves tons of crud.
  -- Used (a) for user expressions typed in at the interactive prompt
  --      (b) the LHS and RHS of a RULE
  --      (c) Template Haskell splices
  --
  -- 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
  
  -- 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.
  
  simplExprGently env expr = do
      expr1 <- simplExpr env (occurAnalyseExpr expr)
      simplExpr env (occurAnalyseExpr expr1)
  
  {-
  ************************************************************************
  *                                                                      *
  \subsection{The driver for the simplifier}
  *                                                                      *
  ************************************************************************
  -}
  
  simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
  simplifyPgm pass guts
    = do { hsc_env <- getHscEnv
         ; us <- getUniqueSupplyM
         ; rb <- getRuleBase
         ; liftIOWithCount $
           simplifyPgmIO pass hsc_env us rb guts }
  
  simplifyPgmIO :: CoreToDo
                -> HscEnv
                -> UniqSupply
                -> RuleBase
                -> ModGuts
                -> IO (SimplCount, ModGuts)  -- New bindings
  
  simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
                hsc_env us hpt_rule_base
                guts@(ModGuts { mg_module = this_mod
                              , mg_rdr_env = rdr_env
                              , mg_binds = binds, mg_rules = rules
                              , mg_fam_inst_env = fam_inst_env })
    = do { (termination_msg, it_count, counts_out, guts')
             <- do_iteration us 1 [] binds rules
  
          ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&
                                  dopt Opt_D_dump_simpl_stats  dflags)
                    "Simplifier statistics for following pass"
                    (vcat [text termination_msg <+> text "after" <+> ppr it_count
                                                <+> text "iterations",
                           blankLine,
                           pprSimplCount counts_out])
  
          ; return (counts_out, guts')
      }
    where
      dflags       = hsc_dflags hsc_env
      print_unqual = mkPrintUnqualified dflags rdr_env
      simpl_env    = mkSimplEnv mode
      active_rule  = activeRule simpl_env
  
      do_iteration :: UniqSupply
                   -> Int          -- Counts iterations
                   -> [SimplCount] -- Counts from earlier iterations, reversed
                   -> CoreProgram  -- Bindings in
                   -> [CoreRule]   -- and orphan rules
                   -> IO (String, Int, SimplCount, ModGuts)
  
      do_iteration us iteration_no counts_so_far binds rules
          -- 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
        = WARN( debugIsOn && (max_iterations > 2)
              , hang (ptext (sLit "Simplifier bailing out after") <+> int max_iterations
                      <+> ptext (sLit "iterations")
                      <+> (brackets $ hsep $ punctuate comma $
                           map (int . simplCountN) (reverse counts_so_far)))
                   2 (ptext (sLit "Size =") <+> ppr (coreBindsStats binds)))
  
                  -- Subtract 1 from iteration_no to get the
                  -- number of iterations we actually completed
          return ( "Simplifier baled out", iteration_no - 1
                 , totalise counts_so_far
                 , guts { mg_binds = binds, mg_rules = rules } )
  
        -- Try and force thunks off the binds; significantly reduces
        -- space usage, especially with -O.  JRS, 000620.
        | let sz = coreBindsSize binds
        , sz == sz     -- Force it
        = do {
                  -- Occurrence analysis
             let {   -- Note [Vectorisation declarations and occurrences]
                     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
                     -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure
                     -- that the right-hand sides of vectorisation declarations are taken into
                     -- 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.)
                   vectVars = mkVarSet $
                                catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr
                                          | Vect bndr _ <- mg_vect_decls guts]
                                ++
                                catMaybes [ fmap snd $ lookupVarEnv (vectInfoVar (mg_vect_info guts)) bndr
                                          | 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".
                ;  (maybeVects, maybeVectVars)
                     = case sm_phase mode of
                         InitialPhase -> (mg_vect_decls guts, vectVars)
                         _            -> ([], vectVars)
                 ; tagged_binds = {-# SCC "OccAnal" #-}
                       occurAnalysePgm this_mod active_rule rules maybeVects maybeVectVars binds
                 } ;
             Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                       (pprCoreBindings tagged_binds);
  
                  -- 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
                  ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
  
                  -- Simplify the program
             ((binds1, rules1), counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz $
                 do { env1 <- {-# SCC "SimplTopBinds" #-}
                              simplTopBinds simpl_env tagged_binds
  
                        -- 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
                    ; rules1 <- simplRules env1 Nothing rules
  
                    ; return (getFloatBinds env1, rules1) } ;
  
                  -- 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
             dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;
             lintPassResult hsc_env pass binds2 ;
  
                  -- Loop
             do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
             } }
        | otherwise = panic "do_iteration"
        where
          (us1, us2) = splitUniqSupply us
  
          -- Remember the counts_so_far are reversed
          totalise :: [SimplCount] -> SimplCount
          totalise = foldr (\c acc -> acc `plusSimplCount` c)
                           (zeroSimplCount dflags)
  
  simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
  
  -------------------
  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
    where
      mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations
              | otherwise                               = Nothing
              -- Show details if Opt_D_dump_simpl_iterations is on
  
      hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no
      pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr
                       , pprSimplCount counts
                       , ptext (sLit "---- End of simplifier counts for") <+> hdr ]
  
  {-
  ************************************************************************
  *                                                                      *
                  Shorting out indirections
  *                                                                      *
  ************************************************************************
  
  If we have this:
  
          x_local = <expression>
          ...bindings...
          x_exported = x_local
  
  where x_exported is exported, and x_local is not, then we replace it with this:
  
          x_exported = <expression>
          x_local = x_exported
          ...bindings...
  
  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.
  
  Note [Transferring IdInfo]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~
  We want to propagage any useful IdInfo on x_local to x_exported.
  
  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.
  
  
  Note [Messing up the exported Id's RULES]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  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:
  
      iterate :: (a -> a) -> a -> [a]
          [Exported]
      iterate = iterateList
  
      iterateFB c f x = x `c` iterateFB c f (f x)
      iterateList f x =  x : iterateList f (f x)
          [Not exported]
  
      {-# RULES
      "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
      "iterateFB"                 iterateFB (:) = iterateList
       #-}
  
  This got shorted out to:
  
      iterateList :: (a -> a) -> a -> [a]
      iterateList = iterate
  
      iterateFB c f x = x `c` iterateFB c f (f x)
      iterate f x =  x : iterate f (f x)
  
      {-# RULES
      "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
      "iterateFB"                 iterateFB (:) = iterate
       #-}
  
  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
  
  Old "solution":
          use rule switching-off pragmas to get rid
          of iterateList in the first place
  
  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
   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.
      It'll get sorted out next time round
  
  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}
          x_local = ....
          x_exported1 = x_local
          x_exported2 = x_local
  ==>
          x_exported1 = ....
  
          x_exported2 = x_exported1
  \end{verbatim}
  
  We rely on prior eta reduction to simplify things like
  \begin{verbatim}
          x_exported = /\ tyvars -> x_local tyvars
  ==>
          x_exported = x_local
  \end{verbatim}
  Hence,there's a possibility of leaving unchanged something like this:
  \begin{verbatim}
          x_local = ....
          x_exported1 = x_local Int
  \end{verbatim}
  By the time we've thrown away the types in STG land this
  could be eliminated.  But I don't think it's very common
  and it's dangerous to do this fiddling in STG land
  because we might elminate a binding that's mentioned in the
  unfolding for something.
  
  Note [Indirection zapping and ticks]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  Unfortunately this is another place where we need a special case for
  ticks. The following happens quite regularly:
  
          x_local = <expression>
          x_exported = tick<x> x_local
  
  Which we want to become:
  
          x_exported =  tick<x> <expression>
  
  As it makes no sense to keep the tick and the expression on separate
  bindings. Note however that that this might increase the ticks scoping
  over the execution of x_local, so we can only do this for floatable
  ticks. More often than not, other references will be unfoldings of
  x_exported, and therefore carry the tick anyway.
  -}
  
  type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks
  
  shortOutIndirections :: CoreProgram -> CoreProgram
  shortOutIndirections binds
    | isEmptyVarEnv ind_env = binds
    | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]
    | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
    where
      ind_env            = makeIndEnv binds
      -- These exported Ids are the subjects  of the indirection-elimination
      exp_ids            = map fst $ varEnvElts ind_env
      exp_id_set         = mkVarSet exp_ids
      no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids
      binds'             = concatMap zap binds
  
      zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
      zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
  
      zapPair (bndr, rhs)
          | bndr `elemVarSet` exp_id_set = []
          | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr
                                         = [(transferIdInfo exp_id bndr,
                                             mkTicks ticks rhs),
                                            (bndr, Var exp_id)]
          | otherwise                    = [(bndr,rhs)]
  
  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
      add_bind (Rec pairs)              env = foldr add_pair env pairs
  
      add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
      add_pair (exported_id, exported) env
          | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported
          , shortMeOut env exported_id local_id
          = extendVarEnv env local_id (exported_id, ticks)
      add_pair _ env = env
  
  -----------------
  shortMeOut :: IndEnv -> Id -> Id -> Bool
  shortMeOut ind_env exported_id local_id
  -- The if-then-else stuff is just so I can get a pprTrace to see
  -- how often I don't get shorting out because of IdInfo stuff
    = 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!
  
         not (isExportedId local_id) &&           -- Only if this one is not itself exported,
                                                  --      since the transformation will nuke it
  
         not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for
      then
          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 )
               False
      else
          False
  
  -----------------
  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
    =  isEmptyRuleInfo (ruleInfo info)
    && isDefaultInlinePragma (inlinePragInfo info)
    && not (isStableUnfolding (unfoldingInfo info))
    where
       info = idInfo id
  
  -----------------
  transferIdInfo :: Id -> Id -> Id
  -- See Note [Transferring IdInfo]
  -- If we have
  --      lcl_id = e; exp_id = lcl_id
  -- and lcl_id has useful IdInfo, we don't want to discard it by going
  --      gbl_id = e; lcl_id = gbl_id
  -- Instead, transfer IdInfo from lcl_id to exp_id
  -- Overwriting, rather than merging, seems to work ok.
  transferIdInfo exported_id local_id
    = modifyIdInfo transfer exported_id
    where
      local_info = idInfo local_id
      transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info
                                   `setUnfoldingInfo`     unfoldingInfo local_info
                                   `setInlinePragInfo`    inlinePragInfo local_info
                                   `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info
      new_info = setRuleInfoHead (idName exported_id)
                                 (ruleInfo local_info)
          -- Remember to set the function-name field of the
          -- rules as we transfer them from one function to another
  