From 63e3a41126771e71c44705480c2bde7043a41df3 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 18 Dec 2009 16:45:21 +0000 Subject: [PATCH] Move all the CoreToDo stuff into CoreMonad 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. --- compiler/main/DynFlags.hs | 305 +-------------------- compiler/simplCore/CoreMonad.lhs | 549 ++++++++++++++++++++++++++++++++++++- compiler/simplCore/FloatOut.lhs | 3 +- compiler/simplCore/SetLevels.lhs | 3 +- compiler/simplCore/SimplCore.lhs | 7 +- compiler/simplCore/SimplEnv.lhs | 2 +- compiler/simplCore/SimplMonad.lhs | 245 +---------------- compiler/simplCore/SimplUtils.lhs | 11 +- compiler/simplCore/Simplify.lhs | 9 +- 9 files changed, 577 insertions(+), 557 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index a008ea6..4ba19b0 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -46,13 +46,6 @@ module 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, @@ -82,7 +75,6 @@ import Maybes ( orElse ) import SrcLoc import FastString import FiniteMap -import BasicTypes ( CompilerPhase ) import Outputable import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) @@ -344,8 +336,6 @@ data DynFlag 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 @@ -353,7 +343,7 @@ data DynFlags = DynFlags { 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 @@ -600,8 +590,6 @@ defaultDynFlags = DynFlags { ghcMode = CompManager, ghcLink = LinkBinary, - coreToDo = Nothing, - stgToDo = Nothing, hscTarget = defaultHscTarget, hscOutName = "", extCoreName = "", @@ -609,7 +597,7 @@ defaultDynFlags = optLevel = 0, simplPhases = 2, maxSimplIterations = 4, - shouldDumpSimplPhase = const False, + shouldDumpSimplPhase = Nothing, ruleCheck = Nothing, specConstrThreshold = Just 200, specConstrCount = Just 3, @@ -979,255 +967,6 @@ minuswRemovesOpts ] -- ----------------------------------------------------------------------------- --- 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 @@ -1238,8 +977,7 @@ 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 @@ -2056,41 +1794,16 @@ forceRecompile = do { dfs <- getCmdLineState 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 }) diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index f8956b0..ef8c428 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -7,6 +7,17 @@ {-# 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, @@ -48,11 +59,13 @@ import CoreUtils 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 ) @@ -65,7 +78,10 @@ import qualified ErrUtils as Err 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 @@ -124,6 +140,533 @@ dumpAndLint dump dflags pass_name dump_flag binds rules %************************************************************************ %* * + 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 %* * %************************************************************************ diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index f5f8946..ba74afc 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -11,8 +11,9 @@ module FloatOut ( floatOutwards ) where 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 ) diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index d0914c9..2945a7c 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -54,8 +54,7 @@ module SetLevels ( #include "HsVersions.h" import CoreSyn - -import DynFlags ( FloatOutSwitches(..) ) +import CoreMonad ( FloatOutSwitches(..) ) import CoreUtils ( exprType, mkPiTypes ) import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index 9f656fb..7449a5a 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -15,9 +15,7 @@ module SimplCore ( core2core, simplifyExpr ) where #include "HsVersions.h" -import DynFlags ( CoreToDo(..), SimplifierSwitch(..), - SimplifierMode(..), DynFlags, DynFlag(..), dopt, - getCoreToDo, shouldDumpSimplPhase ) +import DynFlags ( DynFlags, DynFlag(..), dopt ) import CoreSyn import CoreSubst import HscTypes @@ -37,7 +35,6 @@ import SimplMonad import CoreMonad import qualified ErrUtils as Err import CoreLint -import CoreMonad ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv @@ -507,7 +504,7 @@ simplifyPgmIO mode switches hsc_env us hpt_rule_base } 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 diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 8964079..2a620ff 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -40,6 +40,7 @@ module SimplEnv ( #include "HsVersions.h" import SimplMonad +import CoreMonad ( SimplifierMode(..) ) import IdInfo import CoreSyn import CoreUtils @@ -54,7 +55,6 @@ import qualified Type ( substTy, substTyVarBndr ) import Type hiding ( substTy, substTyVarBndr ) import Coercion import BasicTypes -import DynFlags import MonadUtils import Outputable import FastString diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 8a02b17..5065f57 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -14,8 +14,7 @@ module SimplMonad ( MonadUnique(..), newId, -- Counting - SimplCount, Tick(..), - tick, freeTick, + SimplCount, tick, freeTick, getSimplCount, zeroSimplCount, pprSimplCount, plusSimplCount, isZeroSimplCount, @@ -29,10 +28,9 @@ import Type ( Type ) 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 @@ -154,250 +152,17 @@ getSimplCount = SM (\_st_env us sc -> (sc, us, sc)) 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} - %************************************************************************ %* * diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index dd4cec6..20f26c2 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -28,6 +28,7 @@ module SimplUtils ( #include "HsVersions.h" import SimplEnv +import CoreMonad ( SimplifierMode(..), Tick(..) ) import DynFlags import StaticFlags import CoreSyn @@ -601,15 +602,13 @@ updModeForInlineRules inline_rule_act current_mode 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} diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 60ee802..4c1b6cb 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -18,10 +18,11 @@ import Id 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 ) @@ -674,12 +675,14 @@ simplUnfolding env top_lvl id _ _ (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 _ -- 1.7.10.4