{-# LANGUAGE CPP #-}
module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
import GHC.Driver.Env
import GHC.Platform.Ways  ( hasWay, Way(WayProf) )
import GHC.Core
import GHC.Core.Opt.CSE  ( cseProgram )
import GHC.Core.Rules   ( mkRuleBase,
                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,
                          getRules, initRuleOpts )
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, dumpIdInfoOfProgram )
import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,
                          lintAnnots )
import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplImpRules )
import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Monad
import GHC.Core.Opt.Monad
import GHC.Core.Opt.FloatIn      ( floatInwards )
import GHC.Core.Opt.FloatOut     ( floatOutwards )
import GHC.Core.Opt.LiberateCase ( liberateCase )
import GHC.Core.Opt.StaticArgs   ( doStaticArgs )
import GHC.Core.Opt.Specialise   ( specProgram)
import GHC.Core.Opt.SpecConstr   ( specConstrProgram)
import GHC.Core.Opt.DmdAnal
import GHC.Core.Opt.CprAnal      ( cprAnalProgram )
import GHC.Core.Opt.CallArity    ( callArityAnalProgram )
import GHC.Core.Opt.Exitify      ( exitifyProgram )
import GHC.Core.Opt.WorkWrap     ( wwTopBinds )
import GHC.Core.Opt.CallerCC     ( addCallerCostCentres )
import GHC.Core.LateCC           (addLateCostCentresMG)
import GHC.Core.Seq (seqBinds)
import GHC.Core.FamInstEnv
import GHC.Utils.Error  ( withTiming )
import GHC.Utils.Logger as Logger
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Trace
import GHC.Unit.External
import GHC.Unit.Module.Env
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.Deps
import GHC.Runtime.Context
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Basic
import GHC.Types.Demand ( zapDmdEnvSig )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Tickish
import GHC.Types.Unique.FM
import GHC.Types.Name.Ppr
import Control.Monad
import qualified GHC.LanguageExtensions as LangExt
import GHC.Unit.Module
core2core :: HscEnv -> ModGuts -> IO ModGuts
core2core :: HscEnv -> ModGuts -> IO ModGuts
core2core HscEnv
hsc_env guts :: ModGuts
guts@(ModGuts { mg_module :: ModGuts -> Module
mg_module  = Module
mod
                                , mg_loc :: ModGuts -> SrcSpan
mg_loc     = SrcSpan
loc
                                , mg_deps :: ModGuts -> Dependencies
mg_deps    = Dependencies
deps
                                , mg_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env })
  = do { let builtin_passes :: [CoreToDo]
builtin_passes = Logger -> DynFlags -> [CoreToDo]
getCoreToDo Logger
logger DynFlags
dflags
             orph_mods :: ModuleSet
orph_mods = [Module] -> ModuleSet
mkModuleSet (Module
mod Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: Dependencies -> [Module]
dep_orphs Dependencies
deps)
             uniq_mask :: Char
uniq_mask = Char
's'
       ;
       ; (ModGuts
guts2, SimplCount
stats) <- HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM ModGuts
-> IO (ModGuts, SimplCount)
forall a.
HscEnv
-> RuleBase
-> Char
-> Module
-> ModuleSet
-> PrintUnqualified
-> SrcSpan
-> CoreM a
-> IO (a, SimplCount)
runCoreM HscEnv
hsc_env RuleBase
hpt_rule_base Char
uniq_mask Module
mod
                                    ModuleSet
orph_mods PrintUnqualified
print_unqual SrcSpan
loc (CoreM ModGuts -> IO (ModGuts, SimplCount))
-> CoreM ModGuts -> IO (ModGuts, SimplCount)
forall a b. (a -> b) -> a -> b
$
                           do { HscEnv
hsc_env' <- CoreM HscEnv
getHscEnv
                              ; [CoreToDo]
all_passes <- Plugins
-> PluginOperation CoreM [CoreToDo]
-> [CoreToDo]
-> CoreM [CoreToDo]
forall (m :: * -> *) a.
Monad m =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env')
                                                PluginOperation CoreM [CoreToDo]
installCoreToDos
                                                [CoreToDo]
builtin_passes
                              ; [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
all_passes ModGuts
guts }
       ; Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_simpl_stats
             String
"Grand total simplifier statistics"
             DumpFormat
FormatText
             (SimplCount -> SDoc
pprSimplCount SimplCount
stats)
       ; ModGuts -> IO ModGuts
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts2 }
  where
    logger :: Logger
logger         = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    dflags :: DynFlags
dflags         = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    home_pkg_rules :: [CoreRule]
home_pkg_rules = HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]
hptRules HscEnv
hsc_env (Module -> UnitId
moduleUnitId Module
mod) (GWIB { gwib_mod :: ModuleName
gwib_mod = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod
                                                               , gwib_isBoot :: IsBootInterface
gwib_isBoot = IsBootInterface
NotBoot })
    hpt_rule_base :: RuleBase
hpt_rule_base  = [CoreRule] -> RuleBase
mkRuleBase [CoreRule]
home_pkg_rules
    print_unqual :: PrintUnqualified
print_unqual   = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) GlobalRdrEnv
rdr_env
    
    
    
    
    
getCoreToDo :: Logger -> DynFlags -> [CoreToDo]
getCoreToDo :: Logger -> DynFlags -> [CoreToDo]
getCoreToDo Logger
logger DynFlags
dflags
  = [CoreToDo] -> [CoreToDo]
flatten_todos [CoreToDo]
core_todo
  where
    phases :: Int
phases        = DynFlags -> Int
simplPhases        DynFlags
dflags
    max_iter :: Int
max_iter      = DynFlags -> Int
maxSimplIterations DynFlags
dflags
    rule_check :: Maybe String
rule_check    = DynFlags -> Maybe String
ruleCheck          DynFlags
dflags
    const_fold :: Bool
const_fold    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CoreConstantFolding          DynFlags
dflags
    call_arity :: Bool
call_arity    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CallArity                    DynFlags
dflags
    exitification :: Bool
exitification = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Exitification                DynFlags
dflags
    strictness :: Bool
strictness    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Strictness                   DynFlags
dflags
    full_laziness :: Bool
full_laziness = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_FullLaziness                 DynFlags
dflags
    do_specialise :: Bool
do_specialise = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Specialise                   DynFlags
dflags
    do_float_in :: Bool
do_float_in   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_FloatIn                      DynFlags
dflags
    cse :: Bool
cse           = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CSE                          DynFlags
dflags
    spec_constr :: Bool
spec_constr   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SpecConstr                   DynFlags
dflags
    liberate_case :: Bool
liberate_case = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LiberateCase                 DynFlags
dflags
    late_dmd_anal :: Bool
late_dmd_anal = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LateDmdAnal                  DynFlags
dflags
    late_specialise :: Bool
late_specialise = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_LateSpecialise             DynFlags
dflags
    static_args :: Bool
static_args   = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_StaticArgumentTransformation DynFlags
dflags
    rules_on :: Bool
rules_on      = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EnableRewriteRules           DynFlags
dflags
    eta_expand_on :: Bool
eta_expand_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DoLambdaEtaExpansion         DynFlags
dflags
    pre_inline_on :: Bool
pre_inline_on = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SimplPreInlining             DynFlags
dflags
    ww_on :: Bool
ww_on         = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WorkerWrapper                DynFlags
dflags
    static_ptrs :: Bool
static_ptrs   = Extension -> DynFlags -> Bool
xopt Extension
LangExt.StaticPointers           DynFlags
dflags
    profiling :: Bool
profiling     = DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasWay` Way
WayProf
    do_presimplify :: Bool
do_presimplify = Bool
do_specialise 
    do_simpl3 :: Bool
do_simpl3      = Bool
const_fold Bool -> Bool -> Bool
|| Bool
rules_on 
    maybe_rule_check :: CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
phase = Maybe String -> (String -> CoreToDo) -> CoreToDo
forall a. Maybe a -> (a -> CoreToDo) -> CoreToDo
runMaybe Maybe String
rule_check (CompilerPhase -> String -> CoreToDo
CoreDoRuleCheck CompilerPhase
phase)
    maybe_strictness_before :: CompilerPhase -> CoreToDo
maybe_strictness_before (Phase Int
phase)
      | Int
phase Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> [Int]
strictnessBefore DynFlags
dflags = CoreToDo
CoreDoDemand
    maybe_strictness_before CompilerPhase
_
      = CoreToDo
CoreDoNothing
    base_mode :: SimplMode
base_mode = SimplMode { sm_phase :: CompilerPhase
sm_phase        = String -> CompilerPhase
forall a. String -> a
panic String
"base_mode"
                          , sm_names :: [String]
sm_names        = []
                          , sm_dflags :: DynFlags
sm_dflags       = DynFlags
dflags
                          , sm_logger :: Logger
sm_logger       = Logger
logger
                          , sm_uf_opts :: UnfoldingOpts
sm_uf_opts      = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
                          , sm_rules :: Bool
sm_rules        = Bool
rules_on
                          , sm_eta_expand :: Bool
sm_eta_expand   = Bool
eta_expand_on
                          , sm_cast_swizzle :: Bool
sm_cast_swizzle = Bool
True
                          , sm_inline :: Bool
sm_inline       = Bool
True
                          , sm_case_case :: Bool
sm_case_case    = Bool
True
                          , sm_pre_inline :: Bool
sm_pre_inline   = Bool
pre_inline_on
                          }
    simpl_phase :: CompilerPhase -> String -> Int -> CoreToDo
simpl_phase CompilerPhase
phase String
name Int
iter
      = [CoreToDo] -> CoreToDo
CoreDoPasses
      ([CoreToDo] -> CoreToDo) -> [CoreToDo] -> CoreToDo
forall a b. (a -> b) -> a -> b
$   [ CompilerPhase -> CoreToDo
maybe_strictness_before CompilerPhase
phase
          , Int -> SimplMode -> CoreToDo
CoreDoSimplify Int
iter
                (SimplMode
base_mode { sm_phase :: CompilerPhase
sm_phase = CompilerPhase
phase
                           , sm_names :: [String]
sm_names = [String
name] })
          , CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
phase ]
    
    
    simplify :: String -> CoreToDo
simplify String
name = CompilerPhase -> String -> Int -> CoreToDo
simpl_phase CompilerPhase
FinalPhase String
name Int
max_iter
    
    simpl_gently :: CoreToDo
simpl_gently = Int -> SimplMode -> CoreToDo
CoreDoSimplify Int
max_iter
                       (SimplMode
base_mode { sm_phase :: CompilerPhase
sm_phase = CompilerPhase
InitialPhase
                                  , sm_names :: [String]
sm_names = [String
"Gentle"]
                                  , sm_rules :: Bool
sm_rules = Bool
rules_on   
                                  , sm_inline :: Bool
sm_inline = Bool
True
                                              
                                  , sm_case_case :: Bool
sm_case_case = Bool
False })
                          
                          
    dmd_cpr_ww :: [CoreToDo]
dmd_cpr_ww = if Bool
ww_on then [CoreToDo
CoreDoDemand,CoreToDo
CoreDoCpr,CoreToDo
CoreDoWorkerWrapper]
                          else [CoreToDo
CoreDoDemand,CoreToDo
CoreDoCpr]
    demand_analyser :: CoreToDo
demand_analyser = ([CoreToDo] -> CoreToDo
CoreDoPasses (
                           [CoreToDo]
dmd_cpr_ww [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++
                           [String -> CoreToDo
simplify String
"post-worker-wrapper"]
                           ))
    
    
    static_ptrs_float_outwards :: CoreToDo
static_ptrs_float_outwards =
      Bool -> CoreToDo -> CoreToDo
runWhen Bool
static_ptrs (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
        [ CoreToDo
simpl_gently 
                       
        , FloatOutSwitches -> CoreToDo
CoreDoFloatOutwards FloatOutSwitches
          { floatOutLambdas :: Maybe Int
floatOutLambdas   = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
          , floatOutConstants :: Bool
floatOutConstants = Bool
True
          , floatOutOverSatApps :: Bool
floatOutOverSatApps = Bool
False
          , floatToTopLevelOnly :: Bool
floatToTopLevelOnly = Bool
True
          }
        ]
    add_caller_ccs :: CoreToDo
add_caller_ccs =
        Bool -> CoreToDo -> CoreToDo
runWhen (Bool
profiling Bool -> Bool -> Bool
&& Bool -> Bool
not ([CallerCcFilter] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([CallerCcFilter] -> Bool) -> [CallerCcFilter] -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> [CallerCcFilter]
callerCcFilters DynFlags
dflags)) CoreToDo
CoreAddCallerCcs
    add_late_ccs :: CoreToDo
add_late_ccs =
        Bool -> CoreToDo -> CoreToDo
runWhen (Bool
profiling Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateInlineCcs DynFlags
dflags) (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ CoreToDo
CoreAddLateCcs
    core_todo :: [CoreToDo]
core_todo =
     [
    
    
    
    
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
static_args ([CoreToDo] -> CoreToDo
CoreDoPasses [ CoreToDo
simpl_gently, CoreToDo
CoreDoStaticArgs ]),
        
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_presimplify CoreToDo
simpl_gently,
        
        
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_specialise CoreToDo
CoreDoSpecialising,
        if Bool
full_laziness then
           FloatOutSwitches -> CoreToDo
CoreDoFloatOutwards FloatOutSwitches {
                                 floatOutLambdas :: Maybe Int
floatOutLambdas   = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0,
                                 floatOutConstants :: Bool
floatOutConstants = Bool
True,
                                 floatOutOverSatApps :: Bool
floatOutOverSatApps = Bool
False,
                                 floatToTopLevelOnly :: Bool
floatToTopLevelOnly = Bool
False }
                
                
                
                
                
                
                
                
                
                
                
                
                
                
                
                
                
        else
           
           
           
           CoreToDo
static_ptrs_float_outwards,
        
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_simpl3
            ([CoreToDo] -> CoreToDo
CoreDoPasses ([CoreToDo] -> CoreToDo) -> [CoreToDo] -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [ CompilerPhase -> String -> Int -> CoreToDo
simpl_phase (Int -> CompilerPhase
Phase Int
phase) String
"main" Int
max_iter
                            | Int
phase <- [Int
phases, Int
phasesInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 .. Int
1] ] [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++
                            [ CompilerPhase -> String -> Int -> CoreToDo
simpl_phase (Int -> CompilerPhase
Phase Int
0) String
"main" (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
max_iter Int
3) ]),
                
                
                
                
                
                
                
                
                
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_float_in CoreToDo
CoreDoFloatInwards,
            
            
            
            
            
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
call_arity (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
            [ CoreToDo
CoreDoCallArity
            , String -> CoreToDo
simplify String
"post-call-arity"
            ],
        
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
strictness CoreToDo
demand_analyser,
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
exitification CoreToDo
CoreDoExitify,
            
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
full_laziness (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$
           FloatOutSwitches -> CoreToDo
CoreDoFloatOutwards FloatOutSwitches {
                                 floatOutLambdas :: Maybe Int
floatOutLambdas     = DynFlags -> Maybe Int
floatLamArgs DynFlags
dflags,
                                 floatOutConstants :: Bool
floatOutConstants   = Bool
True,
                                 floatOutOverSatApps :: Bool
floatOutOverSatApps = Bool
True,
                                 floatToTopLevelOnly :: Bool
floatToTopLevelOnly = Bool
False },
                
                
                
                
                
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
cse CoreToDo
CoreCSE,
                
                
                
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
do_float_in CoreToDo
CoreDoFloatInwards,
        String -> CoreToDo
simplify String
"final",  
        CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,
        
        
                
                
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
liberate_case (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
           [ CoreToDo
CoreLiberateCase, String -> CoreToDo
simplify String
"post-liberate-case" ],
           
           
           
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
spec_constr (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
           [ CoreToDo
CoreDoSpecConstr, String -> CoreToDo
simplify String
"post-spec-constr"],
           
        CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
late_specialise (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
           [ CoreToDo
CoreDoSpecialising, String -> CoreToDo
simplify String
"post-late-spec"],
        
        
        
        
        Bool -> CoreToDo -> CoreToDo
runWhen ((Bool
liberate_case Bool -> Bool -> Bool
|| Bool
spec_constr) Bool -> Bool -> Bool
&& Bool
cse) (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses
           [ CoreToDo
CoreCSE, String -> CoreToDo
simplify String
"post-final-cse" ],
        
        Bool -> CoreToDo -> CoreToDo
runWhen Bool
late_dmd_anal (CoreToDo -> CoreToDo) -> CoreToDo -> CoreToDo
forall a b. (a -> b) -> a -> b
$ [CoreToDo] -> CoreToDo
CoreDoPasses (
            [CoreToDo]
dmd_cpr_ww [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [String -> CoreToDo
simplify String
"post-late-ww"]
          ),
        
        
        
        
        
        Bool -> CoreToDo -> CoreToDo
runWhen (Bool
strictness Bool -> Bool -> Bool
|| Bool
late_dmd_anal) CoreToDo
CoreDoDemand,
        CompilerPhase -> CoreToDo
maybe_rule_check CompilerPhase
FinalPhase,
        CoreToDo
add_caller_ccs,
        CoreToDo
add_late_ccs
     ]
    
    flatten_todos :: [CoreToDo] -> [CoreToDo]
flatten_todos [] = []
    flatten_todos (CoreToDo
CoreDoNothing : [CoreToDo]
rest) = [CoreToDo] -> [CoreToDo]
flatten_todos [CoreToDo]
rest
    flatten_todos (CoreDoPasses [CoreToDo]
passes : [CoreToDo]
rest) =
      [CoreToDo] -> [CoreToDo]
flatten_todos [CoreToDo]
passes [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [CoreToDo] -> [CoreToDo]
flatten_todos [CoreToDo]
rest
    flatten_todos (CoreToDo
todo : [CoreToDo]
rest) = CoreToDo
todo CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: [CoreToDo] -> [CoreToDo]
flatten_todos [CoreToDo]
rest
runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
passes ModGuts
guts
  = (ModGuts -> CoreToDo -> CoreM ModGuts)
-> ModGuts -> [CoreToDo] -> CoreM ModGuts
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ModGuts -> CoreToDo -> CoreM ModGuts
do_pass ModGuts
guts [CoreToDo]
passes
  where
    do_pass :: ModGuts -> CoreToDo -> CoreM ModGuts
do_pass ModGuts
guts CoreToDo
CoreDoNothing = ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
    do_pass ModGuts
guts (CoreDoPasses [CoreToDo]
ps) = [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
ps ModGuts
guts
    do_pass ModGuts
guts CoreToDo
pass = do
      Logger
logger <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
      Logger -> SDoc -> (ModGuts -> ()) -> CoreM ModGuts -> CoreM ModGuts
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod))
                   (() -> ModGuts -> ()
forall a b. a -> b -> a
const ()) (CoreM ModGuts -> CoreM ModGuts) -> CoreM ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ do
            ModGuts
guts' <- SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
lintAnnots (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass) (CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass CoreToDo
pass) ModGuts
guts
            CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass CoreToDo
pass (ModGuts -> CoreProgram
mg_binds ModGuts
guts') (ModGuts -> [CoreRule]
mg_rules ModGuts
guts')
            ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts'
    mod :: Module
mod = ModGuts -> Module
mg_module ModGuts
guts
doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
doCorePass CoreToDo
pass ModGuts
guts = do
  Logger
logger    <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  DynFlags
dflags    <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  UniqSupply
us        <- CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
  PackageFamInstEnv
p_fam_env <- CoreM PackageFamInstEnv
getPackageFamInstEnv
  let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
  let fam_envs :: (PackageFamInstEnv, PackageFamInstEnv)
fam_envs = (PackageFamInstEnv
p_fam_env, ModGuts -> PackageFamInstEnv
mg_fam_inst_env ModGuts
guts)
  let updateBinds :: (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds  CoreProgram -> CoreProgram
f = ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ ModGuts
guts { mg_binds :: CoreProgram
mg_binds = CoreProgram -> CoreProgram
f (ModGuts -> CoreProgram
mg_binds ModGuts
guts) }
  let updateBindsM :: (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM CoreProgram -> CoreM CoreProgram
f = CoreProgram -> CoreM CoreProgram
f (ModGuts -> CoreProgram
mg_binds ModGuts
guts) CoreM CoreProgram
-> (CoreProgram -> CoreM ModGuts) -> CoreM ModGuts
forall a b. CoreM a -> (a -> CoreM b) -> CoreM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CoreProgram
b' -> ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ ModGuts
guts { mg_binds :: CoreProgram
mg_binds = CoreProgram
b' }
  case CoreToDo
pass of
    CoreDoSimplify {}         -> {-# SCC "Simplify" #-}
                                 CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm CoreToDo
pass ModGuts
guts
    CoreToDo
CoreCSE                   -> {-# SCC "CommonSubExpr" #-}
                                 (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds CoreProgram -> CoreProgram
cseProgram
    CoreToDo
CoreLiberateCase          -> {-# SCC "LiberateCase" #-}
                                 (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds (DynFlags -> CoreProgram -> CoreProgram
liberateCase DynFlags
dflags)
    CoreToDo
CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}
                                 (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds (Platform -> CoreProgram -> CoreProgram
floatInwards Platform
platform)
    CoreDoFloatOutwards FloatOutSwitches
f     -> {-# SCC "FloatOutwards" #-}
                                 (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM (IO CoreProgram -> CoreM CoreProgram
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CoreProgram -> CoreM CoreProgram)
-> (CoreProgram -> IO CoreProgram)
-> CoreProgram
-> CoreM CoreProgram
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger
-> FloatOutSwitches -> UniqSupply -> CoreProgram -> IO CoreProgram
floatOutwards Logger
logger FloatOutSwitches
f UniqSupply
us)
    CoreToDo
CoreDoStaticArgs          -> {-# SCC "StaticArgs" #-}
                                 (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds (UniqSupply -> CoreProgram -> CoreProgram
doStaticArgs UniqSupply
us)
    CoreToDo
CoreDoCallArity           -> {-# SCC "CallArity" #-}
                                 (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds CoreProgram -> CoreProgram
callArityAnalProgram
    CoreToDo
CoreDoExitify             -> {-# SCC "Exitify" #-}
                                 (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds CoreProgram -> CoreProgram
exitifyProgram
    CoreToDo
CoreDoDemand              -> {-# SCC "DmdAnal" #-}
                                 (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM (IO CoreProgram -> CoreM CoreProgram
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CoreProgram -> CoreM CoreProgram)
-> (CoreProgram -> IO CoreProgram)
-> CoreProgram
-> CoreM CoreProgram
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger
-> DynFlags
-> (PackageFamInstEnv, PackageFamInstEnv)
-> [CoreRule]
-> CoreProgram
-> IO CoreProgram
dmdAnal Logger
logger DynFlags
dflags (PackageFamInstEnv, PackageFamInstEnv)
fam_envs (ModGuts -> [CoreRule]
mg_rules ModGuts
guts))
    CoreToDo
CoreDoCpr                 -> {-# SCC "CprAnal" #-}
                                 (CoreProgram -> CoreM CoreProgram) -> CoreM ModGuts
updateBindsM (IO CoreProgram -> CoreM CoreProgram
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CoreProgram -> CoreM CoreProgram)
-> (CoreProgram -> IO CoreProgram)
-> CoreProgram
-> CoreM CoreProgram
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger
-> (PackageFamInstEnv, PackageFamInstEnv)
-> CoreProgram
-> IO CoreProgram
cprAnalProgram Logger
logger (PackageFamInstEnv, PackageFamInstEnv)
fam_envs)
    CoreToDo
CoreDoWorkerWrapper       -> {-# SCC "WorkWrap" #-}
                                 (CoreProgram -> CoreProgram) -> CoreM ModGuts
updateBinds (Module
-> DynFlags
-> (PackageFamInstEnv, PackageFamInstEnv)
-> UniqSupply
-> CoreProgram
-> CoreProgram
wwTopBinds (ModGuts -> Module
mg_module ModGuts
guts) DynFlags
dflags (PackageFamInstEnv, PackageFamInstEnv)
fam_envs UniqSupply
us)
    CoreToDo
CoreDoSpecialising        -> {-# SCC "Specialise" #-}
                                 ModGuts -> CoreM ModGuts
specProgram ModGuts
guts
    CoreToDo
CoreDoSpecConstr          -> {-# SCC "SpecConstr" #-}
                                 ModGuts -> CoreM ModGuts
specConstrProgram ModGuts
guts
    CoreToDo
CoreAddCallerCcs          -> {-# SCC "AddCallerCcs" #-}
                                 ModGuts -> CoreM ModGuts
addCallerCostCentres ModGuts
guts
    CoreToDo
CoreAddLateCcs            -> {-# SCC "AddLateCcs" #-}
                                 ModGuts -> CoreM ModGuts
addLateCostCentresMG ModGuts
guts
    CoreToDo
CoreDoPrintCore           -> {-# SCC "PrintCore" #-}
                                 IO ModGuts -> CoreM ModGuts
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> CoreM ModGuts) -> IO ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ Logger -> CoreProgram -> IO ()
printCore Logger
logger (ModGuts -> CoreProgram
mg_binds ModGuts
guts) IO () -> IO ModGuts -> IO ModGuts
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ModGuts -> IO ModGuts
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
    CoreDoRuleCheck CompilerPhase
phase String
pat -> {-# SCC "RuleCheck" #-}
                                 CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass CompilerPhase
phase String
pat ModGuts
guts
    CoreToDo
CoreDoNothing             -> ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
    CoreDoPasses [CoreToDo]
passes       -> [CoreToDo] -> ModGuts -> CoreM ModGuts
runCorePasses [CoreToDo]
passes ModGuts
guts
    CoreDoPluginPass String
_ ModGuts -> CoreM ModGuts
p      -> {-# SCC "Plugin" #-} ModGuts -> CoreM ModGuts
p ModGuts
guts
    CoreToDo
CoreDesugar               -> String -> SDoc -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
    CoreToDo
CoreDesugarOpt            -> String -> SDoc -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
    CoreToDo
CoreTidy                  -> String -> SDoc -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
    CoreToDo
CorePrep                  -> String -> SDoc -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
    CoreToDo
CoreOccurAnal             -> String -> SDoc -> CoreM ModGuts
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doCorePass" (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
pass)
printCore :: Logger -> CoreProgram -> IO ()
printCore :: Logger -> CoreProgram -> IO ()
printCore Logger
logger CoreProgram
binds
    = Logger -> String -> SDoc -> IO ()
Logger.logDumpMsg Logger
logger String
"Print Core" (CoreProgram -> SDoc
forall b. OutputableBndr b => [Bind b] -> SDoc
pprCoreBindings CoreProgram
binds)
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass CompilerPhase
current_phase String
pat ModGuts
guts = do
    DynFlags
dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- CoreM Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
    Logger -> SDoc -> (ModGuts -> ()) -> CoreM ModGuts -> CoreM ModGuts
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
text String
"RuleCheck"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> SDoc) -> Module -> SDoc
forall a b. (a -> b) -> a -> b
$ ModGuts -> Module
mg_module ModGuts
guts))
                (() -> ModGuts -> ()
forall a b. a -> b -> a
const ()) (CoreM ModGuts -> CoreM ModGuts) -> CoreM ModGuts -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$ do
        RuleBase
rb <- CoreM RuleBase
getRuleBase
        ModuleSet
vis_orphs <- CoreM ModuleSet
getVisibleOrphanMods
        let rule_fn :: Id -> [CoreRule]
rule_fn Id
fn = RuleEnv -> Id -> [CoreRule]
getRules ([RuleBase] -> ModuleSet -> RuleEnv
RuleEnv [RuleBase
rb] ModuleSet
vis_orphs) Id
fn
                          [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ (ModGuts -> [CoreRule]
mg_rules ModGuts
guts)
        let ropts :: RuleOpts
ropts = DynFlags -> RuleOpts
initRuleOpts DynFlags
dflags
        IO () -> CoreM ()
forall a. IO a -> CoreM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> CoreM ()) -> IO () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ Logger -> String -> SDoc -> IO ()
logDumpMsg Logger
logger String
"Rule check"
                     (RuleOpts
-> CompilerPhase
-> String
-> (Id -> [CoreRule])
-> CoreProgram
-> SDoc
ruleCheckProgram RuleOpts
ropts CompilerPhase
current_phase String
pat
                        Id -> [CoreRule]
rule_fn (ModGuts -> CoreProgram
mg_binds ModGuts
guts))
        ModGuts -> CoreM ModGuts
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts
simplifyExpr :: HscEnv 
             -> CoreExpr
             -> IO CoreExpr
simplifyExpr :: HscEnv -> CoreExpr -> IO CoreExpr
simplifyExpr HscEnv
hsc_env 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
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 <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env ;
        ; let fi_env :: (PackageFamInstEnv, PackageFamInstEnv)
fi_env    = ( 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
$
                            (InstEnv, [FamInst]) -> [FamInst]
forall a b. (a, b) -> b
snd ((InstEnv, [FamInst]) -> [FamInst])
-> (InstEnv, [FamInst]) -> [FamInst]
forall a b. (a -> b) -> a -> b
$ InteractiveContext -> (InstEnv, [FamInst])
ic_instances (InteractiveContext -> (InstEnv, [FamInst]))
-> InteractiveContext -> (InstEnv, [FamInst])
forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env )
              simpl_env :: SimplEnv
simpl_env = Logger -> DynFlags -> SimplEnv
simplEnvForGHCi Logger
logger DynFlags
dflags
        ; let sz :: Int
sz = CoreExpr -> Int
exprSize CoreExpr
expr
        ; (CoreExpr
expr', SimplCount
counts) <- Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (PackageFamInstEnv, PackageFamInstEnv)
-> Int
-> SimplM CoreExpr
-> IO (CoreExpr, SimplCount)
forall a.
Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (PackageFamInstEnv, PackageFamInstEnv)
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl Logger
logger DynFlags
dflags (ExternalPackageState -> RuleBase
eps_rule_base (ExternalPackageState -> RuleBase)
-> IO ExternalPackageState -> IO RuleBase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env) RuleEnv
emptyRuleEnv (PackageFamInstEnv, PackageFamInstEnv)
fi_env 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'
        }
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
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)
simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
simplifyPgm CoreToDo
pass ModGuts
guts
  = do { HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
       ; RuleBase
rb <- CoreM RuleBase
getRuleBase
       ; IO (SimplCount, ModGuts) -> CoreM ModGuts
forall a. IO (SimplCount, a) -> CoreM a
liftIOWithCount (IO (SimplCount, ModGuts) -> CoreM ModGuts)
-> IO (SimplCount, ModGuts) -> CoreM ModGuts
forall a b. (a -> b) -> a -> b
$
         CoreToDo
-> HscEnv -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts)
simplifyPgmIO CoreToDo
pass HscEnv
hsc_env RuleBase
rb ModGuts
guts }
simplifyPgmIO :: CoreToDo
              -> HscEnv
              -> RuleBase
              -> ModGuts
              -> IO (SimplCount, ModGuts)  
simplifyPgmIO :: CoreToDo
-> HscEnv -> RuleBase -> ModGuts -> IO (SimplCount, ModGuts)
simplifyPgmIO pass :: CoreToDo
pass@(CoreDoSimplify Int
max_iterations SimplMode
mode)
              HscEnv
hsc_env RuleBase
hpt_rule_base
              guts :: ModGuts
guts@(ModGuts { mg_module :: ModGuts -> Module
mg_module = Module
this_mod
                            , mg_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env
                            , mg_deps :: ModGuts -> Dependencies
mg_deps = Dependencies
deps
                            , mg_binds :: ModGuts -> CoreProgram
mg_binds = CoreProgram
binds, mg_rules :: ModGuts -> [CoreRule]
mg_rules = [CoreRule]
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]
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
vcat [String -> SDoc
text String
termination_msg SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"after" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
it_count
                                              SDoc -> SDoc -> SDoc
<+> String -> SDoc
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
    dflags :: DynFlags
dflags       = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    logger :: Logger
logger       = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    print_unqual :: PrintUnqualified
print_unqual = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) GlobalRdrEnv
rdr_env
    simpl_env :: SimplEnv
simpl_env    = SimplMode -> SimplEnv
mkSimplEnv SimplMode
mode
    active_rule :: Activation -> Bool
active_rule  = SimplMode -> Activation -> Bool
activeRule SimplMode
mode
    active_unf :: Id -> Bool
active_unf   = SimplMode -> Id -> Bool
activeUnfolding SimplMode
mode
    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]
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
<> String -> SDoc
text String
", after"
                    SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
max_iterations SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"iterations"
                    SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
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
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
text String
"Size =" SDoc -> SDoc -> SDoc
<+> 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 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 { mg_binds :: CoreProgram
mg_binds = CoreProgram
binds, mg_rules :: [CoreRule]
mg_rules = [CoreRule]
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]
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);
                
                
                
                
                
                
                
                
           ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env ;
           let  { read_eps_rules :: IO RuleBase
read_eps_rules = ExternalPackageState -> RuleBase
eps_rule_base (ExternalPackageState -> RuleBase)
-> IO ExternalPackageState -> IO RuleBase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
                ; rule_base :: RuleBase
rule_base = RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
hpt_rule_base [CoreRule]
rules
                ; fam_envs :: (PackageFamInstEnv, PackageFamInstEnv)
fam_envs = (ExternalPackageState -> PackageFamInstEnv
eps_fam_inst_env ExternalPackageState
eps, PackageFamInstEnv
fam_inst_env)
                ; vis_orphs :: [Module]
vis_orphs = Module
this_mod Module -> [Module] -> [Module]
forall a. a -> [a] -> [a]
: Dependencies -> [Module]
dep_orphs Dependencies
deps } ;
                
           ((CoreProgram
binds1, [CoreRule]
rules1), SimplCount
counts1) <-
             Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (PackageFamInstEnv, PackageFamInstEnv)
-> Int
-> SimplM (CoreProgram, [CoreRule])
-> IO ((CoreProgram, [CoreRule]), SimplCount)
forall a.
Logger
-> DynFlags
-> IO RuleBase
-> RuleEnv
-> (PackageFamInstEnv, PackageFamInstEnv)
-> Int
-> SimplM a
-> IO (a, SimplCount)
initSmpl Logger
logger DynFlags
dflags IO RuleBase
read_eps_rules (RuleBase -> [Module] -> RuleEnv
mkRuleEnv RuleBase
rule_base [Module]
vis_orphs) (PackageFamInstEnv, PackageFamInstEnv)
fam_envs 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
                      
                      
                      
                      
                  ; [CoreRule]
rules1 <- SimplEnv -> [CoreRule] -> SimplM [CoreRule]
simplImpRules SimplEnv
env1 [CoreRule]
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) } ;
                
                
           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)  
                       , ModGuts
guts { mg_binds :: CoreProgram
mg_binds = CoreProgram
binds1, mg_rules :: [CoreRule]
mg_rules = [CoreRule]
rules1 } )
           else do {
                
                
                
                
                
                
                
                
           let { binds2 :: CoreProgram
binds2 = {-# SCC "ZapInd" #-} CoreProgram -> CoreProgram
shortOutIndirections CoreProgram
binds1 } ;
                
           let { dump_core_sizes :: Bool
dump_core_sizes = Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressCoreSizes DynFlags
dflags) } ;
           Logger
-> Bool
-> PrintUnqualified
-> Int
-> SimplCount
-> CoreProgram
-> [CoreRule]
-> IO ()
dump_end_iteration Logger
logger Bool
dump_core_sizes PrintUnqualified
print_unqual Int
iteration_no SimplCount
counts1 CoreProgram
binds2 [CoreRule]
rules1 ;
           HscEnv -> CoreToDo -> CoreProgram -> IO ()
lintPassResult HscEnv
hsc_env CoreToDo
pass CoreProgram
binds2 ;
                
           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
        
        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)
                         (DynFlags -> SimplCount
zeroSimplCount DynFlags
dflags)
simplifyPgmIO CoreToDo
_ HscEnv
_ RuleBase
_ ModGuts
_ = String -> IO (SimplCount, ModGuts)
forall a. String -> a
panic String
"simplifyPgmIO"
dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int
                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
dump_end_iteration :: Logger
-> Bool
-> PrintUnqualified
-> Int
-> SimplCount
-> CoreProgram
-> [CoreRule]
-> IO ()
dump_end_iteration Logger
logger Bool
dump_core_sizes PrintUnqualified
print_unqual Int
iteration_no SimplCount
counts CoreProgram
binds [CoreRule]
rules
  = Logger
-> Bool
-> PrintUnqualified
-> Maybe DumpFlag
-> String
-> SDoc
-> CoreProgram
-> [CoreRule]
-> IO ()
dumpPassResult Logger
logger Bool
dump_core_sizes PrintUnqualified
print_unqual 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
vcat [ String -> SDoc
text String
"---- Simplifier counts for" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
hdr
                     , SimplCount -> SDoc
pprSimplCount SimplCount
counts
                     , String -> SDoc
text String
"---- End of simplifier counts for" SDoc -> SDoc -> SDoc
<+> String -> SDoc
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 key 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 = (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
idInfo Id
id
transferIdInfo :: Id -> Id -> (Id, Id)
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)
        
        
    zap_info :: IdInfo -> IdInfo
zap_info IdInfo
lcl_info = IdInfo
lcl_info IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
defaultInlinePragma
                                 IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo`  Unfolding
noUnfolding
dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
dmdAnal :: Logger
-> DynFlags
-> (PackageFamInstEnv, PackageFamInstEnv)
-> [CoreRule]
-> CoreProgram
-> IO CoreProgram
dmdAnal Logger
logger DynFlags
dflags (PackageFamInstEnv, PackageFamInstEnv)
fam_envs [CoreRule]
rules CoreProgram
binds = do
  let !opts :: DmdAnalOpts
opts = DmdAnalOpts
               { dmd_strict_dicts :: Bool
dmd_strict_dicts    = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DictsStrict DynFlags
dflags
               , dmd_unbox_width :: Int
dmd_unbox_width     = DynFlags -> Int
dmdUnboxWidth DynFlags
dflags
               , dmd_max_worker_args :: Int
dmd_max_worker_args = DynFlags -> Int
maxWorkerArgs DynFlags
dflags
               }
      binds_plus_dmds :: CoreProgram
binds_plus_dmds = DmdAnalOpts
-> (PackageFamInstEnv, PackageFamInstEnv)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
dmdAnalProgram DmdAnalOpts
opts (PackageFamInstEnv, PackageFamInstEnv)
fam_envs [CoreRule]
rules CoreProgram
binds
  Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_str_signatures String
"Strictness signatures" DumpFormat
FormatText (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
    Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram (DynFlags -> Bool
hasPprDebug DynFlags
dflags) (DmdSig -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DmdSig -> SDoc) -> (IdInfo -> DmdSig) -> IdInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DmdSig -> DmdSig
zapDmdEnvSig (DmdSig -> DmdSig) -> (IdInfo -> DmdSig) -> IdInfo -> DmdSig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> DmdSig
dmdSigInfo) CoreProgram
binds_plus_dmds
  
  CoreProgram -> ()
seqBinds CoreProgram
binds_plus_dmds () -> IO CoreProgram -> IO CoreProgram
forall a b. a -> b -> b
`seq` CoreProgram -> IO CoreProgram
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreProgram
binds_plus_dmds