{-# 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_ )

#if __GLASGOW_HASKELL__ <= 810
import GHC.Utils.Panic ( panic )
#endif

{-
************************************************************************
*                                                                      *
        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  { ExternalPackageState
eps <- ExternalUnitCache -> IO ExternalPackageState
eucEPS ExternalUnitCache
euc ;
        ; let fam_envs :: (PackageFamInstEnv, PackageFamInstEnv)
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 :: SimplEnv
simpl_env = SimplMode -> (PackageFamInstEnv, PackageFamInstEnv) -> SimplEnv
mkSimplEnv (SimplifyExprOpts -> SimplMode
se_mode SimplifyExprOpts
opts) (PackageFamInstEnv, PackageFamInstEnv)
fam_envs
              top_env_cfg :: TopEnvConfig
top_env_cfg = SimplifyExprOpts -> TopEnvConfig
se_top_env_cfg SimplifyExprOpts
opts
              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
<$> ExternalUnitCache -> IO ExternalPackageState
eucEPS ExternalUnitCache
euc
              read_ruleenv :: IO RuleEnv
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 :: Int
sz = CoreExpr -> Int
exprSize CoreExpr
expr

        ; (CoreExpr
expr', SimplCount
counts) <- Logger
-> IO RuleEnv
-> TopEnvConfig
-> Int
-> SimplM CoreExpr
-> IO (CoreExpr, SimplCount)
forall a.
Logger
-> IO RuleEnv
-> TopEnvConfig
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl Logger
logger IO RuleEnv
read_ruleenv TopEnvConfig
top_env_cfg Int
sz (SimplM CoreExpr -> IO (CoreExpr, SimplCount))
-> SimplM CoreExpr -> IO (CoreExpr, SimplCount)
forall a b. (a -> b) -> a -> b
$
                             SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExprGently SimplEnv
simpl_env CoreExpr
expr

        ; Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_simpl_stats
                  String
"Simplifier statistics" DumpFormat
FormatText (SimplCount -> SDoc
pprSimplCount SimplCount
counts)

        ; Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_simpl String
"Simplified expression"
                        DumpFormat
FormatCore
                        (CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
expr')

        ; CoreExpr -> IO CoreExpr
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
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
    CoreExpr
expr1 <- SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr SimplEnv
env (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
expr)
    SimplEnv -> CoreExpr -> SimplM CoreExpr
simplExpr SimplEnv
env (CoreExpr -> CoreExpr
occurAnalyseExpr CoreExpr
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 { (String
termination_msg, Int
it_count, SimplCount
counts_out, ModGuts
guts')
            <- Int
-> [SimplCount]
-> CoreProgram
-> [CoreRule]
-> IO (String, Int, SimplCount, ModGuts)
do_iteration Int
1 [] CoreProgram
binds [CoreRule]
local_rules

        ; Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_verbose_core2core
                Bool -> Bool -> Bool
&& Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_simpl_stats) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Logger -> String -> SDoc -> IO ()
logDumpMsg Logger
logger
                  String
"Simplifier statistics for following pass"
                  ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
termination_msg 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 a. Outputable a => a -> SDoc
ppr Int
it_count
                                              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"iterations",
                         SDoc
blankLine,
                         SimplCount -> SDoc
pprSimplCount SimplCount
counts_out])

        ; (SimplCount, ModGuts) -> IO (SimplCount, ModGuts)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplCount
counts_out, ModGuts
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`.
          ExternalPackageState
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
base_rule_env = RuleEnv -> [CoreRule] -> RuleEnv
updLocalRules RuleEnv
hpt_rule_env [CoreRule]
local_rules

                ; read_eps_rules :: IO PackageRuleBase
                ; 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 :: 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 :: (PackageFamInstEnv, PackageFamInstEnv)
fam_envs = (ExternalPackageState -> PackageFamInstEnv
eps_fam_inst_env ExternalPackageState
eps, PackageFamInstEnv
fam_inst_env)
                ; simpl_env :: SimplEnv
simpl_env = SimplMode -> (PackageFamInstEnv, PackageFamInstEnv) -> SimplEnv
mkSimplEnv SimplMode
mode (PackageFamInstEnv, PackageFamInstEnv)
fam_envs } ;

                -- Simplify the program
           ((CoreProgram
binds1, [CoreRule]
rules1), SimplCount
counts1) <-
             Logger
-> IO RuleEnv
-> TopEnvConfig
-> Int
-> SimplM (CoreProgram, [CoreRule])
-> IO ((CoreProgram, [CoreRule]), SimplCount)
forall a.
Logger
-> IO RuleEnv
-> TopEnvConfig
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl Logger
logger IO RuleEnv
read_rule_env TopEnvConfig
top_env_cfg Int
sz (SimplM (CoreProgram, [CoreRule])
 -> IO ((CoreProgram, [CoreRule]), SimplCount))
-> SimplM (CoreProgram, [CoreRule])
-> IO ((CoreProgram, [CoreRule]), SimplCount)
forall a b. (a -> b) -> a -> b
$
               do { (SimplFloats
floats, SimplEnv
env1) <- {-# SCC "SimplTopBinds" #-}
                                      SimplEnv -> CoreProgram -> SimplM (SimplFloats, SimplEnv)
simplTopBinds SimplEnv
simpl_env CoreProgram
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
                  ; [CoreRule]
rules1 <- SimplEnv -> [CoreRule] -> SimplM [CoreRule]
simplImpRules SimplEnv
env1 [CoreRule]
local_rules

                  ; (CoreProgram, [CoreRule]) -> SimplM (CoreProgram, [CoreRule])
forall a. a -> SimplM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimplFloats -> CoreProgram
getTopFloatBinds SimplFloats
floats, [CoreRule]
rules1) } ;

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

                -- Dump the result of this 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
counts1 CoreProgram
binds2 [CoreRule]
rules1 ;

           Maybe LintPassResultConfig
-> (LintPassResultConfig -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (SimplifyOpts -> Maybe LintPassResultConfig
so_pass_result_cfg SimplifyOpts
opts) ((LintPassResultConfig -> IO ()) -> IO ())
-> (LintPassResultConfig -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LintPassResultConfig
pass_result_cfg ->
             Logger -> LintPassResultConfig -> CoreProgram -> IO ()
lintPassResult Logger
logger LintPassResultConfig
pass_result_cfg CoreProgram
binds2 ;

                -- Loop
           Int
-> [SimplCount]
-> CoreProgram
-> [CoreRule]
-> IO (String, Int, SimplCount, ModGuts)
do_iteration (Int
iteration_no Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (SimplCount
counts1SimplCount -> [SimplCount] -> [SimplCount]
forall a. a -> [a] -> [a]
:[SimplCount]
counts_so_far) CoreProgram
binds2 [CoreRule]
rules1
           } }
#if __GLASGOW_HASKELL__ <= 810
      | otherwise = panic "do_iteration"
#endif
      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 key 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 = (() :: Constraint) => 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
  = ( (() :: Constraint) => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo IdInfo -> IdInfo
transfer Id
exported_id
    , (() :: Constraint) => (IdInfo -> IdInfo) -> Id -> Id
(IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo IdInfo -> IdInfo
zap_info Id
local_id )
  where
    local_info :: IdInfo
local_info = (() :: Constraint) => 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