X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCoreMonad.lhs;h=67a0991ec0b43d7518ee46e6776b78b626637b99;hp=e3dbf3a3040024c07233ca0c4f4573e476cf6212;hb=5909e9a896d40a18b4bcf6abb95e0b071bfd7db2;hpb=a66541af84d102f32b73fb7f89f48008c01092a6 diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index e3dbf3a..67a0991 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -10,7 +10,6 @@ module CoreMonad ( -- * Configuration of the core-to-core passes CoreToDo(..), SimplifierMode(..), - SimplifierSwitch(..), FloatOutSwitches(..), getCoreToDo, dumpSimplPhase, @@ -44,6 +43,8 @@ module CoreMonad ( debugTraceMsg, debugTraceMsgS, dumpIfSet_dyn, + lookupOrigCoreM, + #ifdef GHCI -- * Getting 'Name's thNameToGhcName @@ -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 ) @@ -79,6 +80,7 @@ import Bag import Maybes import UniqSupply import UniqFM ( UniqFM, mapUFM, filterUFM ) +import MonadUtils import Util ( split ) import Data.List ( intersperse ) @@ -90,6 +92,11 @@ 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 ) @@ -185,8 +192,8 @@ displayLintResults dflags pass warns errs binds 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} @@ -203,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 - Int -- Max iterations - [SimplifierSwitch] -- Each run of the simplifier can take a different - -- set of simplifier-specific flags. + | CoreDoFloatInwards | CoreDoFloatOutwards FloatOutSwitches | CoreLiberateCase @@ -220,7 +226,7 @@ data CoreToDo -- These are diff core-to-core passes, | 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 @@ -241,10 +247,10 @@ 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 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 @@ -253,8 +259,8 @@ coreDumpFlag CoreDoGlomBinds = 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) @@ -265,9 +271,9 @@ instance Outputable CoreToDo where 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") @@ -278,50 +284,56 @@ instance Outputable CoreToDo where \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 - floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications + 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 +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} @@ -336,36 +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) - 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. @@ -379,21 +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 }) - -- 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 @@ -420,7 +447,7 @@ getCoreToDo dflags runWhen full_laziness $ CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = False, + floatOutLambdas = Just 0, floatOutConstants = True, floatOutPartialApplications = False }, -- Was: gentleFloatOutSwitches @@ -466,7 +493,7 @@ getCoreToDo dflags runWhen full_laziness $ CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = False, + floatOutLambdas = floatLamArgs dflags, floatOutConstants = True, floatOutPartialApplications = True }, -- nofib/spectral/hartel/wang doubles in speed if you @@ -483,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. @@ -496,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 @@ -531,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 @@ -1086,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