[commit: ghc] wip/nested-cpr: Use the un-postprocessed DmdResult to build nested CPR (ecfab42)
git at git.haskell.org
git at git.haskell.org
Wed Dec 4 18:06:00 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/nested-cpr
Link : http://ghc.haskell.org/trac/ghc/changeset/ecfab42ee7563ad0cdade10a470b31cc678056f3/ghc
>---------------------------------------------------------------
commit ecfab42ee7563ad0cdade10a470b31cc678056f3
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Wed Dec 4 16:29:35 2013 +0000
Use the un-postprocessed DmdResult to build nested CPR
>---------------------------------------------------------------
ecfab42ee7563ad0cdade10a470b31cc678056f3
compiler/basicTypes/Demand.lhs | 18 +++++++++---------
compiler/stranal/DmdAnal.lhs | 32 ++++++++++++++++++--------------
2 files changed, 27 insertions(+), 23 deletions(-)
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index b4597b2..27ed312 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -26,7 +26,7 @@ module Demand (
peelFV,
DmdResult(..), CPRResult(..),
- isBotRes, isTopRes, resTypeArgDmd,
+ isBotRes, isTopRes, getDmdResult, resTypeArgDmd,
topRes, botRes, cprConRes, vanillaCprConRes,
appIsBottom, isBottomingSig, pprIfaceStrictSig,
returnsCPR, returnsCPR_maybe,
@@ -828,15 +828,15 @@ forgetCPR Diverges = Diverges
forgetCPR (Converges _) = Converges NoCPR
forgetCPR (Dunno _) = Dunno NoCPR
-cprConRes :: ConTag -> [DmdType] -> CPRResult
-cprConRes tag arg_tys
+cprConRes :: ConTag -> [DmdResult] -> CPRResult
+cprConRes tag arg_ress
| 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!
- get_res _ = topRes
+ | opt_NestedCprOff = cutCPRResult flatCPRDepth $ RetCon tag arg_ress
+ | otherwise = cutCPRResult maxCPRDepth $ RetCon tag arg_ress
+
+getDmdResult :: DmdType -> DmdResult
+getDmdResult (DmdType _ [] r) = r -- Only for data-typed arguments!
+getDmdResult _ = topRes
vanillaCprConRes :: ConTag -> Arity -> CPRResult
vanillaCprConRes tag arity
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index edb8fba..fb45b46 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -100,24 +100,28 @@ c) The application rule wouldn't be right either
\begin{code}
dmdAnalArg :: AnalEnv
-> Demand -- This one takes a *Demand*
- -> CoreExpr -> (DmdType, CoreExpr)
+ -> CoreExpr
+ -> (DmdType, DmdResult, CoreExpr)
-- Used for function arguments
dmdAnalArg env dmd e
| exprIsTrivial e = dmdAnalStar env dmd e
| otherwise = dmdAnalStar env (oneifyDmd dmd) e
+ -- oneifyDmd: This is a thunk, so its content will be evaluated at most once
-- Do not process absent demands
-- Otherwise act like in a normal demand analysis
-- See |-* relation in the companion paper
dmdAnalStar :: AnalEnv
-> Demand -- This one takes a *Demand*
- -> CoreExpr -> (DmdType, CoreExpr)
+ -> CoreExpr
+ -> (DmdType, DmdResult, CoreExpr)
dmdAnalStar env dmd e
| (cd, defer_and_use) <- toCleanDmd dmd
, (dmd_ty, e') <- dmdAnal env cd e
= let dmd_ty' = postProcessDmdTypeM defer_and_use dmd_ty
in -- pprTrace "dmdAnalStar" (vcat [ppr e, ppr dmd, ppr defer_and_use, ppr dmd_ty, ppr dmd_ty'])
- (dmd_ty', e')
+ -- We also return the unmodified DmdResult, to store it in nested CPR information
+ (dmd_ty', getDmdResult dmd_ty, e')
-- Main Demand Analsysis machinery
dmdAnal :: AnalEnv
@@ -508,7 +512,7 @@ completeApp env (fun_ty, fun') (arg:args)
| otherwise = completeApp env (res_ty `bothDmdType` arg_ty, App fun' arg') args
where
(arg_dmd, res_ty) = splitDmdTy fun_ty
- (arg_ty, arg') = dmdAnalArg env arg_dmd arg
+ (arg_ty, _, arg') = dmdAnalArg env arg_dmd arg
----------------
dmdAnalVarApp :: AnalEnv -> CleanDemand -> Id
@@ -517,7 +521,7 @@ dmdAnalVarApp env dmd fun args
| Just con <- isDataConWorkId_maybe fun -- Data constructor
, isVanillaDataCon con
, n_val_args == dataConRepArity con -- Saturated
- , let cpr_info = Converges (cprConRes (dataConTag con) arg_tys)
+ , let cpr_info = Converges (cprConRes (dataConTag con) arg_rets)
res_ty = foldl bothDmdType (DmdType emptyDmdEnv [] cpr_info) arg_tys
= -- pprTrace "dmdAnalVarApp" (vcat [ ppr con, ppr args, ppr n_val_args, ppr cxt_ds
-- , ppr arg_tys, ppr cpr_info, ppr res_ty]) $
@@ -535,21 +539,21 @@ dmdAnalVarApp env dmd fun args
where
n_val_args = valArgCount args
cxt_ds = splitProdCleanDmd n_val_args dmd
- (arg_tys, args') = anal_args cxt_ds args
+ (arg_tys, arg_rets, args') = anal_args cxt_ds args
-- The constructor itself is lazy
-- See Note [Data-con worker strictness] in MkId
- anal_args :: [Demand] -> [CoreExpr] -> ([DmdType], [CoreExpr])
- anal_args _ [] = ([],[])
+ anal_args :: [Demand] -> [CoreExpr] -> ([DmdType], [DmdResult], [CoreExpr])
+ anal_args _ [] = ([],[],[])
anal_args ds (arg : args)
| isTypeArg arg
- , (arg_tys, args') <- anal_args ds args
- = (arg_tys, arg:args')
+ , (arg_tys, arg_rets, args') <- anal_args ds args
+ = (arg_tys, arg_rets, arg:args')
anal_args (d:ds) (arg : args)
- | (arg_ty, arg') <- dmdAnalArg env d arg
- , (arg_tys, args') <- anal_args ds args
+ | (arg_ty, arg_ret, arg') <- dmdAnalArg env d arg
+ , (arg_tys, arg_rets, args') <- anal_args ds args
= --pprTrace "dmdAnalVarApp arg" (vcat [ ppr d, ppr arg, ppr arg_ty, ppr arg' ])
- (arg_ty:arg_tys, arg':args')
+ (arg_ty:arg_tys, arg_ret:arg_rets, arg':args')
anal_args ds args = pprPanic "anal_args" (ppr args $$ ppr ds)
\end{code}
@@ -834,7 +838,7 @@ annotateLamIdBndr env arg_of_dfun dmd_ty one_shot id
Nothing -> main_ty
Just unf -> main_ty `bothDmdType` unf_ty
where
- (unf_ty, _) = dmdAnalStar env dmd unf
+ (unf_ty, _, _) = dmdAnalStar env dmd unf
main_ty = addDemand dmd dmd_ty'
(dmd_ty', dmd) = peelFV dmd_ty id
More information about the ghc-commits
mailing list