[commit: ghc] master: Make -fhistory-size dynamic (892d862)
Ian Lynagh
igloo at earth.li
Tue Sep 4 01:49:06 CEST 2012
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/892d862144d253bd84e04a3c02be1e4314b1cb46
>---------------------------------------------------------------
commit 892d862144d253bd84e04a3c02be1e4314b1cb46
Author: Ian Lynagh <ian at well-typed.com>
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 at SimplCount { details = dts }
= sc { details = dts `addTick` tick }
doFreeSimplTick _ sc = sc
-doSimplTick tick sc at 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>
More information about the Cvs-ghc
mailing list