Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/892d862144d253bd84e04a3c02be1e4314b1cb46 >--------------------------------------------------------------- commit 892d862144d253bd84e04a3c02be1e4314b1cb46 Author: Ian Lynagh <[email protected]> Date: Mon Sep 3 22:22:34 2012 +0100 Make -fhistory-size dynamic >--------------------------------------------------------------- compiler/main/DynFlags.hs | 3 +++ compiler/main/StaticFlagParser.hs | 1 - compiler/main/StaticFlags.hs | 4 ---- compiler/simplCore/CoreMonad.lhs | 12 +++++++----- compiler/simplCore/SimplMonad.lhs | 6 +++--- docs/users_guide/flags.xml | 2 +- 6 files changed, 14 insertions(+), 14 deletions(-) diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index b5d17ca..3451dfd 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -523,6 +523,7 @@ data DynFlags = DynFlags { liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches + historySize :: Int, cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], @@ -1104,6 +1105,7 @@ defaultDynFlags mySettings = specConstrCount = Just 3, liberateCaseThreshold = Just 2000, floatLamArgs = Just 0, -- Default: float only if no fvs + historySize = 20, strictnessBefore = [], cmdlineHcIncludes = [], @@ -2041,6 +2043,7 @@ dynamic_flags = [ , Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) , Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) + , Flag "fhistory-size" (intSuffix (\n d -> d{ historySize = n })) ------ Profiling ---------------------------------------------------- diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 05a4639..dbf321d 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -142,7 +142,6 @@ isStaticFlag f = || any (`isPrefixOf` f) [ "fliberate-case-threshold", "fmax-worker-args", - "fhistory-size", "funfolding-creation-threshold", "funfolding-dict-threshold", "funfolding-use-threshold", diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index fac89cf..6b01a95 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -65,7 +65,6 @@ module StaticFlags ( -- misc opts opt_ErrorSpans, - opt_HistorySize, -- For the parser addOpt, removeOpt, v_opt_C_ready, @@ -246,9 +245,6 @@ opt_CprOff = lookUp (fsLit "-fcpr-off") opt_MaxWorkerArgs :: Int opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) -opt_HistorySize :: Int -opt_HistorySize = lookup_def_int "-fhistory-size" 20 - -- Simplifier switches opt_SimplNoPreInlining :: Bool opt_SimplNoPreInlining = lookUp (fsLit "-fno-pre-inlining") diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 5c97fbd..9af48b4 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -480,7 +480,8 @@ zeroSimplCount :: DynFlags -> SimplCount isZeroSimplCount :: SimplCount -> Bool hasDetailedCounts :: SimplCount -> Bool pprSimplCount :: SimplCount -> SDoc -doSimplTick, doFreeSimplTick :: Tick -> SimplCount -> SimplCount +doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount plusSimplCount :: SimplCount -> SimplCount -> SimplCount \end{code} @@ -525,13 +526,14 @@ 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 } +doSimplTick dflags tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= historySize dflags = 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 _ (VerySimplCount n) = VerySimplCount (n+1) +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) -- Don't use Map.unionWith because that's lazy, and we want to diff --git a/compiler/simplCore/SimplMonad.lhs b/compiler/simplCore/SimplMonad.lhs index 04b8c4e..9d98569 100644 --- a/compiler/simplCore/SimplMonad.lhs +++ b/compiler/simplCore/SimplMonad.lhs @@ -182,15 +182,15 @@ getSimplCount :: SimplM SimplCount getSimplCount = SM (\_st_env us sc -> return (sc, us, sc)) tick :: Tick -> SimplM () -tick t = SM (\_st_env us sc -> let sc' = doSimplTick t sc - in sc' `seq` return ((), us, sc')) +tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc + in sc' `seq` return ((), us, sc')) checkedTick :: Tick -> SimplM () -- Try to take a tick, but fail if too many checkedTick t = SM (\st_env us sc -> if st_max_ticks st_env <= simplCountN sc then pprPanic "Simplifier ticks exhausted" (msg sc) - else let sc' = doSimplTick t sc + else let sc' = doSimplTick (st_flags st_env) t sc in sc' `seq` return ((), us, sc')) where msg sc = vcat [ ptext (sLit "When trying") <+> ppr t diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 7cbeeab..00c9b44 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -2864,7 +2864,7 @@ <row> <entry><option>-fhistory-size</option></entry> <entry>Set simplification history size</entry> - <entry>static</entry> + <entry>dynamic</entry> <entry>-</entry> </row> <row> _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
