Nitpick: don't we usually name these flags -fno-nested-cpr? On Wed, Dec 4, 2013 at 10:19 AM, wrote:

Repository : ssh://git@git.haskell.org/ghc

On branch : wip/nested-cpr Link : http://ghc.haskell.org/trac/ghc/changeset/90529b15c02ef03dcece13c267b76d4709...

...

---------------------------------------------------------------

commit 90529b15c02ef03dcece13c267b76d470941b808 Author: Joachim Breitner Date: Wed Dec 4 09:14:26 2013 +0000

Add a flag -fnested-cpr-off to conveniently test the effect of nested CPR

...

---------------------------------------------------------------

90529b15c02ef03dcece13c267b76d470941b808 compiler/basicTypes/Demand.lhs | 28 +++++++++++++++++++--------- compiler/main/StaticFlags.hs | 9 +++++++-- 2 files changed, 26 insertions(+), 11 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index 557a9bd..e955195 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -791,20 +791,29 @@ botRes = Diverges 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 e.g. the -- DmdResult of repeat -- -- So we need to forget information at a certain depth. We do that at all points -- where we are building RetCon 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 0 _ = NoCPR +cutCPRResult _ NoCPR = NoCPR cutCPRResult n (RetCon tag rs) = RetCon tag (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) +

-- Forget that something might converge for sure divergeDmdResult :: DmdResult -> DmdResult @@ -819,8 +828,9 @@ forgetCPR (Dunno _) = Dunno NoCPR

cprConRes :: ConTag -> [DmdType] -> CPRResult cprConRes tag arg_tys - | opt_CprOff = NoCPR - | otherwise = cutCPRResult maxCPRDepth $ RetCon tag (map get_res arg_tys) + | opt_CprOff = NoCPR + | opt_NestedCprOff = cutCPRResult flatCPRDepth $ RetCon tag (map get_res arg_tys) + | otherwise = cutCPRResult maxCPRDepth $ RetCon tag (map get_res arg_tys) where get_res :: DmdType -> DmdResult get_res (DmdType _ [] r) = r -- Only for data-typed arguments! 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")

_______________________________________________ ghc-commits mailing list ghc-commits@haskell.org http://www.haskell.org/mailman/listinfo/ghc-commits