-- * Configuration of the core-to-core passes
CoreToDo(..),
SimplifierMode(..),
- SimplifierSwitch(..),
FloatOutSwitches(..),
getCoreToDo, dumpSimplPhase,
-- * Counting
- SimplCount, doSimplTick, doFreeSimplTick,
+ SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
-- * The monad
debugTraceMsg, debugTraceMsgS,
dumpIfSet_dyn,
+ lookupOrigCoreM,
+
#ifdef GHCI
-- * Getting 'Name's
thNameToGhcName
import CoreLint ( lintCoreBindings )
import PrelNames ( iNTERACTIVE )
import HscTypes
-import Module ( PackageId, Module )
+import Module ( Module )
import DynFlags
import StaticFlags
import Rules ( RuleBase )
-import BasicTypes ( CompilerPhase )
+import BasicTypes ( CompilerPhase(..) )
import Annotations
import Id ( Id )
import Maybes
import UniqSupply
import UniqFM ( UniqFM, mapUFM, filterUFM )
-import FiniteMap
+import MonadUtils
import Util ( split )
import Data.List ( intersperse )
import Data.Dynamic
import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Word
import Control.Monad
import Prelude hiding ( read )
+import OccName
+import IfaceEnv
+import Name
+import SrcLoc
+import Control.Exception.Base
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( lookupThName_maybe )
; Err.ghcExit dflags 1 }
| not (isEmptyBag warns)
+ , not (case pass of { CoreDesugar -> True; _ -> False })
+ -- Suppress warnings after desugaring pass because some
+ -- are legitimate. Notably, the desugarer generates instance
+ -- methods with INLINE pragmas that form a mutually recursive
+ -- group. Only afer a round of simplification are they unravelled.
, not opt_NoDebugOutput
, showLintWarnings pass
= printDump (banner "warnings" $$ Err.pprMessageBag warns)
showLintWarnings :: CoreToDo -> Bool
-- Disable Lint warnings on the first simplifier pass, because
-- there may be some INLINE knots still tied, which is tiresomely noisy
-showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
-showLintWarnings _ = True
+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
+showLintWarnings _ = True
\end{code}
-- as many times as you like.
= CoreDoSimplify -- The core-to-core simplifier.
+ Int -- Max iterations
SimplifierMode
- Int -- Max iterations
- [SimplifierSwitch] -- Each run of the simplifier can take a different
- -- set of simplifier-specific flags.
+
| CoreDoFloatInwards
| CoreDoFloatOutwards FloatOutSwitches
| CoreLiberateCase
| CoreCSE
| CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
-- matching this string
- | CoreDoVectorisation PackageId
+ | CoreDoVectorisation
| CoreDoNothing -- Useful when building up
| CoreDoPasses [CoreToDo] -- lists of these things
coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
coreDumpFlag CoreCSE = Just Opt_D_dump_cse
-coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
-coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
-coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
-coreDumpFlag CorePrep = Just Opt_D_dump_prep
+coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect
+coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
+coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep = Just Opt_D_dump_prep
coreDumpFlag CoreDoPrintCore = Nothing
coreDumpFlag (CoreDoRuleCheck {}) = Nothing
coreDumpFlag (CoreDoPasses {}) = Nothing
instance Outputable CoreToDo where
- ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier")
- <+> ppr md
+ ppr (CoreDoSimplify n md) = ptext (sLit "Simplifier")
+ <+> ppr md
<+> ptext (sLit "max-iterations=") <> int n
ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
ppr CoreDoSpecialising = ptext (sLit "Specialise")
ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
ppr CoreCSE = ptext (sLit "Common sub-expression")
- ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
- ppr CoreDesugar = ptext (sLit "Desugar")
- ppr CoreTidy = ptext (sLit "Tidy Core")
+ ppr CoreDoVectorisation = ptext (sLit "Vectorisation")
+ ppr CoreDesugar = ptext (sLit "Desugar")
+ ppr CoreTidy = ptext (sLit "Tidy Core")
ppr CorePrep = ptext (sLit "CorePrep")
ppr CoreDoPrintCore = ptext (sLit "Print core")
ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
\begin{code}
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
+ = SimplMode
+ { sm_names :: [String] -- Name(s) of the phase
+ , sm_phase :: CompilerPhase
+ , sm_rules :: Bool -- Whether RULES are enabled
+ , sm_inline :: Bool -- Whether inlining is enabled
+ , sm_case_case :: Bool -- Whether case-of-case is enabled
+ , sm_eta_expand :: Bool -- Whether eta-expansion is enabled
+ }
instance Outputable SimplifierMode where
- ppr (SimplPhase { sm_num = n, sm_names = ss })
- = ptext (sLit "Phase") <+> 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"))
+ ppr (SimplMode { sm_phase = p, sm_names = ss
+ , sm_rules = r, sm_inline = i
+ , sm_eta_expand = eta, sm_case_case = cc })
+ = ptext (sLit "SimplMode") <+> braces (
+ sep [ ptext (sLit "Phase =") <+> ppr p <+>
+ brackets (text (concat $ intersperse "," ss)) <> comma
+ , pp_flag i (sLit "inline") <> comma
+ , pp_flag r (sLit "rules") <> comma
+ , pp_flag eta (sLit "eta-expand") <> comma
+ , pp_flag cc (sLit "case-of-case") ])
where
pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
-
-data SimplifierSwitch
- = NoCaseOfCase
\end{code}
\begin{code}
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
- }
+ floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if
+ -- doing so will abstract over n or fewer
+ -- value variables
+ -- Nothing <=> float all lambdas to top level,
+ -- regardless of how many free variables
+ -- Just 0 is the vanilla case: float a lambda
+ -- iff it has no free vars
+
+ floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
+ -- even if they do not escape a lambda
+ floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
+ -- based on arity information.
+ }
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
+pprFloatOutSwitches sw
+ = ptext (sLit "FOS") <+> (braces $
+ sep $ punctuate comma $
+ [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw)
+ , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw)
+ , ptext (sLit "PAPs =") <+> ppr (floatOutPartialApplications sw) ])
\end{code}
getCoreToDo dflags
= core_todo
where
- opt_level = optLevel dflags
- phases = simplPhases dflags
+ 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
+ rule_check = ruleCheck 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
static_args = dopt Opt_StaticArgumentTransformation dflags
+ rules_on = dopt Opt_EnableRewriteRules dflags
+ eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags
maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
maybe_strictness_before phase
= runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
+ base_mode = SimplMode { sm_phase = panic "base_mode"
+ , sm_names = []
+ , sm_rules = rules_on
+ , sm_eta_expand = eta_expand_on
+ , sm_inline = True
+ , sm_case_case = True }
+
simpl_phase phase names iter
= CoreDoPasses
- [ maybe_strictness_before phase
- , CoreDoSimplify (SimplPhase phase names)
- iter []
- , maybe_rule_check phase
- ]
+ $ [ maybe_strictness_before phase
+ , CoreDoSimplify iter
+ (base_mode { sm_phase = Phase phase
+ , sm_names = names })
+
+ , maybe_rule_check (Phase phase) ]
+
+ -- Vectorisation can introduce a fair few common sub expressions involving
+ -- DPH primitives. For example, see the Reverse test from dph-examples.
+ -- We need to eliminate these common sub expressions before their definitions
+ -- are inlined in phase 2. The CSE introduces lots of v1 = v2 bindings,
+ -- so we also run simpl_gently to inline them.
+ ++ (if dopt Opt_Vectorise dflags && phase == 3
+ then [CoreCSE, simpl_gently]
+ else [])
vectorisation
- = runWhen (dopt Opt_Vectorise dflags)
- $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ]
-
+ = runWhen (dopt Opt_Vectorise dflags) $
+ CoreDoPasses [ simpl_gently, CoreDoVectorisation ]
-- By default, we have 2 phases before phase 0.
-- 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] ]
+ | phase <- [phases, phases-1 .. 1] ]
-- initial simplify: mk specialiser happy: minimum effort please
- simpl_gently = CoreDoSimplify
- (SimplGently { sm_rules = True, sm_inline = False })
- -- See Note [Gentle mode] and
- -- Note [RULEs enabled in SimplGently] in SimplUtils
- max_iter
- [
-
-
- NoCaseOfCase -- Don't do case-of-case transformations.
- -- This makes full laziness work better
- ]
+ simpl_gently = CoreDoSimplify max_iter
+ (base_mode { sm_phase = InitialPhase
+ , sm_names = ["Gentle"]
+ , sm_rules = rules_on -- Note [RULEs enabled in SimplGently]
+ , sm_inline = False
+ , sm_case_case = False })
+ -- Don't do case-of-case transformations.
+ -- This makes full laziness work better
core_todo =
if opt_level == 0 then
-- so that overloaded functions have all their dictionary lambdas manifest
runWhen do_specialise CoreDoSpecialising,
- runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
+ runWhen full_laziness $
+ CoreDoFloatOutwards FloatOutSwitches {
+ floatOutLambdas = Just 0,
+ floatOutConstants = True,
+ floatOutPartialApplications = False },
-- Was: gentleFloatOutSwitches
- -- I have no idea why, but not floating constants to top level is
- -- very bad in some cases.
+ --
+ -- 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
+ -- Changing from "gentle" to "constantsOnly"
+ -- improved rewrite's allocation by 19%, and
+ -- made 0.0% difference to any other nofib
+ -- benchmark
+ --
+ -- Not doing floatOutPartialApplications yet, we'll do
+ -- that later on when we've had a chance to get more
+ -- accurate arity information. In fact it makes no
+ -- difference at all to performance if we do it here,
+ -- but maybe we save some unnecessary to-and-fro in
+ -- the simplifier.
runWhen do_float_in CoreDoFloatInwards,
simpl_phase 0 ["post-worker-wrapper"] max_iter
]),
- runWhen full_laziness
- (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
+ runWhen full_laziness $
+ CoreDoFloatOutwards FloatOutSwitches {
+ floatOutLambdas = floatLamArgs dflags,
+ floatOutConstants = True,
+ floatOutPartialApplications = True },
-- 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
runWhen do_float_in CoreDoFloatInwards,
- maybe_rule_check 0,
+ maybe_rule_check (Phase 0),
-- Case-liberation for -O2. This should be after
-- strictness analysis and the simplification which follows it.
runWhen spec_constr CoreDoSpecConstr,
- maybe_rule_check 0,
+ maybe_rule_check (Phase 0),
-- Final clean-up simplification:
simpl_phase 0 ["final"] max_iter
_ -> phase_name s
phase_num :: Int -> Bool
- phase_num n = case mode of
- SimplPhase k _ -> n == k
- _ -> False
+ phase_num n = case sm_phase mode of
+ Phase k -> n == k
+ _ -> False
phase_name :: String -> Bool
- phase_name s = case mode of
- SimplGently {} -> s == "gentle"
- SimplPhase { sm_names = ss } -> s `elem` ss
+ phase_name s = s `elem` sm_names mode
\end{code}
+Note [RULEs enabled in SimplGently]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+RULES are enabled when doing "gentle" simplification. Two reasons:
+
+ * We really want the class-op cancellation to happen:
+ op (df d1 d2) --> $cop3 d1 d2
+ because this breaks the mutual recursion between 'op' and 'df'
+
+ * I wanted the RULE
+ lift String ===> ...
+ to work in Template Haskell when simplifying
+ splices, so we get simpler code for literal strings
+
+But watch out: list fusion can prevent floating. So use phase control
+to switch off those rules until after floating.
+
+
%************************************************************************
%* *
Counting and logging
\begin{code}
data SimplCount
- = VerySimplZero -- These two are used when
- | VerySimplNonZero -- we are only interested in
- -- termination info
+ = VerySimplCount !Int -- Used when don't want detailed stats
| SimplCount {
ticks :: !Int, -- Total ticks
-- recent history reasonably efficiently
}
-type TickCounts = FiniteMap Tick Int
+type TickCounts = Map Tick Int
+
+simplCountN :: SimplCount -> Int
+simplCountN (VerySimplCount n) = n
+simplCountN (SimplCount { ticks = n }) = n
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,
+ = SimplCount {ticks = 0, details = Map.empty,
n_log = 0, log1 = [], log2 = []}
| otherwise
- = VerySimplZero
+ = VerySimplCount 0
-isZeroSimplCount VerySimplZero = True
-isZeroSimplCount (SimplCount { ticks = 0 }) = True
-isZeroSimplCount _ = False
+isZeroSimplCount (VerySimplCount n) = n==0
+isZeroSimplCount (SimplCount { ticks = n }) = n==0
doFreeSimplTick tick sc@SimplCount { details = dts }
= sc { details = dts `addTick` tick }
where
sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
-doSimplTick _ _ = VerySimplNonZero -- The very simple case
+doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
--- Don't use plusFM_C because that's lazy, and we want to
+-- Don't use Map.unionWith 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
+addTick fm tick = case Map.lookup tick fm of
+ Nothing -> Map.insert tick 1 fm
+ Just n -> n1 `seq` Map.insert tick n1 fm
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 }
+ = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) 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
+plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
+plusSimplCount _ _ = panic "plusSimplCount"
+ -- We use one or the other consistently
-pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
-pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
+pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
= vcat [ptext (sLit "Total ticks: ") <+> int tks,
blankLine,
- pprTickCounts (fmToList dts),
+ pprTickCounts (Map.toList dts),
if verboseSimplStats then
vcat [blankLine,
ptext (sLit "Log (most recent first)"),
liftIO $ initTcForLookup hsc_env (lookupThName_maybe th_name)
#endif
\end{code}
+
+\begin{code}
+updNameCache' :: (NameCache -> (NameCache, a)) -> CoreM a
+updNameCache' upd_fn = do
+ HscEnv { hsc_NC = nc_var } <- getHscEnv
+ r <- liftIO $ atomicModifyIORef nc_var upd_fn
+ r' <- liftIO $ readIORef nc_var
+ _ <- liftIO $ evaluate r'
+ return r
+
+-- cut-and-pasted from IfaceEnv, where it lives in the TcRn monad rather than CoreM
+lookupOrigCoreM :: Module -> OccName -> CoreM Name
+lookupOrigCoreM mod occ
+ = do { mod `seq` occ `seq` return ()
+ ; updNameCache' $ \name_cache ->
+ case lookupOrigNameCache (nsNames name_cache) mod occ of {
+ Just name -> (name_cache, name);
+ Nothing ->
+ case takeUniqFromSupply (nsUniqs name_cache) of {
+ (uniq, us) ->
+ let
+ name = mkExternalName uniq mod occ noSrcSpan
+ new_cache = extendNameCache (nsNames name_cache) mod occ name
+ in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
+ }}}
+\end{code}
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff