[commit: ghc] wip/nested-cpr: Add a flag -fnested-cpr-off to conveniently test the effect of nested CPR (90529b1)

[Johan Tibell]

Nitpick: don't we usually name these flags -fno-nested-cpr?


On Wed, Dec 4, 2013 at 10:19 AM, <git at git.haskell.org> wrote:

> Repository : ssh://git@git.haskell.org/ghc
>
> On branch  : wip/nested-cpr
> Link       :
> http://ghc.haskell.org/trac/ghc/changeset/90529b15c02ef03dcece13c267b76d470941b808/ghc
>
> >---------------------------------------------------------------
>
> commit 90529b15c02ef03dcece13c267b76d470941b808
> 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
>
>
> >---------------------------------------------------------------
>
> 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 at haskell.org
> http://www.haskell.org/mailman/listinfo/ghc-commits
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://www.haskell.org/pipermail/ghc-commits/attachments/20131204/98ce2378/attachment.html>