Nitpick: don't we usually name these flags -fno-nested-cpr?
On Wed, Dec 4, 2013 at 10:19 AM, <[email protected]> wrote: > Repository : ssh://[email protected]/ghc > > On branch : wip/nested-cpr > Link : > http://ghc.haskell.org/trac/ghc/changeset/90529b15c02ef03dcece13c267b76d470941b808/ghc > > >--------------------------------------------------------------- > > commit 90529b15c02ef03dcece13c267b76d470941b808 > Author: Joachim Breitner <[email protected]> > 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 > [email protected] > http://www.haskell.org/mailman/listinfo/ghc-commits >
_______________________________________________ ghc-devs mailing list [email protected] http://www.haskell.org/mailman/listinfo/ghc-devs
