{-# 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 )
import GHC.Core.Opt.Simplify.Inline ( 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_ )
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 :: 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
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)
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)
, SimplifyOpts -> PackageRuleBase
so_hpt_rules :: !RuleBase
, SimplifyOpts -> TopEnvConfig
so_top_env_cfg :: !TopEnvConfig
}
simplifyPgm :: Logger
-> UnitEnv
-> NamePprCtx
-> SimplifyOpts
-> ModGuts
-> IO (SimplCount, ModGuts)
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
!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)
do_iteration :: Int
-> [SimplCount]
-> CoreProgram
-> [CoreRule]
-> 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
| Int
iteration_no Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
max_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
$
(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 bailed 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 } )
| let sz :: Int
sz = CoreProgram -> Int
coreBindsSize CoreProgram
binds
, () <- Int
sz Int -> () -> ()
forall a b. a -> b -> b
`seq` ()
= do {
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);
eps <- UnitEnv -> IO ExternalPackageState
ueEPS UnitEnv
unit_env ;
let {
; !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 } ;
((binds1, rules1), counts1) <-
initSmpl logger read_rule_env top_env_cfg sz $
do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
; rules1 <- simplImpRules env1 local_rules
; return (getTopFloatBinds floats, rules1) } ;
if isZeroSimplCount counts1 then
return ( "Simplifier reached fixed point", iteration_no
, totalise (counts1 : counts_so_far)
, guts_no_binds { mg_binds = binds1, mg_rules = rules1 } )
else do {
let { binds2 = {-# SCC "ZapInd" #-} CoreProgram -> CoreProgram
shortOutIndirections CoreProgram
binds1 } ;
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 ;
do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
} }
where
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
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 ]
type IndEnv = IdEnv (Id, [CoreTickish])
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'
| 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')]
where
ind_env :: VarEnv (Id, [CoreTickish])
ind_env = CoreProgram -> VarEnv (Id, [CoreTickish])
makeIndEnv CoreProgram
binds
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
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
= []
| 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
=
[ (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
= if Id -> Bool
isExportedId Id
exported_id Bool -> Bool -> Bool
&&
Id -> Bool
isLocalId Id
local_id Bool -> Bool -> Bool
&&
Bool -> Bool
not (Id -> Bool
isExportedId Id
local_id) Bool -> Bool -> Bool
&&
Bool -> Bool
not (Id
local_id Id -> VarEnv (Id, [CoreTickish]) -> Bool
forall a. Id -> VarEnv a -> Bool
`elemVarEnv` VarEnv (Id, [CoreTickish])
ind_env)
then
if Id -> Bool
hasShortableIdInfo Id
exported_id
then Bool
True
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
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
transferIdInfo :: Id -> Id -> (Id, Id)
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)
zap_info :: IdInfo -> IdInfo
zap_info IdInfo
lcl_info = IdInfo
lcl_info IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
defaultInlinePragma
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
noUnfolding