    {-# LANGUAGE CPP #-}

    module GHC.Core.Opt.Simplify
      ( SimplifyExprOpts(..), SimplifyOpts(..)
      , simplifyExpr, simplifyPgm
      ) where

    import GHC.Prelude

    import GHC.Driver.Flags

    import GHC.Core
    import GHC.Core.Rules
    import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )
    import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
    import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )
    import GHC.Core.Utils   ( mkTicks, stripTicksTop )
    import GHC.Core.Lint    ( LintPassResultConfig, dumpPassResult, lintPassResult )
    import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules )
    import GHC.Core.Opt.Simplify.Utils ( activeRule, activeUnfolding )
    import GHC.Core.Opt.Simplify.Env
    import GHC.Core.Opt.Simplify.Monad
    import GHC.Core.Opt.Stats ( simplCountN )
    import GHC.Core.FamInstEnv

    import GHC.Utils.Error  ( withTiming )
    import GHC.Utils.Logger as Logger
    import GHC.Utils.Outputable
    import GHC.Utils.Constants (debugIsOn)

    import GHC.Unit.Env ( UnitEnv, ueEPS )
    import GHC.Unit.External
    import GHC.Unit.Module.ModGuts

    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.Basic
    import GHC.Types.Var.Set
    import GHC.Types.Var.Env
    import GHC.Types.Tickish
    import GHC.Types.Unique.FM

    import Control.Monad
    import Data.Foldable ( for_ )

    {-
    ************************************************************************
    *                                                                      *
            Gentle simplification
    *                                                                      *
    ************************************************************************
    -}

    -- | Configuration record for `simplifyExpr`.
    -- The values of this datatype are /only/ driven by the demands of that function.
    data SimplifyExprOpts = SimplifyExprOpts
      { SimplifyExprOpts -> [FamInst]
    se_fam_inst :: ![FamInst]
      , SimplifyExprOpts -> SimplMode
    se_mode :: !SimplMode
      , SimplifyExprOpts -> TopEnvConfig
    se_top_env_cfg :: !TopEnvConfig
      }

    simplifyExpr :: Logger
                 -> ExternalUnitCache
                 -> SimplifyExprOpts
                 -> CoreExpr
                 -> IO CoreExpr
    -- simplifyExpr is called by the driver to simplify an
    -- expression typed in at the interactive prompt
    simplifyExpr :: Logger
    -> ExternalUnitCache -> SimplifyExprOpts -> CoreExpr -> IO CoreExpr
    simplifyExpr Logger
    logger ExternalUnitCache
    euc SimplifyExprOpts
    opts CoreExpr
    expr
      = Logger -> SDoc -> (CoreExpr -> ()) -> IO CoreExpr -> IO CoreExpr
    forall (m :: * -> *) a.
    MonadIO m =>
    Logger -> SDoc -> (a -> ()) -> m a -> m a
    withTiming Logger
    logger (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Simplify [expr]") (() -> CoreExpr -> ()
    forall a b. a -> b -> a
    const ()) (IO CoreExpr -> IO CoreExpr) -> IO CoreExpr -> IO CoreExpr
    forall a b. (a -> b) -> a -> b
    $
        do  { eps <- ExternalUnitCache -> IO ExternalPackageState
    eucEPS ExternalUnitCache
    euc ;
            ; let fam_envs = ( ExternalPackageState -> PackageFamInstEnv
    eps_fam_inst_env ExternalPackageState
    eps
                             , PackageFamInstEnv -> [FamInst] -> PackageFamInstEnv
    extendFamInstEnvList PackageFamInstEnv
    emptyFamInstEnv ([FamInst] -> PackageFamInstEnv) -> [FamInst] -> PackageFamInstEnv
    forall a b. (a -> b) -> a -> b
    $ SimplifyExprOpts -> [FamInst]
    se_fam_inst SimplifyExprOpts
    opts
                             )
                  simpl_env = SimplMode -> (PackageFamInstEnv, PackageFamInstEnv) -> SimplEnv
    mkSimplEnv (SimplifyExprOpts -> SimplMode
    se_mode SimplifyExprOpts
    opts) (PackageFamInstEnv, PackageFamInstEnv)
    fam_envs
                  top_env_cfg = SimplifyExprOpts -> TopEnvConfig
    se_top_env_cfg SimplifyExprOpts
    opts
                  read_eps_rules = ExternalPackageState -> PackageRuleBase
    eps_rule_base (ExternalPackageState -> PackageRuleBase)
    -> IO ExternalPackageState -> IO PackageRuleBase
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ExternalUnitCache -> IO ExternalPackageState
    eucEPS ExternalUnitCache
    euc
                  read_ruleenv = RuleEnv -> PackageRuleBase -> RuleEnv
    updExternalPackageRules RuleEnv
    emptyRuleEnv (PackageRuleBase -> RuleEnv) -> IO PackageRuleBase -> IO RuleEnv
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO PackageRuleBase
    read_eps_rules

            ; let sz = CoreExpr -> Int
    exprSize CoreExpr
    expr

            ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $
                                 simplExprGently simpl_env expr

            ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats
                      "Simplifier statistics" FormatText (pprSimplCount counts)

            ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression"
                            FormatCore
                            (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 SimplMode is InitialPhase,
    -- 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 [Simplify rule LHS] above.  The
    -- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam)
    -- but only if -O is on.

    simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
    simplExprGently SimplEnv
    env CoreExpr
    expr = do
        expr1 <- SimplEnv -> CoreExpr -> SimplM CoreExpr
    simplExpr SimplEnv
    env (CoreExpr -> CoreExpr
    occurAnalyseExpr CoreExpr
    expr)
        simplExpr env (occurAnalyseExpr expr1)

    {-
    ************************************************************************
    *                                                                      *
    \subsection{The driver for the simplifier}
    *                                                                      *
    ************************************************************************
    -}

    -- | Configuration record for `simplifyPgm`.
    -- The values of this datatype are /only/ driven by the demands of that function.
    data SimplifyOpts = SimplifyOpts
      { SimplifyOpts -> Bool
    so_dump_core_sizes :: !Bool
      , SimplifyOpts -> Int
    so_iterations      :: !Int
      , SimplifyOpts -> SimplMode
    so_mode            :: !SimplMode

      , SimplifyOpts -> Maybe LintPassResultConfig
    so_pass_result_cfg :: !(Maybe LintPassResultConfig)
                              -- Nothing => Do not Lint
                              -- Just cfg => Lint like this

      , SimplifyOpts -> PackageRuleBase
    so_hpt_rules       :: !RuleBase
      , SimplifyOpts -> TopEnvConfig
    so_top_env_cfg     :: !TopEnvConfig
      }

    simplifyPgm :: Logger
                -> UnitEnv
                -> NamePprCtx                -- For dumping
                -> SimplifyOpts
                -> ModGuts
                -> IO (SimplCount, ModGuts)  -- New bindings

    simplifyPgm :: Logger
    -> UnitEnv
    -> NamePprCtx
    -> SimplifyOpts
    -> ModGuts
    -> IO (SimplCount, ModGuts)
    simplifyPgm Logger
    logger UnitEnv
    unit_env NamePprCtx
    name_ppr_ctx SimplifyOpts
    opts
                guts :: ModGuts
    guts@(ModGuts { mg_module :: ModGuts -> Module
    mg_module = Module
    this_mod
                              , mg_binds :: ModGuts -> CoreProgram
    mg_binds = CoreProgram
    binds, mg_rules :: ModGuts -> [CoreRule]
    mg_rules = [CoreRule]
    local_rules
                              , mg_fam_inst_env :: ModGuts -> PackageFamInstEnv
    mg_fam_inst_env = PackageFamInstEnv
    fam_inst_env })
      = do { (termination_msg, it_count, counts_out, guts')
                <- Int
    -> [SimplCount]
    -> CoreProgram
    -> [CoreRule]
    -> IO (String, Int, SimplCount, ModGuts)
    do_iteration Int
    1 [] CoreProgram
    binds [CoreRule]
    local_rules

            ; when (logHasDumpFlag logger Opt_D_verbose_core2core
                    && logHasDumpFlag logger Opt_D_dump_simpl_stats) $
              logDumpMsg logger
                      "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
        dump_core_sizes :: Bool
    dump_core_sizes = SimplifyOpts -> Bool
    so_dump_core_sizes SimplifyOpts
    opts
        mode :: SimplMode
    mode            = SimplifyOpts -> SimplMode
    so_mode SimplifyOpts
    opts
        max_iterations :: Int
    max_iterations  = SimplifyOpts -> Int
    so_iterations SimplifyOpts
    opts
        top_env_cfg :: TopEnvConfig
    top_env_cfg     = SimplifyOpts -> TopEnvConfig
    so_top_env_cfg SimplifyOpts
    opts
        active_rule :: Activation -> Bool
    active_rule     = SimplMode -> Activation -> Bool
    activeRule SimplMode
    mode
        active_unf :: Id -> Bool
    active_unf      = SimplMode -> Id -> Bool
    activeUnfolding SimplMode
    mode
        -- Note the bang in !guts_no_binds.  If you don't force `guts_no_binds`
        -- the old bindings are retained until the end of all simplifier iterations
        !guts_no_binds :: ModGuts
    guts_no_binds = ModGuts
    guts { mg_binds = [], mg_rules = [] }

        hpt_rule_env :: RuleEnv
        hpt_rule_env :: RuleEnv
    hpt_rule_env = ModGuts -> PackageRuleBase -> PackageRuleBase -> RuleEnv
    mkRuleEnv ModGuts
    guts PackageRuleBase
    emptyRuleBase (SimplifyOpts -> PackageRuleBase
    so_hpt_rules SimplifyOpts
    opts)
                       -- emptyRuleBase: no EPS rules yet; we will update
                       -- them on each iteration to pick up the most up to date set

        do_iteration :: Int -- Counts iterations
                     -> [SimplCount] -- Counts from earlier iterations, reversed
                     -> CoreProgram  -- Bindings
                     -> [CoreRule]   -- Local rules for imported Ids
                     -> IO (String, Int, SimplCount, ModGuts)

        do_iteration :: Int
    -> [SimplCount]
    -> CoreProgram
    -> [CoreRule]
    -> IO (String, Int, SimplCount, ModGuts)
    do_iteration Int
    iteration_no [SimplCount]
    counts_so_far CoreProgram
    binds [CoreRule]
    local_rules
            -- iteration_no is the number of the iteration we are
            -- about to begin, with '1' for the first
          | Int
    iteration_no Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    max_iterations   -- Stop if we've run out of iterations
          = Bool
    -> String
    -> SDoc
    -> IO (String, Int, SimplCount, ModGuts)
    -> IO (String, Int, SimplCount, ModGuts)
    forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
    warnPprTrace (Bool
    debugIsOn Bool -> Bool -> Bool
    && (Int
    max_iterations Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    2))
                String
    "Simplifier bailing out"
                ( SDoc -> Int -> SDoc -> SDoc
    hang (Module -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Module
    this_mod SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    ", after"
                        SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall doc. IsLine doc => Int -> doc
    int Int
    max_iterations SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "iterations"
                        SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> (SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    brackets (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    forall doc. IsLine doc => doc -> [doc] -> [doc]
    punctuate SDoc
    forall doc. IsLine doc => doc
    comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
    forall a b. (a -> b) -> a -> b
    $
                             (SimplCount -> SDoc) -> [SimplCount] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> SDoc
    forall doc. IsLine doc => Int -> doc
    int (Int -> SDoc) -> (SimplCount -> Int) -> SimplCount -> SDoc
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . SimplCount -> Int
    simplCountN) ([SimplCount] -> [SimplCount]
    forall a. [a] -> [a]
    reverse [SimplCount]
    counts_so_far)))
                     Int
    2 (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Size =" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CoreStats -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CoreProgram -> CoreStats
    coreBindsStats CoreProgram
    binds))) (IO (String, Int, SimplCount, ModGuts)
     -> IO (String, Int, SimplCount, ModGuts))
    -> IO (String, Int, SimplCount, ModGuts)
    -> IO (String, Int, SimplCount, ModGuts)
    forall a b. (a -> b) -> a -> b
    $

                    -- Subtract 1 from iteration_no to get the
                    -- number of iterations we actually completed
            (String, Int, SimplCount, ModGuts)
    -> IO (String, Int, SimplCount, ModGuts)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( String
    "Simplifier baled out", Int
    iteration_no Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1
                   , [SimplCount] -> SimplCount
    totalise [SimplCount]
    counts_so_far
                   , ModGuts
    guts_no_binds { mg_binds = binds, mg_rules = local_rules } )

          -- Try and force thunks off the binds; significantly reduces
          -- space usage, especially with -O.  JRS, 000620.
          | let sz :: Int
    sz = CoreProgram -> Int
    coreBindsSize CoreProgram
    binds
          , () <- Int
    sz Int -> () -> ()
    forall a b. a -> b -> b
    `seq` ()     -- Force it
          = do {
                    -- Occurrence analysis
               let { tagged_binds :: CoreProgram
    tagged_binds = {-# SCC "OccAnal" #-}
                         Module
    -> (Id -> Bool)
    -> (Activation -> Bool)
    -> [CoreRule]
    -> CoreProgram
    -> CoreProgram
    occurAnalysePgm Module
    this_mod Id -> Bool
    active_unf Activation -> Bool
    active_rule
                                         [CoreRule]
    local_rules CoreProgram
    binds
                   } ;
               Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
    Logger.putDumpFileMaybe Logger
    logger DumpFlag
    Opt_D_dump_occur_anal String
    "Occurrence analysis"
                         DumpFormat
    FormatCore
                         (CoreProgram -> SDoc
    forall b. OutputableBndr b => [Bind b] -> SDoc
    pprCoreBindings CoreProgram
    tagged_binds);

                    -- read_eps_rules:
                    -- We need to read rules from the EPS 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
                    -- Hence just before attempting to match a rule we read the EPS
                    -- value (via read_rule_env) and then combine it with the existing rule base.
                    -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.
              eps <- UnitEnv -> IO ExternalPackageState
    ueEPS UnitEnv
    unit_env ;
               let  { -- base_rule_env contains
                      --    (a) home package rules, fixed across all iterations
                      --    (b) local rules (substituted) from `local_rules` arg to do_iteration
                      -- Forcing base_rule_env to avoid unnecessary allocations.
                      -- Not doing so results in +25.6% allocations of LargeRecord.
                    ; !base_rule_env = RuleEnv -> [CoreRule] -> RuleEnv
    updLocalRules RuleEnv
    hpt_rule_env [CoreRule]
    local_rules

                    ; read_eps_rules :: IO PackageRuleBase
                    ; read_eps_rules = ExternalPackageState -> PackageRuleBase
    eps_rule_base (ExternalPackageState -> PackageRuleBase)
    -> IO ExternalPackageState -> IO PackageRuleBase
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> UnitEnv -> IO ExternalPackageState
    ueEPS UnitEnv
    unit_env

                    ; read_rule_env :: IO RuleEnv
                    ; read_rule_env = RuleEnv -> PackageRuleBase -> RuleEnv
    updExternalPackageRules RuleEnv
    base_rule_env (PackageRuleBase -> RuleEnv) -> IO PackageRuleBase -> IO RuleEnv
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO PackageRuleBase
    read_eps_rules

                    ; fam_envs = (ExternalPackageState -> PackageFamInstEnv
    eps_fam_inst_env ExternalPackageState
    eps, PackageFamInstEnv
    fam_inst_env)
                    ; simpl_env = SimplMode -> (PackageFamInstEnv, PackageFamInstEnv) -> SimplEnv
    mkSimplEnv SimplMode
    mode (PackageFamInstEnv, PackageFamInstEnv)
    fam_envs } ;

                    -- Simplify the program
               ((binds1, rules1), counts1) <-
                 initSmpl logger read_rule_env top_env_cfg sz $
                   do { (floats, 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 <- simplImpRules env1 local_rules

                      ; return (getTopFloatBinds floats, rules1) } ;

                    -- Stop if nothing happened; don't dump output
                    -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats
               if isZeroSimplCount counts1 then
                    return ( "Simplifier reached fixed point", iteration_no
                           , totalise (counts1 : counts_so_far)  -- Include "free" ticks
                           , guts_no_binds { 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" #-} CoreProgram -> CoreProgram
    shortOutIndirections CoreProgram
    binds1 } ;

                    -- Dump the result of this iteration
               dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts1 binds2 rules1 ;

               for_ (so_pass_result_cfg opts) $ \LintPassResultConfig
    pass_result_cfg ->
                 Logger -> LintPassResultConfig -> CoreProgram -> IO ()
    lintPassResult Logger
    logger LintPassResultConfig
    pass_result_cfg CoreProgram
    binds2 ;

                    -- Loop
               do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
               } }
          where
            -- Remember the counts_so_far are reversed
            totalise :: [SimplCount] -> SimplCount
            totalise :: [SimplCount] -> SimplCount
    totalise = (SimplCount -> SimplCount -> SimplCount)
    -> SimplCount -> [SimplCount] -> SimplCount
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\SimplCount
    c SimplCount
    acc -> SimplCount
    acc SimplCount -> SimplCount -> SimplCount
    `plusSimplCount` SimplCount
    c)
                             (Bool -> SimplCount
    zeroSimplCount (Bool -> SimplCount) -> Bool -> SimplCount
    forall a b. (a -> b) -> a -> b
    $ Logger -> DumpFlag -> Bool
    logHasDumpFlag Logger
    logger DumpFlag
    Opt_D_dump_simpl_stats)

    dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int
                       -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
    dump_end_iteration :: Logger
    -> Bool
    -> NamePprCtx
    -> Int
    -> SimplCount
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    dump_end_iteration Logger
    logger Bool
    dump_core_sizes NamePprCtx
    name_ppr_ctx Int
    iteration_no SimplCount
    counts CoreProgram
    binds [CoreRule]
    rules
      = Logger
    -> Bool
    -> NamePprCtx
    -> Maybe DumpFlag
    -> String
    -> SDoc
    -> CoreProgram
    -> [CoreRule]
    -> IO ()
    dumpPassResult Logger
    logger Bool
    dump_core_sizes NamePprCtx
    name_ppr_ctx Maybe DumpFlag
    mb_flag String
    hdr SDoc
    pp_counts CoreProgram
    binds [CoreRule]
    rules
      where
        mb_flag :: Maybe DumpFlag
    mb_flag | Logger -> DumpFlag -> Bool
    logHasDumpFlag Logger
    logger DumpFlag
    Opt_D_dump_simpl_iterations = DumpFlag -> Maybe DumpFlag
    forall a. a -> Maybe a
    Just DumpFlag
    Opt_D_dump_simpl_iterations
                | Bool
    otherwise                                         = Maybe DumpFlag
    forall a. Maybe a
    Nothing
                -- Show details if Opt_D_dump_simpl_iterations is on

        hdr :: String
    hdr = String
    "Simplifier iteration=" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    iteration_no
        pp_counts :: SDoc
    pp_counts = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "---- Simplifier counts for" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    hdr
                         , SimplCount -> SDoc
    pprSimplCount SimplCount
    counts
                         , String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "---- End of simplifier counts for" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    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 [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
    they say.  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 eliminate 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 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, [CoreTickish]) -- Maps local_id -> exported_id, ticks

    shortOutIndirections :: CoreProgram -> CoreProgram
    shortOutIndirections :: CoreProgram -> CoreProgram
    shortOutIndirections CoreProgram
    binds
      | VarEnv (Id, [CoreTickish]) -> Bool
    forall a. VarEnv a -> Bool
    isEmptyVarEnv VarEnv (Id, [CoreTickish])
    ind_env = CoreProgram
    binds
      | Bool
    no_need_to_flatten    = CoreProgram
    binds'                      -- See Note [Rules and indirection-zapping]
      | Bool
    otherwise             = [[(Id, CoreExpr)] -> Bind Id
    forall b. [(b, Expr b)] -> Bind b
    Rec (CoreProgram -> [(Id, CoreExpr)]
    forall b. [Bind b] -> [(b, Expr b)]
    flattenBinds CoreProgram
    binds')] -- for this no_need_to_flatten stuff
      where
        ind_env :: VarEnv (Id, [CoreTickish])
    ind_env            = CoreProgram -> VarEnv (Id, [CoreTickish])
    makeIndEnv CoreProgram
    binds
        -- These exported Ids are the subjects  of the indirection-elimination
        exp_ids :: [Id]
    exp_ids            = ((Id, [CoreTickish]) -> Id) -> [(Id, [CoreTickish])] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map (Id, [CoreTickish]) -> Id
    forall a b. (a, b) -> a
    fst ([(Id, [CoreTickish])] -> [Id]) -> [(Id, [CoreTickish])] -> [Id]
    forall a b. (a -> b) -> a -> b
    $ VarEnv (Id, [CoreTickish]) -> [(Id, [CoreTickish])]
    forall {k} (key :: k) elt. UniqFM key elt -> [elt]
    nonDetEltsUFM VarEnv (Id, [CoreTickish])
    ind_env
          -- It's OK to use nonDetEltsUFM here because we forget the ordering
          -- by immediately converting to a set or check if all the elements
          -- satisfy a predicate.
        exp_id_set :: VarSet
    exp_id_set         = [Id] -> VarSet
    mkVarSet [Id]
    exp_ids
        no_need_to_flatten :: Bool
    no_need_to_flatten = (Id -> Bool) -> [Id] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all ([CoreRule] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null ([CoreRule] -> Bool) -> (Id -> [CoreRule]) -> Id -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . RuleInfo -> [CoreRule]
    ruleInfoRules (RuleInfo -> [CoreRule]) -> (Id -> RuleInfo) -> Id -> [CoreRule]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Id -> RuleInfo
    idSpecialisation) [Id]
    exp_ids
        binds' :: CoreProgram
    binds'             = (Bind Id -> CoreProgram) -> CoreProgram -> CoreProgram
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Bind Id -> CoreProgram
    zap CoreProgram
    binds

        zap :: Bind Id -> CoreProgram
    zap (NonRec Id
    bndr CoreExpr
    rhs) = [Id -> CoreExpr -> Bind Id
    forall b. b -> Expr b -> Bind b
    NonRec Id
    b CoreExpr
    r | (Id
    b,CoreExpr
    r) <- (Id, CoreExpr) -> [(Id, CoreExpr)]
    zapPair (Id
    bndr,CoreExpr
    rhs)]
        zap (Rec [(Id, CoreExpr)]
    pairs)       = [[(Id, CoreExpr)] -> Bind Id
    forall b. [(b, Expr b)] -> Bind b
    Rec (((Id, CoreExpr) -> [(Id, CoreExpr)])
    -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Id, CoreExpr) -> [(Id, CoreExpr)]
    zapPair [(Id, CoreExpr)]
    pairs)]

        zapPair :: (Id, CoreExpr) -> [(Id, CoreExpr)]
    zapPair (Id
    bndr, CoreExpr
    rhs)
            | Id
    bndr Id -> VarSet -> Bool
    `elemVarSet` VarSet
    exp_id_set
            = []   -- Kill the exported-id binding

            | Just (Id
    exp_id, [CoreTickish]
    ticks) <- VarEnv (Id, [CoreTickish]) -> Id -> Maybe (Id, [CoreTickish])
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv VarEnv (Id, [CoreTickish])
    ind_env Id
    bndr
            , (Id
    exp_id', Id
    lcl_id') <- Id -> Id -> (Id, Id)
    transferIdInfo Id
    exp_id Id
    bndr
            =      -- Turn a local-id binding into two bindings
                   --    exp_id = rhs; lcl_id = exp_id
              [ (Id
    exp_id', [CoreTickish] -> CoreExpr -> CoreExpr
    mkTicks [CoreTickish]
    ticks CoreExpr
    rhs),
                (Id
    lcl_id', Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    exp_id') ]

            | Bool
    otherwise
            = [(Id
    bndr,CoreExpr
    rhs)]

    makeIndEnv :: [CoreBind] -> IndEnv
    makeIndEnv :: CoreProgram -> VarEnv (Id, [CoreTickish])
    makeIndEnv CoreProgram
    binds
      = (VarEnv (Id, [CoreTickish])
     -> Bind Id -> VarEnv (Id, [CoreTickish]))
    -> VarEnv (Id, [CoreTickish])
    -> CoreProgram
    -> VarEnv (Id, [CoreTickish])
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' VarEnv (Id, [CoreTickish]) -> Bind Id -> VarEnv (Id, [CoreTickish])
    add_bind VarEnv (Id, [CoreTickish])
    forall a. VarEnv a
    emptyVarEnv CoreProgram
    binds
      where
        add_bind :: IndEnv -> CoreBind -> IndEnv
        add_bind :: VarEnv (Id, [CoreTickish]) -> Bind Id -> VarEnv (Id, [CoreTickish])
    add_bind VarEnv (Id, [CoreTickish])
    env (NonRec Id
    exported_id CoreExpr
    rhs) = VarEnv (Id, [CoreTickish])
    -> (Id, CoreExpr) -> VarEnv (Id, [CoreTickish])
    add_pair VarEnv (Id, [CoreTickish])
    env (Id
    exported_id, CoreExpr
    rhs)
        add_bind VarEnv (Id, [CoreTickish])
    env (Rec [(Id, CoreExpr)]
    pairs)              = (VarEnv (Id, [CoreTickish])
     -> (Id, CoreExpr) -> VarEnv (Id, [CoreTickish]))
    -> VarEnv (Id, [CoreTickish])
    -> [(Id, CoreExpr)]
    -> VarEnv (Id, [CoreTickish])
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' VarEnv (Id, [CoreTickish])
    -> (Id, CoreExpr) -> VarEnv (Id, [CoreTickish])
    add_pair VarEnv (Id, [CoreTickish])
    env [(Id, CoreExpr)]
    pairs

        add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv
        add_pair :: VarEnv (Id, [CoreTickish])
    -> (Id, CoreExpr) -> VarEnv (Id, [CoreTickish])
    add_pair VarEnv (Id, [CoreTickish])
    env (Id
    exported_id, CoreExpr
    exported)
            | ([CoreTickish]
    ticks, Var Id
    local_id) <- (CoreTickish -> Bool) -> CoreExpr -> ([CoreTickish], CoreExpr)
    forall b.
    (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
    stripTicksTop CoreTickish -> Bool
    forall (pass :: TickishPass). GenTickish pass -> Bool
    tickishFloatable CoreExpr
    exported
            , VarEnv (Id, [CoreTickish]) -> Id -> Id -> Bool
    shortMeOut VarEnv (Id, [CoreTickish])
    env Id
    exported_id Id
    local_id
            = VarEnv (Id, [CoreTickish])
    -> Id -> (Id, [CoreTickish]) -> VarEnv (Id, [CoreTickish])
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv VarEnv (Id, [CoreTickish])
    env Id
    local_id (Id
    exported_id, [CoreTickish]
    ticks)
        add_pair VarEnv (Id, [CoreTickish])
    env (Id, CoreExpr)
    _ = VarEnv (Id, [CoreTickish])
    env

    shortMeOut :: IndEnv -> Id -> Id -> Bool
    shortMeOut :: VarEnv (Id, [CoreTickish]) -> Id -> Id -> Bool
    shortMeOut VarEnv (Id, [CoreTickish])
    ind_env Id
    exported_id 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 Id -> Bool
    isExportedId Id
    exported_id Bool -> Bool -> Bool
    &&              -- Only if this is exported

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

           Bool -> Bool
    not (Id -> Bool
    isExportedId Id
    local_id) Bool -> Bool -> Bool
    &&           -- Only if this one is not itself exported,
                                                    --      since the transformation will nuke it

           Bool -> Bool
    not (Id
    local_id Id -> VarEnv (Id, [CoreTickish]) -> Bool
    forall a. Id -> VarEnv a -> Bool
    `elemVarEnv` VarEnv (Id, [CoreTickish])
    ind_env)      -- Only if not already substituted for
        then
            if Id -> Bool
    hasShortableIdInfo Id
    exported_id
            then Bool
    True       -- See Note [Messing up the exported Id's RULES]
            else Bool -> String -> SDoc -> Bool -> Bool
    forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
    warnPprTrace Bool
    True String
    "Not shorting out" (Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    exported_id) Bool
    False
        else
            Bool
    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 RULES]
    hasShortableIdInfo :: Id -> Bool
    hasShortableIdInfo Id
    id
      =  RuleInfo -> Bool
    isEmptyRuleInfo (IdInfo -> RuleInfo
    ruleInfo IdInfo
    info)
      Bool -> Bool -> Bool
    && InlinePragma -> Bool
    isDefaultInlinePragma (IdInfo -> InlinePragma
    inlinePragInfo IdInfo
    info)
      Bool -> Bool -> Bool
    && Bool -> Bool
    not (Unfolding -> Bool
    isStableUnfolding (IdInfo -> Unfolding
    realUnfoldingInfo IdInfo
    info))
      where
         info :: IdInfo
    info = HasDebugCallStack => Id -> IdInfo
    Id -> IdInfo
    idInfo Id
    id

    {- 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, specifically
    * (Stable) unfolding
    * Strictness
    * Rules
    * Inline pragma

    Overwriting, rather than merging, seems to work ok.

    For the lcl_id we

    * Zap the InlinePragma. It might originally have had a NOINLINE, which
      we have now transferred; and we really want the lcl_id to inline now
      that its RHS is trivial!

    * Zap any Stable unfolding.  agian, we want lcl_id = gbl_id to inline,
      replacing lcl_id by gbl_id. That won't happen if lcl_id has its original
      great big Stable unfolding
    -}

    transferIdInfo :: Id -> Id -> (Id, Id)
    -- See Note [Transferring IdInfo]
    transferIdInfo :: Id -> Id -> (Id, Id)
    transferIdInfo Id
    exported_id Id
    local_id
      = ( HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
    (IdInfo -> IdInfo) -> Id -> Id
    modifyIdInfo IdInfo -> IdInfo
    transfer Id
    exported_id
        , HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id
    (IdInfo -> IdInfo) -> Id -> Id
    modifyIdInfo IdInfo -> IdInfo
    zap_info Id
    local_id )
      where
        local_info :: IdInfo
    local_info = HasDebugCallStack => Id -> IdInfo
    Id -> IdInfo
    idInfo Id
    local_id
        transfer :: IdInfo -> IdInfo
    transfer IdInfo
    exp_info = IdInfo
    exp_info IdInfo -> DmdSig -> IdInfo
    `setDmdSigInfo`     IdInfo -> DmdSig
    dmdSigInfo IdInfo
    local_info
                                     IdInfo -> CprSig -> IdInfo
    `setCprSigInfo`     IdInfo -> CprSig
    cprSigInfo IdInfo
    local_info
                                     IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  IdInfo -> Unfolding
    realUnfoldingInfo IdInfo
    local_info
                                     IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` IdInfo -> InlinePragma
    inlinePragInfo IdInfo
    local_info
                                     IdInfo -> RuleInfo -> IdInfo
    `setRuleInfo`       RuleInfo -> RuleInfo -> RuleInfo
    addRuleInfo (IdInfo -> RuleInfo
    ruleInfo IdInfo
    exp_info) RuleInfo
    new_info
        new_info :: RuleInfo
    new_info = Name -> RuleInfo -> RuleInfo
    setRuleInfoHead (Id -> Name
    idName Id
    exported_id)
                                   (IdInfo -> RuleInfo
    ruleInfo IdInfo
    local_info)
            -- Remember to set the function-name field of the
            -- rules as we transfer them from one function to another

        zap_info :: IdInfo -> IdInfo
    zap_info IdInfo
    lcl_info = IdInfo
    lcl_info IdInfo -> InlinePragma -> IdInfo
    `setInlinePragInfo` InlinePragma
    defaultInlinePragma
                                     IdInfo -> Unfolding -> IdInfo
    `setUnfoldingInfo`  Unfolding
    noUnfolding