X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCoreMonad.lhs;h=67a0991ec0b43d7518ee46e6776b78b626637b99;hp=ef8c428c8e4c461a4e1030dff31d469ec8f9c6b7;hb=5909e9a896d40a18b4bcf6abb95e0b071bfd7db2;hpb=63e3a41126771e71c44705480c2bde7043a41df3 diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index ef8c428..67a0991 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -10,12 +10,11 @@ module CoreMonad ( -- * 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 @@ -36,13 +35,15 @@ module CoreMonad ( getAnnotations, getFirstAnnotations, -- ** Debug output - endPass, endPassIf, endIteration, + showPass, endPass, endIteration, dumpIfSet, -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, fatalErrorMsg, fatalErrorMsgS, debugTraceMsg, debugTraceMsgS, - dumpIfSet_dyn, + dumpIfSet_dyn, + + lookupOrigCoreM, #ifdef GHCI -- * Getting 'Name's @@ -59,11 +60,11 @@ import CoreUtils 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 ) @@ -75,19 +76,27 @@ import TcRnMonad ( TcM, initTc ) import Outputable import FastString import qualified ErrUtils as Err +import Bag import Maybes import UniqSupply -import LazyUniqFM ( UniqFM, mapUFM, filterUFM ) -import FiniteMap +import UniqFM ( UniqFM, mapUFM, filterUFM ) +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 ) @@ -106,35 +115,85 @@ be, and it makes a conveneint place. place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () -endPass = dumpAndLint Err.dumpIfSet_core +showPass :: DynFlags -> CoreToDo -> IO () +showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass)) -endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () -endPassIf cond = dumpAndLint (Err.dumpIf_core cond) +endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO () +endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass) -- Same as endPass but doesn't dump Core even with -dverbose-core2core -endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () -endIteration = dumpAndLint Err.dumpIfSet_dyn +endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO () +endIteration dflags pass n + = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n) + (Just Opt_D_dump_simpl_iterations) + +dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO () +dumpIfSet dump_me pass extra_info doc + = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc -dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) - -> DynFlags -> String -> DynFlag +dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag -> [CoreBind] -> [CoreRule] -> IO () -dumpAndLint dump dflags pass_name dump_flag binds rules +-- The "show_all" parameter says to print dump if -dverbose-core2core is on +dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules = do { -- Report result size if required -- This has the side effect of forcing the intermediate to be evaluated ; Err.debugTraceMsg dflags 2 $ (text " Result size =" <+> int (coreBindsSize binds)) -- Report verbosely, if required - ; dump dflags dump_flag pass_name - (pprCoreBindings binds $$ ppUnless (null rules) pp_rules) + ; let pass_name = showSDoc (ppr pass <+> extra_info) + dump_doc = pprCoreBindings binds + $$ ppUnless (null rules) pp_rules + + ; case mb_dump_flag of + Nothing -> return () + Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc + where + dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core] + | otherwise = [dump_flag] -- Type check - ; lintCoreBindings dflags pass_name binds } + ; when (dopt Opt_DoCoreLinting dflags) $ + do { let (warns, errs) = lintCoreBindings binds + ; Err.showPass dflags ("Core Linted result of " ++ pass_name) + ; displayLintResults dflags pass warns errs binds } } where pp_rules = vcat [ blankLine , ptext (sLit "------ Local rules for imported ids --------") , pprRules rules ] + +displayLintResults :: DynFlags -> CoreToDo + -> Bag Err.Message -> Bag Err.Message -> [CoreBind] + -> IO () +displayLintResults dflags pass warns errs binds + | not (isEmptyBag errs) + = do { printDump (vcat [ banner "errors", Err.pprMessageBag errs + , ptext (sLit "*** Offending Program ***") + , pprCoreBindings binds + , ptext (sLit "*** End of Offense ***") ]) + ; 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) + + | otherwise = return () + where + banner string = ptext (sLit "*** Core Lint") <+> text string + <+> ptext (sLit ": in result of") <+> ppr pass + <+> ptext (sLit "***") + +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 _ (SimplMode { sm_phase = InitialPhase })) = False +showLintWarnings _ = True \end{code} @@ -151,10 +210,9 @@ data CoreToDo -- These are diff core-to-core passes, -- as many times as you like. = CoreDoSimplify -- The core-to-core simplifier. + Int -- Max iterations SimplifierMode - [SimplifierSwitch] - -- Each run of the simplifier can take a different - -- set of simplifier-specific flags. + | CoreDoFloatInwards | CoreDoFloatOutwards FloatOutSwitches | CoreLiberateCase @@ -164,62 +222,118 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoWorkerWrapper | CoreDoSpecialising | CoreDoSpecConstr - | CoreDoOldStrictness | CoreDoGlomBinds | 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 + | CoreDesugar -- Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + +coreDumpFlag :: CoreToDo -> Maybe DynFlag +coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases +coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core +coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core +coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core +coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal +coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper +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 CoreDoPrintCore = Nothing +coreDumpFlag (CoreDoRuleCheck {}) = Nothing +coreDumpFlag CoreDoNothing = Nothing +coreDumpFlag CoreDoGlomBinds = Nothing +coreDumpFlag (CoreDoPasses {}) = Nothing + +instance Outputable CoreToDo where + 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 CoreLiberateCase = ptext (sLit "Liberate case") + ppr CoreDoStaticArgs = ptext (sLit "Static argument") + ppr CoreDoStrictness = ptext (sLit "Demand analysis") + ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds") + 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 CorePrep = ptext (sLit "CorePrep") + ppr CoreDoPrintCore = ptext (sLit "Print core") + ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check") + ppr CoreDoGlomBinds = ptext (sLit "Glom binds") + ppr CoreDoNothing = ptext (sLit "CoreDoNothing") + ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses") +\end{code} +\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 }) - = 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 +\end{code} -data SimplifierSwitch - = MaxSimplifierIterations Int - | NoCaseOfCase +\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} @@ -234,37 +348,54 @@ getCoreToDo :: DynFlags -> [CoreToDo] 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) [ - MaxSimplifierIterations 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. @@ -278,27 +409,18 @@ getCoreToDo dflags -- 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 }) - [ - -- 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 - ] + 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 @@ -323,14 +445,28 @@ getCoreToDo dflags -- 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, @@ -355,8 +491,11 @@ getCoreToDo dflags 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 @@ -371,7 +510,7 @@ getCoreToDo dflags 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. @@ -384,7 +523,7 @@ getCoreToDo dflags runWhen spec_constr CoreDoSpecConstr, - maybe_rule_check 0, + maybe_rule_check (Phase 0), -- Final clean-up simplification: simpl_phase 0 ["final"] max_iter @@ -419,17 +558,32 @@ dumpSimplPhase dflags mode _ -> 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 @@ -449,9 +603,7 @@ plusSimplCount :: SimplCount -> SimplCount -> SimplCount \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 @@ -465,20 +617,23 @@ data SimplCount -- 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 } @@ -490,37 +645,37 @@ doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = 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)"), @@ -973,3 +1128,29 @@ thNameToGhcName th_name = do 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