This patch moves a lot of code around, but has zero functionality change.
The idea is that the types
CoreToDo
SimplifierSwitch
SimplifierMode
FloatOutSwitches
and
the main core-to-core pipeline construction
belong in simplCore/, and *not* in DynFlags.
-- ** DynFlag C compiler options
machdepCCOpts, picCCOpts,
- -- * Configuration of the core-to-core passes
- CoreToDo(..),
- SimplifierMode(..),
- SimplifierSwitch(..),
- FloatOutSwitches(..),
- getCoreToDo,
-
-- * Configuration of the stg-to-stg passes
StgToDo(..),
getStgToDo,
import SrcLoc
import FastString
import FiniteMap
-import BasicTypes ( CompilerPhase )
import Outputable
import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
data DynFlags = DynFlags {
ghcMode :: GhcMode,
ghcLink :: GhcLink,
- coreToDo :: Maybe [CoreToDo], -- reserved for -Ofile
- stgToDo :: Maybe [StgToDo], -- similarly
hscTarget :: HscTarget,
hscOutName :: String, -- ^ Name of the output file
extCoreName :: String, -- ^ Name of the .hcr output file
optLevel :: Int, -- ^ Optimisation level
simplPhases :: Int, -- ^ Number of simplifier phases
maxSimplIterations :: Int, -- ^ Max simplifier iterations
- shouldDumpSimplPhase :: SimplifierMode -> Bool,
+ shouldDumpSimplPhase :: Maybe String,
ruleCheck :: Maybe String,
strictnessBefore :: [Int], -- ^ Additional demand analysis
DynFlags {
ghcMode = CompManager,
ghcLink = LinkBinary,
- coreToDo = Nothing,
- stgToDo = Nothing,
hscTarget = defaultHscTarget,
hscOutName = "",
extCoreName = "",
optLevel = 0,
simplPhases = 2,
maxSimplIterations = 4,
- shouldDumpSimplPhase = const False,
+ shouldDumpSimplPhase = Nothing,
ruleCheck = Nothing,
specConstrThreshold = Just 200,
specConstrCount = Just 3,
]
-- -----------------------------------------------------------------------------
--- CoreToDo: abstraction of core-to-core passes to run.
-
-data CoreToDo -- These are diff core-to-core passes,
- -- which may be invoked in any order,
- -- as many times as you like.
-
- = CoreDoSimplify -- The core-to-core simplifier.
- SimplifierMode
- [SimplifierSwitch]
- -- Each run of the simplifier can take a different
- -- set of simplifier-specific flags.
- | CoreDoFloatInwards
- | CoreDoFloatOutwards FloatOutSwitches
- | CoreLiberateCase
- | CoreDoPrintCore
- | CoreDoStaticArgs
- | CoreDoStrictness
- | CoreDoWorkerWrapper
- | CoreDoSpecialising
- | CoreDoSpecConstr
- | CoreDoOldStrictness
- | CoreDoGlomBinds
- | CoreCSE
- | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
- -- matching this string
- | CoreDoVectorisation PackageId
- | CoreDoNothing -- Useful when building up
- | CoreDoPasses [CoreToDo] -- lists of these things
-
-
-data SimplifierMode -- See comments in SimplMonad
- = SimplGently
- { sm_rules :: Bool -- Whether RULES are enabled
- , sm_inline :: Bool } -- Whether inlining is enabled
-
- | SimplPhase
- { sm_num :: Int -- Phase number; counts downward so 0 is last phase
- , sm_names :: [String] } -- Name(s) of the phase
-
-instance Outputable SimplifierMode where
- ppr (SimplPhase { sm_num = n, sm_names = ss })
- = int n <+> brackets (text (concat $ intersperse "," ss))
- ppr (SimplGently { sm_rules = r, sm_inline = i })
- = ptext (sLit "gentle") <>
- brackets (pp_flag r (sLit "rules") <> comma <>
- pp_flag i (sLit "inline"))
- where
- pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
-
-data SimplifierSwitch
- = MaxSimplifierIterations Int
- | NoCaseOfCase
-
-data FloatOutSwitches = FloatOutSwitches {
- floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
- floatOutConstants :: Bool -- ^ True <=> float constants to top level,
- -- even if they do not escape a lambda
- }
-
-instance Outputable FloatOutSwitches where
- ppr = pprFloatOutSwitches
-
-pprFloatOutSwitches :: FloatOutSwitches -> SDoc
-pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
- <+> pp_not (floatOutConstants sw) <+> text "constants"
- where
- pp_not True = empty
- pp_not False = text "not"
-
--- | Switches that specify the minimum amount of floating out
--- gentleFloatOutSwitches :: FloatOutSwitches
--- gentleFloatOutSwitches = FloatOutSwitches False False
-
--- | Switches that do not specify floating out of lambdas, just of constants
-constantsOnlyFloatOutSwitches :: FloatOutSwitches
-constantsOnlyFloatOutSwitches = FloatOutSwitches False True
-
-
--- The core-to-core pass ordering is derived from the DynFlags:
-runWhen :: Bool -> CoreToDo -> CoreToDo
-runWhen True do_this = do_this
-runWhen False _ = CoreDoNothing
-
-runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
-runMaybe (Just x) f = f x
-runMaybe Nothing _ = CoreDoNothing
-
-getCoreToDo :: DynFlags -> [CoreToDo]
-getCoreToDo dflags
- | Just todo <- coreToDo dflags = todo -- set explicitly by user
- | otherwise = core_todo
- where
- opt_level = optLevel dflags
- phases = simplPhases dflags
- max_iter = maxSimplIterations dflags
- strictness = dopt Opt_Strictness dflags
- full_laziness = dopt Opt_FullLaziness dflags
- do_specialise = dopt Opt_Specialise dflags
- do_float_in = dopt Opt_FloatIn dflags
- cse = dopt Opt_CSE dflags
- spec_constr = dopt Opt_SpecConstr dflags
- liberate_case = dopt Opt_LiberateCase dflags
- rule_check = ruleCheck dflags
- static_args = dopt Opt_StaticArgumentTransformation dflags
-
- maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
-
- maybe_strictness_before phase
- = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
-
- simpl_phase phase names iter
- = CoreDoPasses
- [ maybe_strictness_before phase,
- CoreDoSimplify (SimplPhase phase names) [
- MaxSimplifierIterations iter
- ],
- maybe_rule_check phase
- ]
-
- vectorisation
- = runWhen (dopt Opt_Vectorise dflags)
- $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
-
-
- -- By default, we have 2 phases before phase 0.
-
- -- Want to run with inline phase 2 after the specialiser to give
- -- maximum chance for fusion to work before we inline build/augment
- -- in phase 1. This made a difference in 'ansi' where an
- -- overloaded function wasn't inlined till too late.
-
- -- Need phase 1 so that build/augment get
- -- inlined. I found that spectral/hartel/genfft lost some useful
- -- strictness in the function sumcode' if augment is not inlined
- -- before strictness analysis runs
- simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
- | phase <- [phases, phases-1 .. 1] ]
-
-
- -- initial simplify: mk specialiser happy: minimum effort please
- simpl_gently = CoreDoSimplify
- (SimplGently { sm_rules = True, sm_inline = False })
- [
- -- Simplify "gently"
- -- Don't inline anything till full laziness has bitten
- -- In particular, inlining wrappers inhibits floating
- -- e.g. ...(case f x of ...)...
- -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
- -- ==> ...(case x of I# x# -> case fw x# of ...)...
- -- and now the redex (f x) isn't floatable any more
- -- Similarly, don't apply any rules until after full
- -- laziness. Notably, list fusion can prevent floating.
-
- NoCaseOfCase, -- Don't do case-of-case transformations.
- -- This makes full laziness work better
- MaxSimplifierIterations max_iter
- ]
-
- core_todo =
- if opt_level == 0 then
- [vectorisation,
- simpl_phase 0 ["final"] max_iter]
- else {- opt_level >= 1 -} [
-
- -- We want to do the static argument transform before full laziness as it
- -- may expose extra opportunities to float things outwards. However, to fix
- -- up the output of the transformation we need at do at least one simplify
- -- after this before anything else
- runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
-
- -- We run vectorisation here for now, but we might also try to run
- -- it later
- vectorisation,
-
- -- initial simplify: mk specialiser happy: minimum effort please
- simpl_gently,
-
- -- Specialisation is best done before full laziness
- -- so that overloaded functions have all their dictionary lambdas manifest
- runWhen do_specialise CoreDoSpecialising,
-
- runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
- -- Was: gentleFloatOutSwitches
- -- I have no idea why, but not floating constants to top level is
- -- very bad in some cases.
- -- Notably: p_ident in spectral/rewrite
- -- Changing from "gentle" to "constantsOnly" improved
- -- rewrite's allocation by 19%, and made 0.0% difference
- -- to any other nofib benchmark
-
- runWhen do_float_in CoreDoFloatInwards,
-
- simpl_phases,
-
- -- Phase 0: allow all Ids to be inlined now
- -- This gets foldr inlined before strictness analysis
-
- -- At least 3 iterations because otherwise we land up with
- -- huge dead expressions because of an infelicity in the
- -- simpifier.
- -- let k = BIG in foldr k z xs
- -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
- -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
- -- Don't stop now!
- simpl_phase 0 ["main"] (max max_iter 3),
-
- runWhen strictness (CoreDoPasses [
- CoreDoStrictness,
- CoreDoWorkerWrapper,
- CoreDoGlomBinds,
- simpl_phase 0 ["post-worker-wrapper"] max_iter
- ]),
-
- runWhen full_laziness
- (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
- -- nofib/spectral/hartel/wang doubles in speed if you
- -- do full laziness late in the day. It only happens
- -- after fusion and other stuff, so the early pass doesn't
- -- catch it. For the record, the redex is
- -- f_el22 (f_el21 r_midblock)
-
-
- runWhen cse CoreCSE,
- -- We want CSE to follow the final full-laziness pass, because it may
- -- succeed in commoning up things floated out by full laziness.
- -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
-
- runWhen do_float_in CoreDoFloatInwards,
-
- maybe_rule_check 0,
-
- -- Case-liberation for -O2. This should be after
- -- strictness analysis and the simplification which follows it.
- runWhen liberate_case (CoreDoPasses [
- CoreLiberateCase,
- simpl_phase 0 ["post-liberate-case"] max_iter
- ]), -- Run the simplifier after LiberateCase to vastly
- -- reduce the possiblility of shadowing
- -- Reason: see Note [Shadowing] in SpecConstr.lhs
-
- runWhen spec_constr CoreDoSpecConstr,
-
- maybe_rule_check 0,
-
- -- Final clean-up simplification:
- simpl_phase 0 ["final"] max_iter
- ]
-
--- -----------------------------------------------------------------------------
-- StgToDo: abstraction of stg-to-stg passes to run.
data StgToDo
getStgToDo :: DynFlags -> [StgToDo]
getStgToDo dflags
- | Just todo <- stgToDo dflags = todo -- set explicitly by user
- | otherwise = todo2
+ = todo2
where
stg_stats = dopt Opt_StgStats dflags
force_recomp dfs = isOneShot (ghcMode dfs)
setVerboseCore2Core :: DynP ()
-setVerboseCore2Core = do setDynFlag Opt_D_verbose_core2core
- forceRecompile
- upd (\s -> s { shouldDumpSimplPhase = const True })
+setVerboseCore2Core = do forceRecompile
+ setDynFlag Opt_D_verbose_core2core
+ upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing })
+
setDumpSimplPhases :: String -> DynP ()
setDumpSimplPhases s = do forceRecompile
- upd (\s -> s { shouldDumpSimplPhase = spec })
+ upd (\dfs -> dfs { shouldDumpSimplPhase = Just spec })
where
- spec :: SimplifierMode -> Bool
- spec = join (||)
- . map (join (&&) . map match . split ':')
- . split ','
- $ case s of
- '=' : s' -> s'
- _ -> s
-
- join :: (Bool -> Bool -> Bool)
- -> [SimplifierMode -> Bool]
- -> SimplifierMode -> Bool
- join _ [] = const True
- join op ss = foldr1 (\f g x -> f x `op` g x) ss
-
- match :: String -> SimplifierMode -> Bool
- match "" = const True
- match s = case reads s of
- [(n,"")] -> phase_num n
- _ -> phase_name s
-
- phase_num :: Int -> SimplifierMode -> Bool
- phase_num n (SimplPhase k _) = n == k
- phase_num _ _ = False
-
- phase_name :: String -> SimplifierMode -> Bool
- phase_name s (SimplGently {}) = s == "gentle"
- phase_name s (SimplPhase { sm_names = ss }) = s `elem` ss
+ spec = case s of { ('=' : s') -> s'; _ -> s }
setVerbosity :: Maybe Int -> DynP ()
setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })
{-# LANGUAGE UndecidableInstances #-}
module CoreMonad (
+ -- * Configuration of the core-to-core passes
+ CoreToDo(..),
+ SimplifierMode(..),
+ SimplifierSwitch(..),
+ FloatOutSwitches(..),
+ getCoreToDo, dumpSimplPhase,
+
+ -- * Counting
+ SimplCount, doSimplTick, doFreeSimplTick,
+ pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
+
-- * The monad
CoreM, runCoreM,
import CoreLint ( lintCoreBindings )
import PrelNames ( iNTERACTIVE )
import HscTypes
-import Module ( Module )
-import DynFlags ( DynFlags, DynFlag )
-import SimplMonad ( SimplCount, plusSimplCount, zeroSimplCount )
+import Module ( PackageId, Module )
+import DynFlags
+import StaticFlags
import Rules ( RuleBase )
+import BasicTypes ( CompilerPhase )
import Annotations
+import Id ( Id )
import IOEnv hiding ( liftIO, failM, failWithM )
import qualified IOEnv ( liftIO )
import Maybes
import UniqSupply
import LazyUniqFM ( UniqFM, mapUFM, filterUFM )
+import FiniteMap
+import Util ( split )
+import Data.List ( intersperse )
import Data.Dynamic
import Data.IORef
import Data.Word
%************************************************************************
%* *
+ The CoreToDo type and related types
+ Abstraction of core-to-core passes to run.
+%* *
+%************************************************************************
+
+\begin{code}
+data CoreToDo -- These are diff core-to-core passes,
+ -- which may be invoked in any order,
+ -- as many times as you like.
+
+ = CoreDoSimplify -- The core-to-core simplifier.
+ SimplifierMode
+ [SimplifierSwitch]
+ -- Each run of the simplifier can take a different
+ -- set of simplifier-specific flags.
+ | CoreDoFloatInwards
+ | CoreDoFloatOutwards FloatOutSwitches
+ | CoreLiberateCase
+ | CoreDoPrintCore
+ | CoreDoStaticArgs
+ | CoreDoStrictness
+ | CoreDoWorkerWrapper
+ | CoreDoSpecialising
+ | CoreDoSpecConstr
+ | CoreDoOldStrictness
+ | CoreDoGlomBinds
+ | CoreCSE
+ | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
+ -- matching this string
+ | CoreDoVectorisation PackageId
+ | CoreDoNothing -- Useful when building up
+ | CoreDoPasses [CoreToDo] -- lists of these things
+
+
+data SimplifierMode -- See comments in SimplMonad
+ = SimplGently
+ { sm_rules :: Bool -- Whether RULES are enabled
+ , sm_inline :: Bool } -- Whether inlining is enabled
+
+ | SimplPhase
+ { sm_num :: Int -- Phase number; counts downward so 0 is last phase
+ , sm_names :: [String] } -- Name(s) of the phase
+
+instance Outputable SimplifierMode where
+ ppr (SimplPhase { sm_num = n, sm_names = ss })
+ = int n <+> brackets (text (concat $ intersperse "," ss))
+ ppr (SimplGently { sm_rules = r, sm_inline = i })
+ = ptext (sLit "gentle") <>
+ brackets (pp_flag r (sLit "rules") <> comma <>
+ pp_flag i (sLit "inline"))
+ where
+ pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
+
+data SimplifierSwitch
+ = MaxSimplifierIterations Int
+ | NoCaseOfCase
+
+data FloatOutSwitches = FloatOutSwitches {
+ floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
+ floatOutConstants :: Bool -- ^ True <=> float constants to top level,
+ -- even if they do not escape a lambda
+ }
+
+instance Outputable FloatOutSwitches where
+ ppr = pprFloatOutSwitches
+
+pprFloatOutSwitches :: FloatOutSwitches -> SDoc
+pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma
+ <+> pp_not (floatOutConstants sw) <+> text "constants"
+ where
+ pp_not True = empty
+ pp_not False = text "not"
+
+-- | Switches that specify the minimum amount of floating out
+-- gentleFloatOutSwitches :: FloatOutSwitches
+-- gentleFloatOutSwitches = FloatOutSwitches False False
+
+-- | Switches that do not specify floating out of lambdas, just of constants
+constantsOnlyFloatOutSwitches :: FloatOutSwitches
+constantsOnlyFloatOutSwitches = FloatOutSwitches False True
+\end{code}
+
+
+%************************************************************************
+%* *
+ Generating the main optimisation pipeline
+%* *
+%************************************************************************
+
+\begin{code}
+getCoreToDo :: DynFlags -> [CoreToDo]
+getCoreToDo dflags
+ = core_todo
+ where
+ opt_level = optLevel dflags
+ phases = simplPhases dflags
+ max_iter = maxSimplIterations dflags
+ strictness = dopt Opt_Strictness dflags
+ full_laziness = dopt Opt_FullLaziness dflags
+ do_specialise = dopt Opt_Specialise dflags
+ do_float_in = dopt Opt_FloatIn dflags
+ cse = dopt Opt_CSE dflags
+ spec_constr = dopt Opt_SpecConstr dflags
+ liberate_case = dopt Opt_LiberateCase dflags
+ rule_check = ruleCheck dflags
+ static_args = dopt Opt_StaticArgumentTransformation dflags
+
+ maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
+
+ maybe_strictness_before phase
+ = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
+
+ simpl_phase phase names iter
+ = CoreDoPasses
+ [ maybe_strictness_before phase,
+ CoreDoSimplify (SimplPhase phase names) [
+ MaxSimplifierIterations iter
+ ],
+ maybe_rule_check phase
+ ]
+
+ vectorisation
+ = runWhen (dopt Opt_Vectorise dflags)
+ $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
+
+
+ -- By default, we have 2 phases before phase 0.
+
+ -- Want to run with inline phase 2 after the specialiser to give
+ -- maximum chance for fusion to work before we inline build/augment
+ -- in phase 1. This made a difference in 'ansi' where an
+ -- overloaded function wasn't inlined till too late.
+
+ -- Need phase 1 so that build/augment get
+ -- inlined. I found that spectral/hartel/genfft lost some useful
+ -- strictness in the function sumcode' if augment is not inlined
+ -- before strictness analysis runs
+ simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
+ | phase <- [phases, phases-1 .. 1] ]
+
+
+ -- initial simplify: mk specialiser happy: minimum effort please
+ simpl_gently = CoreDoSimplify
+ (SimplGently { sm_rules = True, sm_inline = False })
+ [
+ -- Simplify "gently"
+ -- Don't inline anything till full laziness has bitten
+ -- In particular, inlining wrappers inhibits floating
+ -- e.g. ...(case f x of ...)...
+ -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
+ -- ==> ...(case x of I# x# -> case fw x# of ...)...
+ -- and now the redex (f x) isn't floatable any more
+ -- Similarly, don't apply any rules until after full
+ -- laziness. Notably, list fusion can prevent floating.
+
+ NoCaseOfCase, -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
+ MaxSimplifierIterations max_iter
+ ]
+
+ core_todo =
+ if opt_level == 0 then
+ [vectorisation,
+ simpl_phase 0 ["final"] max_iter]
+ else {- opt_level >= 1 -} [
+
+ -- We want to do the static argument transform before full laziness as it
+ -- may expose extra opportunities to float things outwards. However, to fix
+ -- up the output of the transformation we need at do at least one simplify
+ -- after this before anything else
+ runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
+
+ -- We run vectorisation here for now, but we might also try to run
+ -- it later
+ vectorisation,
+
+ -- initial simplify: mk specialiser happy: minimum effort please
+ simpl_gently,
+
+ -- Specialisation is best done before full laziness
+ -- so that overloaded functions have all their dictionary lambdas manifest
+ runWhen do_specialise CoreDoSpecialising,
+
+ runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
+ -- Was: gentleFloatOutSwitches
+ -- I have no idea why, but not floating constants to top level is
+ -- very bad in some cases.
+ -- Notably: p_ident in spectral/rewrite
+ -- Changing from "gentle" to "constantsOnly" improved
+ -- rewrite's allocation by 19%, and made 0.0% difference
+ -- to any other nofib benchmark
+
+ runWhen do_float_in CoreDoFloatInwards,
+
+ simpl_phases,
+
+ -- Phase 0: allow all Ids to be inlined now
+ -- This gets foldr inlined before strictness analysis
+
+ -- At least 3 iterations because otherwise we land up with
+ -- huge dead expressions because of an infelicity in the
+ -- simpifier.
+ -- let k = BIG in foldr k z xs
+ -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs
+ -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
+ -- Don't stop now!
+ simpl_phase 0 ["main"] (max max_iter 3),
+
+ runWhen strictness (CoreDoPasses [
+ CoreDoStrictness,
+ CoreDoWorkerWrapper,
+ CoreDoGlomBinds,
+ simpl_phase 0 ["post-worker-wrapper"] max_iter
+ ]),
+
+ runWhen full_laziness
+ (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
+ -- nofib/spectral/hartel/wang doubles in speed if you
+ -- do full laziness late in the day. It only happens
+ -- after fusion and other stuff, so the early pass doesn't
+ -- catch it. For the record, the redex is
+ -- f_el22 (f_el21 r_midblock)
+
+
+ runWhen cse CoreCSE,
+ -- We want CSE to follow the final full-laziness pass, because it may
+ -- succeed in commoning up things floated out by full laziness.
+ -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
+
+ runWhen do_float_in CoreDoFloatInwards,
+
+ maybe_rule_check 0,
+
+ -- Case-liberation for -O2. This should be after
+ -- strictness analysis and the simplification which follows it.
+ runWhen liberate_case (CoreDoPasses [
+ CoreLiberateCase,
+ simpl_phase 0 ["post-liberate-case"] max_iter
+ ]), -- Run the simplifier after LiberateCase to vastly
+ -- reduce the possiblility of shadowing
+ -- Reason: see Note [Shadowing] in SpecConstr.lhs
+
+ runWhen spec_constr CoreDoSpecConstr,
+
+ maybe_rule_check 0,
+
+ -- Final clean-up simplification:
+ simpl_phase 0 ["final"] max_iter
+ ]
+
+-- The core-to-core pass ordering is derived from the DynFlags:
+runWhen :: Bool -> CoreToDo -> CoreToDo
+runWhen True do_this = do_this
+runWhen False _ = CoreDoNothing
+
+runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
+runMaybe (Just x) f = f x
+runMaybe Nothing _ = CoreDoNothing
+
+dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool
+dumpSimplPhase dflags mode
+ | Just spec_string <- shouldDumpSimplPhase dflags
+ = match_spec spec_string
+ | otherwise
+ = dopt Opt_D_verbose_core2core dflags
+
+ where
+ match_spec :: String -> Bool
+ match_spec spec_string
+ = or $ map (and . map match . split ':')
+ $ split ',' spec_string
+
+ match :: String -> Bool
+ match "" = True
+ match s = case reads s of
+ [(n,"")] -> phase_num n
+ _ -> phase_name s
+
+ phase_num :: Int -> Bool
+ phase_num n = case mode of
+ SimplPhase k _ -> n == k
+ _ -> False
+
+ phase_name :: String -> Bool
+ phase_name s = case mode of
+ SimplGently {} -> s == "gentle"
+ SimplPhase { sm_names = ss } -> s `elem` ss
+\end{code}
+
+
+%************************************************************************
+%* *
+ Counting and logging
+%* *
+%************************************************************************
+
+\begin{code}
+verboseSimplStats :: Bool
+verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
+
+zeroSimplCount :: DynFlags -> SimplCount
+isZeroSimplCount :: SimplCount -> Bool
+pprSimplCount :: SimplCount -> SDoc
+doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount
+plusSimplCount :: SimplCount -> SimplCount -> SimplCount
+\end{code}
+
+\begin{code}
+data SimplCount
+ = VerySimplZero -- These two are used when
+ | VerySimplNonZero -- we are only interested in
+ -- termination info
+
+ | SimplCount {
+ ticks :: !Int, -- Total ticks
+ details :: !TickCounts, -- How many of each type
+
+ n_log :: !Int, -- N
+ log1 :: [Tick], -- Last N events; <= opt_HistorySize,
+ -- most recent first
+ log2 :: [Tick] -- Last opt_HistorySize events before that
+ -- Having log1, log2 lets us accumulate the
+ -- recent history reasonably efficiently
+ }
+
+type TickCounts = FiniteMap Tick Int
+
+zeroSimplCount dflags
+ -- This is where we decide whether to do
+ -- the VerySimpl version or the full-stats version
+ | dopt Opt_D_dump_simpl_stats dflags
+ = SimplCount {ticks = 0, details = emptyFM,
+ n_log = 0, log1 = [], log2 = []}
+ | otherwise
+ = VerySimplZero
+
+isZeroSimplCount VerySimplZero = True
+isZeroSimplCount (SimplCount { ticks = 0 }) = True
+isZeroSimplCount _ = False
+
+doFreeSimplTick tick sc@SimplCount { details = dts }
+ = sc { details = dts `addTick` tick }
+doFreeSimplTick _ sc = sc
+
+doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
+ | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
+ | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
+ where
+ sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
+
+doSimplTick _ _ = VerySimplNonZero -- The very simple case
+
+
+-- Don't use plusFM_C because that's lazy, and we want to
+-- be pretty strict here!
+addTick :: TickCounts -> Tick -> TickCounts
+addTick fm tick = case lookupFM fm tick of
+ Nothing -> addToFM fm tick 1
+ Just n -> n1 `seq` addToFM fm tick n1
+ where
+ n1 = n+1
+
+
+plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
+ sc2@(SimplCount { ticks = tks2, details = dts2 })
+ = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
+ where
+ -- A hackish way of getting recent log info
+ log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
+ | null (log2 sc2) = sc2 { log2 = log1 sc1 }
+ | otherwise = sc2
+
+plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
+plusSimplCount _ _ = VerySimplNonZero
+
+pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
+pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
+pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
+ = vcat [ptext (sLit "Total ticks: ") <+> int tks,
+ blankLine,
+ pprTickCounts (fmToList dts),
+ if verboseSimplStats then
+ vcat [blankLine,
+ ptext (sLit "Log (most recent first)"),
+ nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
+ else empty
+ ]
+
+pprTickCounts :: [(Tick,Int)] -> SDoc
+pprTickCounts [] = empty
+pprTickCounts ((tick1,n1):ticks)
+ = vcat [int tot_n <+> text (tickString tick1),
+ pprTCDetails real_these,
+ pprTickCounts others
+ ]
+ where
+ tick1_tag = tickToTag tick1
+ (these, others) = span same_tick ticks
+ real_these = (tick1,n1):these
+ same_tick (tick2,_) = tickToTag tick2 == tick1_tag
+ tot_n = sum [n | (_,n) <- real_these]
+
+pprTCDetails :: [(Tick, Int)] -> SDoc
+pprTCDetails ticks
+ = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
+\end{code}
+
+
+\begin{code}
+data Tick
+ = PreInlineUnconditionally Id
+ | PostInlineUnconditionally Id
+
+ | UnfoldingDone Id
+ | RuleFired FastString -- Rule name
+
+ | LetFloatFromLet
+ | EtaExpansion Id -- LHS binder
+ | EtaReduction Id -- Binder on outer lambda
+ | BetaReduction Id -- Lambda binder
+
+
+ | CaseOfCase Id -- Bndr on *inner* case
+ | KnownBranch Id -- Case binder
+ | CaseMerge Id -- Binder on outer case
+ | AltMerge Id -- Case binder
+ | CaseElim Id -- Case binder
+ | CaseIdentity Id -- Case binder
+ | FillInCaseDefault Id -- Case binder
+
+ | BottomFound
+ | SimplifierDone -- Ticked at each iteration of the simplifier
+
+instance Outputable Tick where
+ ppr tick = text (tickString tick) <+> pprTickCts tick
+
+instance Eq Tick where
+ a == b = case a `cmpTick` b of
+ EQ -> True
+ _ -> False
+
+instance Ord Tick where
+ compare = cmpTick
+
+tickToTag :: Tick -> Int
+tickToTag (PreInlineUnconditionally _) = 0
+tickToTag (PostInlineUnconditionally _) = 1
+tickToTag (UnfoldingDone _) = 2
+tickToTag (RuleFired _) = 3
+tickToTag LetFloatFromLet = 4
+tickToTag (EtaExpansion _) = 5
+tickToTag (EtaReduction _) = 6
+tickToTag (BetaReduction _) = 7
+tickToTag (CaseOfCase _) = 8
+tickToTag (KnownBranch _) = 9
+tickToTag (CaseMerge _) = 10
+tickToTag (CaseElim _) = 11
+tickToTag (CaseIdentity _) = 12
+tickToTag (FillInCaseDefault _) = 13
+tickToTag BottomFound = 14
+tickToTag SimplifierDone = 16
+tickToTag (AltMerge _) = 17
+
+tickString :: Tick -> String
+tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
+tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
+tickString (UnfoldingDone _) = "UnfoldingDone"
+tickString (RuleFired _) = "RuleFired"
+tickString LetFloatFromLet = "LetFloatFromLet"
+tickString (EtaExpansion _) = "EtaExpansion"
+tickString (EtaReduction _) = "EtaReduction"
+tickString (BetaReduction _) = "BetaReduction"
+tickString (CaseOfCase _) = "CaseOfCase"
+tickString (KnownBranch _) = "KnownBranch"
+tickString (CaseMerge _) = "CaseMerge"
+tickString (AltMerge _) = "AltMerge"
+tickString (CaseElim _) = "CaseElim"
+tickString (CaseIdentity _) = "CaseIdentity"
+tickString (FillInCaseDefault _) = "FillInCaseDefault"
+tickString BottomFound = "BottomFound"
+tickString SimplifierDone = "SimplifierDone"
+
+pprTickCts :: Tick -> SDoc
+pprTickCts (PreInlineUnconditionally v) = ppr v
+pprTickCts (PostInlineUnconditionally v)= ppr v
+pprTickCts (UnfoldingDone v) = ppr v
+pprTickCts (RuleFired v) = ppr v
+pprTickCts LetFloatFromLet = empty
+pprTickCts (EtaExpansion v) = ppr v
+pprTickCts (EtaReduction v) = ppr v
+pprTickCts (BetaReduction v) = ppr v
+pprTickCts (CaseOfCase v) = ppr v
+pprTickCts (KnownBranch v) = ppr v
+pprTickCts (CaseMerge v) = ppr v
+pprTickCts (AltMerge v) = ppr v
+pprTickCts (CaseElim v) = ppr v
+pprTickCts (CaseIdentity v) = ppr v
+pprTickCts (FillInCaseDefault v) = ppr v
+pprTickCts _ = empty
+
+cmpTick :: Tick -> Tick -> Ordering
+cmpTick a b = case (tickToTag a `compare` tickToTag b) of
+ GT -> GT
+ EQ -> cmpEqTick a b
+ LT -> LT
+
+cmpEqTick :: Tick -> Tick -> Ordering
+cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
+cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
+cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
+cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
+cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
+cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
+cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
+cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
+cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
+cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
+cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
+cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
+cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
+cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
+cmpEqTick _ _ = EQ
+\end{code}
+
+
+%************************************************************************
+%* *
Monad and carried data structure definitions
%* *
%************************************************************************
import CoreSyn
import CoreUtils
import CoreArity ( etaExpand )
+import CoreMonad ( FloatOutSwitches(..) )
-import DynFlags ( DynFlags, DynFlag(..), FloatOutSwitches(..) )
+import DynFlags ( DynFlags, DynFlag(..) )
import ErrUtils ( dumpIfSet_dyn )
import CostCentre ( dupifyCC, CostCentre )
import Id ( Id, idType, idArity, isBottomingId )
#include "HsVersions.h"
import CoreSyn
-
-import DynFlags ( FloatOutSwitches(..) )
+import CoreMonad ( FloatOutSwitches(..) )
import CoreUtils ( exprType, mkPiTypes )
import CoreArity ( exprBotStrictness_maybe )
import CoreFVs -- all of it
#include "HsVersions.h"
-import DynFlags ( CoreToDo(..), SimplifierSwitch(..),
- SimplifierMode(..), DynFlags, DynFlag(..), dopt,
- getCoreToDo, shouldDumpSimplPhase )
+import DynFlags ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import CoreSubst
import HscTypes
import CoreMonad
import qualified ErrUtils as Err
import CoreLint
-import CoreMonad ( endPass )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FamInstEnv
}
where
dflags = hsc_dflags hsc_env
- dump_phase = shouldDumpSimplPhase dflags mode
+ dump_phase = dumpSimplPhase dflags mode
sw_chkr = isAmongSimpl switches
max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
#include "HsVersions.h"
import SimplMonad
+import CoreMonad ( SimplifierMode(..) )
import IdInfo
import CoreSyn
import CoreUtils
import Type hiding ( substTy, substTyVarBndr )
import Coercion
import BasicTypes
-import DynFlags
import MonadUtils
import Outputable
import FastString
MonadUnique(..), newId,
-- Counting
- SimplCount, Tick(..),
- tick, freeTick,
+ SimplCount, tick, freeTick,
getSimplCount, zeroSimplCount, pprSimplCount,
plusSimplCount, isZeroSimplCount,
import FamInstEnv ( FamInstEnv )
import Rules ( RuleBase )
import UniqSupply
-import DynFlags ( SimplifierSwitch(..), DynFlags, DynFlag(..), dopt )
-import StaticFlags ( opt_PprStyle_Debug, opt_HistorySize )
+import DynFlags ( DynFlags )
import Maybes ( expectJust )
-import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, plusFM_C, fmToList )
+import CoreMonad
import FastString
import Outputable
import FastTypes
tick :: Tick -> SimplM ()
tick t
- = SM (\_st_env us sc -> let sc' = doTick t sc
+ = SM (\_st_env us sc -> let sc' = doSimplTick t sc
in sc' `seq` ((), us, sc'))
freeTick :: Tick -> SimplM ()
-- Record a tick, but don't add to the total tick count, which is
-- used to decide when nothing further has happened
freeTick t
- = SM (\_st_env us sc -> let sc' = doFreeTick t sc
+ = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
in sc' `seq` ((), us, sc'))
\end{code}
-\begin{code}
-verboseSimplStats :: Bool
-verboseSimplStats = opt_PprStyle_Debug -- For now, anyway
-
-zeroSimplCount :: DynFlags -> SimplCount
-isZeroSimplCount :: SimplCount -> Bool
-pprSimplCount :: SimplCount -> SDoc
-doTick, doFreeTick :: Tick -> SimplCount -> SimplCount
-plusSimplCount :: SimplCount -> SimplCount -> SimplCount
-\end{code}
-
-\begin{code}
-data SimplCount
- = VerySimplZero -- These two are used when
- | VerySimplNonZero -- we are only interested in
- -- termination info
-
- | SimplCount {
- ticks :: !Int, -- Total ticks
- details :: !TickCounts, -- How many of each type
-
- n_log :: !Int, -- N
- log1 :: [Tick], -- Last N events; <= opt_HistorySize,
- -- most recent first
- log2 :: [Tick] -- Last opt_HistorySize events before that
- -- Having log1, log2 lets us accumulate the
- -- recent history reasonably efficiently
- }
-
-type TickCounts = FiniteMap Tick Int
-
-zeroSimplCount dflags
- -- This is where we decide whether to do
- -- the VerySimpl version or the full-stats version
- | dopt Opt_D_dump_simpl_stats dflags
- = SimplCount {ticks = 0, details = emptyFM,
- n_log = 0, log1 = [], log2 = []}
- | otherwise
- = VerySimplZero
-
-isZeroSimplCount VerySimplZero = True
-isZeroSimplCount (SimplCount { ticks = 0 }) = True
-isZeroSimplCount _ = False
-
-doFreeTick tick sc@SimplCount { details = dts }
- = sc { details = dts `addTick` tick }
-doFreeTick _ sc = sc
-
-doTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }
- | nl >= opt_HistorySize = sc1 { n_log = 1, log1 = [tick], log2 = l1 }
- | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }
- where
- sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
-
-doTick _ _ = VerySimplNonZero -- The very simple case
-
-
--- Don't use plusFM_C because that's lazy, and we want to
--- be pretty strict here!
-addTick :: TickCounts -> Tick -> TickCounts
-addTick fm tick = case lookupFM fm tick of
- Nothing -> addToFM fm tick 1
- Just n -> n1 `seq` addToFM fm tick n1
- where
- n1 = n+1
-
-
-plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
- sc2@(SimplCount { ticks = tks2, details = dts2 })
- = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
- where
- -- A hackish way of getting recent log info
- log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
- | null (log2 sc2) = sc2 { log2 = log1 sc1 }
- | otherwise = sc2
-
-plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
-plusSimplCount _ _ = VerySimplNonZero
-
-pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
-pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
-pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
- = vcat [ptext (sLit "Total ticks: ") <+> int tks,
- blankLine,
- pprTickCounts (fmToList dts),
- if verboseSimplStats then
- vcat [blankLine,
- ptext (sLit "Log (most recent first)"),
- nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
- else empty
- ]
-
-pprTickCounts :: [(Tick,Int)] -> SDoc
-pprTickCounts [] = empty
-pprTickCounts ((tick1,n1):ticks)
- = vcat [int tot_n <+> text (tickString tick1),
- pprTCDetails real_these,
- pprTickCounts others
- ]
- where
- tick1_tag = tickToTag tick1
- (these, others) = span same_tick ticks
- real_these = (tick1,n1):these
- same_tick (tick2,_) = tickToTag tick2 == tick1_tag
- tot_n = sum [n | (_,n) <- real_these]
-
-pprTCDetails :: [(Tick, Int)] -> SDoc
-pprTCDetails ticks
- = nest 4 (vcat [int n <+> pprTickCts tick | (tick,n) <- ticks])
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Ticks}
-%* *
-%************************************************************************
-
-\begin{code}
-data Tick
- = PreInlineUnconditionally Id
- | PostInlineUnconditionally Id
-
- | UnfoldingDone Id
- | RuleFired FastString -- Rule name
-
- | LetFloatFromLet
- | EtaExpansion Id -- LHS binder
- | EtaReduction Id -- Binder on outer lambda
- | BetaReduction Id -- Lambda binder
-
-
- | CaseOfCase Id -- Bndr on *inner* case
- | KnownBranch Id -- Case binder
- | CaseMerge Id -- Binder on outer case
- | AltMerge Id -- Case binder
- | CaseElim Id -- Case binder
- | CaseIdentity Id -- Case binder
- | FillInCaseDefault Id -- Case binder
-
- | BottomFound
- | SimplifierDone -- Ticked at each iteration of the simplifier
-
-instance Outputable Tick where
- ppr tick = text (tickString tick) <+> pprTickCts tick
-
-instance Eq Tick where
- a == b = case a `cmpTick` b of
- EQ -> True
- _ -> False
-
-instance Ord Tick where
- compare = cmpTick
-
-tickToTag :: Tick -> Int
-tickToTag (PreInlineUnconditionally _) = 0
-tickToTag (PostInlineUnconditionally _) = 1
-tickToTag (UnfoldingDone _) = 2
-tickToTag (RuleFired _) = 3
-tickToTag LetFloatFromLet = 4
-tickToTag (EtaExpansion _) = 5
-tickToTag (EtaReduction _) = 6
-tickToTag (BetaReduction _) = 7
-tickToTag (CaseOfCase _) = 8
-tickToTag (KnownBranch _) = 9
-tickToTag (CaseMerge _) = 10
-tickToTag (CaseElim _) = 11
-tickToTag (CaseIdentity _) = 12
-tickToTag (FillInCaseDefault _) = 13
-tickToTag BottomFound = 14
-tickToTag SimplifierDone = 16
-tickToTag (AltMerge _) = 17
-
-tickString :: Tick -> String
-tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"
-tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"
-tickString (UnfoldingDone _) = "UnfoldingDone"
-tickString (RuleFired _) = "RuleFired"
-tickString LetFloatFromLet = "LetFloatFromLet"
-tickString (EtaExpansion _) = "EtaExpansion"
-tickString (EtaReduction _) = "EtaReduction"
-tickString (BetaReduction _) = "BetaReduction"
-tickString (CaseOfCase _) = "CaseOfCase"
-tickString (KnownBranch _) = "KnownBranch"
-tickString (CaseMerge _) = "CaseMerge"
-tickString (AltMerge _) = "AltMerge"
-tickString (CaseElim _) = "CaseElim"
-tickString (CaseIdentity _) = "CaseIdentity"
-tickString (FillInCaseDefault _) = "FillInCaseDefault"
-tickString BottomFound = "BottomFound"
-tickString SimplifierDone = "SimplifierDone"
-
-pprTickCts :: Tick -> SDoc
-pprTickCts (PreInlineUnconditionally v) = ppr v
-pprTickCts (PostInlineUnconditionally v)= ppr v
-pprTickCts (UnfoldingDone v) = ppr v
-pprTickCts (RuleFired v) = ppr v
-pprTickCts LetFloatFromLet = empty
-pprTickCts (EtaExpansion v) = ppr v
-pprTickCts (EtaReduction v) = ppr v
-pprTickCts (BetaReduction v) = ppr v
-pprTickCts (CaseOfCase v) = ppr v
-pprTickCts (KnownBranch v) = ppr v
-pprTickCts (CaseMerge v) = ppr v
-pprTickCts (AltMerge v) = ppr v
-pprTickCts (CaseElim v) = ppr v
-pprTickCts (CaseIdentity v) = ppr v
-pprTickCts (FillInCaseDefault v) = ppr v
-pprTickCts _ = empty
-
-cmpTick :: Tick -> Tick -> Ordering
-cmpTick a b = case (tickToTag a `compare` tickToTag b) of
- GT -> GT
- EQ -> cmpEqTick a b
- LT -> LT
-
-cmpEqTick :: Tick -> Tick -> Ordering
-cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b
-cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b
-cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b
-cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b
-cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b
-cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b
-cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b
-cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b
-cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b
-cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b
-cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b
-cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b
-cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b
-cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b
-cmpEqTick _ _ = EQ
-\end{code}
-
%************************************************************************
%* *
#include "HsVersions.h"
import SimplEnv
+import CoreMonad ( SimplifierMode(..), Tick(..) )
import DynFlags
import StaticFlags
import CoreSyn
ActiveBefore {} -> mk_gentle current_mode
ActiveAfter n -> mk_phase n current_mode
where
- no_op = SimplGently { sm_rules = False, sm_inline = False }
+ no_op = SimplGently { sm_rules = False, sm_inline = False }
mk_gentle (SimplGently {}) = current_mode
- mk_gentle _ = SimplGently { sm_rules = True, sm_inline = True }
+ mk_gentle _ = SimplGently { sm_rules = True, sm_inline = True }
- mk_phase n (SimplPhase cp ss)
- | cp > n = no_op -- Current phase earlier than n
- | otherwise = SimplPhase n ss
- mk_phase _ (SimplGently {}) = no_op
+ mk_phase n (SimplPhase _ ss) = SimplPhase n ss
+ mk_phase n (SimplGently {}) = SimplPhase n ["gentle-rules"]
\end{code}
import MkId ( mkImpossibleExpr, seqId )
import Var
import IdInfo
-import Name ( mkSystemVarName )
+import Name ( mkSystemVarName, isExternalName )
import Coercion
import FamInstEnv ( topNormaliseType )
import DataCon ( DataCon, dataConWorkId, dataConRepStrictness )
+import CoreMonad ( SimplifierSwitch(..), Tick(..) )
import CoreSyn
import Demand ( isStrictDmd, splitStrictSig )
import PprCore ( pprParendExpr, pprCoreExpr )
(CoreUnfolding { uf_tmpl = expr, uf_arity = arity
, uf_src = src, uf_guidance = guide })
| isInlineRuleSource src
- = do { expr' <- simplExpr rule_env expr
+ = -- pprTrace "su" (vcat [ppr id, ppr act, ppr (getMode env), ppr (getMode rule_env)]) $
+ do { expr' <- simplExpr rule_env expr
; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst env) src
; return (mkCoreUnfolding (isTopLevel top_lvl) src' expr' arity guide) }
-- See Note [Top-level flag on inline rules] in CoreUnfold
where
- rule_env = updMode (updModeForInlineRules (idInlineActivation id)) env
+ act = idInlineActivation id
+ rule_env = updMode (updModeForInlineRules act) env
-- See Note [Simplifying gently inside InlineRules] in SimplUtils
simplUnfolding _ top_lvl id _occ_info new_rhs _
projects / ghc-hetmet.git / commitdiff