[commit: ghc] wip/nested-cpr: Refactor trimCPRInfo away (26978dc)

git at git.haskell.org git at git.haskell.org
Wed Jan 15 18:07:17 UTC 2014


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

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

>---------------------------------------------------------------

commit 26978dcf8b41ddf7e494d6b3576105b9cf8a829d
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Jan 15 17:44:30 2014 +0000

    Refactor trimCPRInfo away


>---------------------------------------------------------------

26978dcf8b41ddf7e494d6b3576105b9cf8a829d
 compiler/basicTypes/Demand.lhs |   35 ++++++++++++++++++++---------------
 compiler/stranal/DmdAnal.lhs   |   30 ++++++++++++++++++++----------
 2 files changed, 40 insertions(+), 25 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index a8d7a6d..23dacea 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -30,7 +30,8 @@ module Demand (
         isBotRes, isTopRes, getDmdResult,
         topRes, convRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes,
         appIsBottom, isBottomingSig, pprIfaceStrictSig,
-        trimCPRInfo, returnsCPR, returnsCPR_maybe,
+        returnsCPR, returnsCPR_maybe,
+        forgetCPR, forgetSumCPR,
         StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, convergeSig,
         isNopSig, splitStrictSig, increaseStrictSigArity,
         sigMayDiverge,
@@ -857,6 +858,24 @@ cutCPRResult n (RetProd rs)    = RetProd (map (cutDmdResult (n-1)) rs)
     cutDmdResult n (Converges c) = Converges (cutCPRResult n c)
     cutDmdResult n (Dunno c)     = Dunno     (cutCPRResult n c)
 
+-- Forget the CPR information, but remember if it converges or diverges
+-- Used for non-strict thunks and non-top-level things with sum type
+forgetCPR :: DmdResult -> DmdResult
+forgetCPR Diverges = Diverges
+forgetCPR (Converges _) = Converges NoCPR
+forgetCPR (Dunno _) = Dunno NoCPR
+
+forgetSumCPR :: DmdResult -> DmdResult
+forgetSumCPR Diverges = Diverges
+forgetSumCPR (Converges r) = Converges (forgetSumCPR_help r)
+forgetSumCPR (Dunno r) = Dunno (forgetSumCPR_help r)
+
+forgetSumCPR_help :: CPRResult -> CPRResult
+forgetSumCPR_help (RetProd ds) = RetProd (map forgetSumCPR ds)
+forgetSumCPR_help (RetSum _)   = NoCPR
+forgetSumCPR_help NoCPR        = NoCPR
+
+
 vanillaCprProdRes :: Arity -> DmdResult
 vanillaCprProdRes arity
   | opt_CprOff        = topRes
@@ -871,20 +890,6 @@ isBotRes :: DmdResult -> Bool
 isBotRes Diverges = True
 isBotRes _        = False
 
-trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult
-trimCPRInfo trim_all trim_sums res
-  = trimR res
-  where
-    trimR (Converges c) = Converges (trimC c)
-    trimR (Dunno c)     = Dunno (trimC c)
-    trimR Diverges      = Diverges
-
-    trimC (RetSum n)   | trim_all || trim_sums = NoCPR
-                       | otherwise             = RetSum n
-    trimC (RetProd rs) | trim_all  = NoCPR
-                       | otherwise = RetProd (map trimR rs)
-    trimC NoCPR = NoCPR
-
 returnsCPR :: DmdResult -> Bool
 returnsCPR dr = isJust (returnsCPR_maybe False dr)
 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 5409538..a080930 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -651,21 +651,25 @@ dmdAnalRhs :: TopLevelFlag
 	   -> (StrictSig,  DmdEnv, Id, CoreExpr)
 -- Process the RHS of the binding, add the strictness signature
 -- to the Id, and augment the environment with the signature as well.
-dmdAnalRhs top_lvl rec_flag env id rhs
+dmdAnalRhs top_lvl rec_flag env var rhs
   | Just fn <- unpackTrivial rhs   -- See Note [Trivial right-hand sides]
   , let fn_str = getStrictness env fn
-  = (fn_str, emptyDmdEnv, set_idStrictness env id fn_str, rhs)
+  = (fn_str, emptyDmdEnv, set_idStrictness env var fn_str, rhs)
 
   | otherwise
-  = (sig_ty, lazy_fv, id', mkLams bndrs' body')
+  = (sig_ty, lazy_fv, var', mkLams bndrs' body')
   where
     (bndrs, body)        = collectBinders rhs
     env_body             = foldl extendSigsWithLam env bndrs
     (DmdType body_fv _      body_res, body')  = dmdAnal env_body body_dmd body
-    (DmdType rhs_fv rhs_dmds rhs_res, bndrs') = annotateLamBndrs env (isDFunId id)
+    (DmdType rhs_fv rhs_dmds rhs_res, bndrs') = annotateLamBndrs env (isDFunId var)
                                                   (DmdType body_fv [] body_res) bndrs
-    sig_ty               = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
-    id'		         = set_idStrictness env id sig_ty
+    sig_ty               = mkStrictSig $
+                           mkDmdType sig_fv rhs_dmds $
+                                handle_sum_cpr $
+                                handle_thunk_cpr $
+                                rhs_res
+    var'                 = set_idStrictness env var sig_ty
 	-- See Note [NOINLINE and strictness]
 
     -- See Note [Product demands for function body]
@@ -681,16 +685,19 @@ dmdAnalRhs top_lvl rec_flag env id rhs
 
     (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
 
-    rhs_res'  = trimCPRInfo trim_all trim_sums rhs_res
-    trim_all  = is_thunk && not_strict
-    trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types]
+    -- Note [CPR for sum types]
+    handle_sum_cpr | isTopLevel top_lvl = id
+                   | otherwise          = forgetSumCPR
 
     -- See Note [CPR for thunks]
+    handle_thunk_cpr | is_thunk && not_strict = forgetCPR
+                     | otherwise              = id
+
     is_thunk = not (exprIsHNF rhs)
     not_strict
        =  isTopLevel top_lvl  -- Top level and recursive things don't
        || isJust rec_flag     -- get their demandInfo set at all
-       || not (isStrictDmd (idDemandInfo id) || ae_virgin env)
+       || not (isStrictDmd (idDemandInfo var) || ae_virgin env)
           -- See Note [Optimistic CPR in the "virgin" case]
 
 unpackTrivial :: CoreExpr -> Maybe Id
@@ -881,6 +888,9 @@ may be CPR'd (via the returned Justs).  But in the case of
 sums, there may be Nothing alternatives; and that messes
 up the sum-type CPR.
 
+This also applies to nested CPR information: Keep product CPR information, but
+zap sum CPR information therein.
+
 Conclusion: only do this for products.  It's still not
 guaranteed OK for products, but sums definitely lose sometimes.
 



More information about the ghc-commits mailing list