X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FCoreMonad.lhs;h=d821d407367192f13c024aa38c01bd584f5ec79b;hp=7f43ce528f3657afe253eb7472b9985b9728cc59;hb=94bf0d3604ff0d2ecab246924af712bdd1c29a40;hpb=5126e7cd4594d05cd78bcaccf044a30c0051fd9b diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 7f43ce5..d821d40 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -79,12 +79,14 @@ import Bag 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 @@ -303,8 +305,10 @@ data SimplifierSwitch \begin{code} data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level - floatOutConstants :: Bool -- ^ True <=> float constants 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 + -- based on arity information. } instance Outputable FloatOutSwitches where ppr = pprFloatOutSwitches @@ -319,10 +323,6 @@ pprFloatOutSwitches sw = pp_not (floatOutLambdas sw) <+> text "lambdas" <> comma -- | 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} @@ -419,14 +419,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 = False, + 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, @@ -451,8 +465,11 @@ getCoreToDo dflags simpl_phase 0 ["post-worker-wrapper"] max_iter ]), - runWhen full_laziness - (CoreDoFloatOutwards constantsOnlyFloatOutSwitches), + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = False, + 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 @@ -559,7 +576,7 @@ data SimplCount -- recent history reasonably efficiently } -type TickCounts = FiniteMap Tick Int +type TickCounts = Map Tick Int simplCountN :: SimplCount -> Int simplCountN (VerySimplCount n) = n @@ -569,7 +586,7 @@ 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 = VerySimplCount 0 @@ -590,19 +607,19 @@ doSimplTick tick sc@SimplCount { ticks = tks, details = dts, n_log = nl, log1 = 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 @@ -617,7 +634,7 @@ 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)"),