[commit: ghc] wip/nested-cpr: Add a flag -fnested-cpr-off to conveniently test the effect of nested CPR (46ede93)
git at git.haskell.org
git at git.haskell.org
Wed Jan 15 18:07:12 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nested-cpr
Link : http://ghc.haskell.org/trac/ghc/changeset/46ede931aad26290718033743b2425bfcd5e1cac/ghc
>---------------------------------------------------------------
commit 46ede931aad26290718033743b2425bfcd5e1cac
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Dec 4 09:14:26 2013 +0000
Add a flag -fnested-cpr-off to conveniently test the effect of nested CPR
>---------------------------------------------------------------
46ede931aad26290718033743b2425bfcd5e1cac
compiler/basicTypes/Demand.lhs | 31 ++++++++++++++++++++-----------
compiler/main/StaticFlags.hs | 9 +++++++--
2 files changed, 27 insertions(+), 13 deletions(-)
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 43b0418..cef71b2 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -829,6 +829,13 @@ divergeDmdResult r = r `lubDmdResult` botRes
maxCPRDepth :: Int
maxCPRDepth = 3
+-- This is the depth we use with -fnested-cpr-off, in order
+-- to get precisely the same behaviour as before introduction of nested cpr
+-- -fnested-cpr-off can eventually be removed if nested cpr is deemd to be
+-- a good thing always.
+flatCPRDepth :: Int
+flatCPRDepth = 1
+
-- With nested CPR, DmdResult can be arbitrarily deep; consider
-- data Rec1 = Foo Rec2 Rec2
-- data Rec2 = Bar Rec1 Rec1
@@ -838,21 +845,23 @@ maxCPRDepth = 3
--
-- So we need to forget information at a certain depth. We do that at all points
-- where we are constructing new RetProd constructors.
-cutDmdResult :: Int -> DmdResult -> DmdResult
-cutDmdResult 0 _ = topRes
-cutDmdResult _ Diverges = Diverges
-cutDmdResult n (Converges c) = Converges (cutCPRResult n c)
-cutDmdResult n (Dunno c) = Dunno (cutCPRResult n c)
-
cutCPRResult :: Int -> CPRResult -> CPRResult
-cutCPRResult _ NoCPR = NoCPR
-cutCPRResult n (RetProd rs) = RetProd (map (cutDmdResult (n-1)) rs)
-cutCPRResult _ (RetSum tag) = RetSum tag
+cutCPRResult 0 _ = NoCPR
+cutCPRResult _ NoCPR = NoCPR
+cutCPRResult _ (RetSum tag) = RetSum tag
+cutCPRResult n (RetProd rs) = RetProd (map (cutDmdResult (n-1)) rs)
+ where
+ cutDmdResult :: Int -> DmdResult -> DmdResult
+ cutDmdResult 0 _ = topRes
+ cutDmdResult _ Diverges = Diverges
+ cutDmdResult n (Converges c) = Converges (cutCPRResult n c)
+ cutDmdResult n (Dunno c) = Dunno (cutCPRResult n c)
vanillaCprProdRes :: Arity -> DmdResult
vanillaCprProdRes arity
- | opt_CprOff = topRes
- | otherwise = Converges $ cutCPRResult maxCPRDepth $ RetProd (replicate arity topRes)
+ | opt_CprOff = topRes
+ | opt_NestedCprOff = Converges $ cutCPRResult flatCPRDepth $ RetProd (replicate arity topRes)
+ | otherwise = Converges $ cutCPRResult maxCPRDepth $ RetProd (replicate arity topRes)
isTopRes :: DmdResult -> Bool
isTopRes (Dunno NoCPR) = True
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 01dc3b7..feb7235 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -27,6 +27,7 @@ module StaticFlags (
-- optimisation opts
opt_NoStateHack,
opt_CprOff,
+ opt_NestedCprOff,
opt_NoOptCoercion,
-- For the parser
@@ -140,7 +141,8 @@ flagsStaticNames :: [String]
flagsStaticNames = [
"fno-state-hack",
"fno-opt-coercion",
- "fcpr-off"
+ "fcpr-off",
+ "fnested-cpr-off"
]
-- We specifically need to discard static flags for clients of the
@@ -195,10 +197,13 @@ opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output")
opt_NoStateHack :: Bool
opt_NoStateHack = lookUp (fsLit "-fno-state-hack")
--- Switch off CPR analysis in the new demand analyser
+-- Switch off CPR analysis in the demand analyser
opt_CprOff :: Bool
opt_CprOff = lookUp (fsLit "-fcpr-off")
+opt_NestedCprOff :: Bool
+opt_NestedCprOff = lookUp (fsLit "-fnested-cpr-off")
+
opt_NoOptCoercion :: Bool
opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion")
More information about the ghc-commits
mailing list