<div dir="ltr">Nitpick: don't we usually name these flags -fno-nested-cpr?</div><div class="gmail_extra"><br><br><div class="gmail_quote">On Wed, Dec 4, 2013 at 10:19 AM, <span dir="ltr"><<a href="mailto:git@git.haskell.org" target="_blank">git@git.haskell.org</a>></span> wrote:<br>
<blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex">Repository : ssh://<a href="http://git@git.haskell.org/ghc" target="_blank">git@git.haskell.org/ghc</a><br>
<br>
On branch : wip/nested-cpr<br>
Link : <a href="http://ghc.haskell.org/trac/ghc/changeset/90529b15c02ef03dcece13c267b76d470941b808/ghc" target="_blank">http://ghc.haskell.org/trac/ghc/changeset/90529b15c02ef03dcece13c267b76d470941b808/ghc</a><br>
<br>
>---------------------------------------------------------------<br>
<br>
commit 90529b15c02ef03dcece13c267b76d470941b808<br>
Author: Joachim Breitner <<a href="mailto:mail@joachim-breitner.de">mail@joachim-breitner.de</a>><br>
Date: Wed Dec 4 09:14:26 2013 +0000<br>
<br>
Add a flag -fnested-cpr-off to conveniently test the effect of nested CPR<br>
<br>
<br>
>---------------------------------------------------------------<br>
<br>
90529b15c02ef03dcece13c267b76d470941b808<br>
compiler/basicTypes/Demand.lhs | 28 +++++++++++++++++++---------<br>
compiler/main/StaticFlags.hs | 9 +++++++--<br>
2 files changed, 26 insertions(+), 11 deletions(-)<br>
<br>
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs<br>
index 557a9bd..e955195 100644<br>
--- a/compiler/basicTypes/Demand.lhs<br>
+++ b/compiler/basicTypes/Demand.lhs<br>
@@ -791,20 +791,29 @@ botRes = Diverges<br>
maxCPRDepth :: Int<br>
maxCPRDepth = 3<br>
<br>
+-- This is the depth we use with -fnested-cpr-off, in order<br>
+-- to get precisely the same behaviour as before introduction of nested cpr<br>
+-- -fnested-cpr-off can eventually be removed if nested cpr is deemd to be<br>
+-- a good thing always.<br>
+flatCPRDepth :: Int<br>
+flatCPRDepth = 1<br>
+<br>
-- With nested CPR, DmdResult can be arbitrarily deep; consider e.g. the<br>
-- DmdResult of repeat<br>
--<br>
-- So we need to forget information at a certain depth. We do that at all points<br>
-- where we are building RetCon constructors.<br>
-cutDmdResult :: Int -> DmdResult -> DmdResult<br>
-cutDmdResult 0 _ = topRes<br>
-cutDmdResult _ Diverges = Diverges<br>
-cutDmdResult n (Converges c) = Converges (cutCPRResult n c)<br>
-cutDmdResult n (Dunno c) = Dunno (cutCPRResult n c)<br>
-<br>
cutCPRResult :: Int -> CPRResult -> CPRResult<br>
-cutCPRResult _ NoCPR = NoCPR<br>
+cutCPRResult 0 _ = NoCPR<br>
+cutCPRResult _ NoCPR = NoCPR<br>
cutCPRResult n (RetCon tag rs) = RetCon tag (map (cutDmdResult (n-1)) rs)<br>
+ where<br>
+ cutDmdResult :: Int -> DmdResult -> DmdResult<br>
+ cutDmdResult 0 _ = topRes<br>
+ cutDmdResult _ Diverges = Diverges<br>
+ cutDmdResult n (Converges c) = Converges (cutCPRResult n c)<br>
+ cutDmdResult n (Dunno c) = Dunno (cutCPRResult n c)<br>
+<br>
<br>
-- Forget that something might converge for sure<br>
divergeDmdResult :: DmdResult -> DmdResult<br>
@@ -819,8 +828,9 @@ forgetCPR (Dunno _) = Dunno NoCPR<br>
<br>
cprConRes :: ConTag -> [DmdType] -> CPRResult<br>
cprConRes tag arg_tys<br>
- | opt_CprOff = NoCPR<br>
- | otherwise = cutCPRResult maxCPRDepth $ RetCon tag (map get_res arg_tys)<br>
+ | opt_CprOff = NoCPR<br>
+ | opt_NestedCprOff = cutCPRResult flatCPRDepth $ RetCon tag (map get_res arg_tys)<br>
+ | otherwise = cutCPRResult maxCPRDepth $ RetCon tag (map get_res arg_tys)<br>
where<br>
get_res :: DmdType -> DmdResult<br>
get_res (DmdType _ [] r) = r -- Only for data-typed arguments!<br>
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs<br>
index 01dc3b7..feb7235 100644<br>
--- a/compiler/main/StaticFlags.hs<br>
+++ b/compiler/main/StaticFlags.hs<br>
@@ -27,6 +27,7 @@ module StaticFlags (<br>
-- optimisation opts<br>
opt_NoStateHack,<br>
opt_CprOff,<br>
+ opt_NestedCprOff,<br>
opt_NoOptCoercion,<br>
<br>
-- For the parser<br>
@@ -140,7 +141,8 @@ flagsStaticNames :: [String]<br>
flagsStaticNames = [<br>
"fno-state-hack",<br>
"fno-opt-coercion",<br>
- "fcpr-off"<br>
+ "fcpr-off",<br>
+ "fnested-cpr-off"<br>
]<br>
<br>
-- We specifically need to discard static flags for clients of the<br>
@@ -195,10 +197,13 @@ opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output")<br>
opt_NoStateHack :: Bool<br>
opt_NoStateHack = lookUp (fsLit "-fno-state-hack")<br>
<br>
--- Switch off CPR analysis in the new demand analyser<br>
+-- Switch off CPR analysis in the demand analyser<br>
opt_CprOff :: Bool<br>
opt_CprOff = lookUp (fsLit "-fcpr-off")<br>
<br>
+opt_NestedCprOff :: Bool<br>
+opt_NestedCprOff = lookUp (fsLit "-fnested-cpr-off")<br>
+<br>
opt_NoOptCoercion :: Bool<br>
opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion")<br>
<br>
<br>
_______________________________________________<br>
ghc-commits mailing list<br>
<a href="mailto:ghc-commits@haskell.org">ghc-commits@haskell.org</a><br>
<a href="http://www.haskell.org/mailman/listinfo/ghc-commits" target="_blank">http://www.haskell.org/mailman/listinfo/ghc-commits</a><br>
</blockquote></div><br></div>