diff options
| author | Joachim Breitner <mail@joachim-breitner.de> | 2013-12-04 17:38:25 +0000 |
|---|---|---|
| committer | Joachim Breitner <mail@joachim-breitner.de> | 2013-12-16 21:30:00 +0100 |
| commit | 59d4a8eb5fa34bdad8f4fa48f4679cf85a8e4b0d (patch) | |
| tree | 73cc5f35de83523478b05dd07b0b71ad4f6023ef | |
| parent | fbe14a8e8861403c207dddd6c496096924293bef (diff) | |
| download | haskell-59d4a8eb5fa34bdad8f4fa48f4679cf85a8e4b0d.tar.gz | |
Remove dmdAnalArg and replace by easier to understand code
| -rw-r--r-- | compiler/stranal/DmdAnal.lhs | 16 |
1 files changed, 8 insertions, 8 deletions
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 3b805d97c0..a377bf5cea 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -103,13 +103,12 @@ c) The application rule wouldn't be right either evaluation of f in a C(L) demand! \begin{code} -dmdAnalArg :: AnalEnv - -> Demand -- This one takes a *Demand* - -> CoreExpr -> (DmdType, CoreExpr) --- Used for function arguments -dmdAnalArg env dmd e - | exprIsTrivial e = dmdAnalStar env dmd e - | otherwise = dmdAnalStar env (oneifyDmd dmd) e +-- If e is complicated enough to become a thunk, its contents will be evaluated +-- at most once, so oneify it. +dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand +dmdTransformThunkDmd e + | exprIsTrivial e = id + | otherwise = oneifyDmd -- Do not process absent demands -- Otherwise act like in a normal demand analysis @@ -177,7 +176,7 @@ dmdAnal env dmd (App fun arg) -- Non-type arguments call_dmd = mkCallDmd dmd (fun_ty, fun') = dmdAnal env call_dmd fun (arg_dmd, res_ty) = splitDmdTy fun_ty - (arg_ty, arg') = dmdAnalArg env arg_dmd arg + (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg in -- pprTrace "dmdAnal:app" (vcat -- [ text "dmd =" <+> ppr dmd @@ -510,6 +509,7 @@ dmdTransform env var dmd | otherwise -- Local non-letrec-bound thing = unitVarDmd var (mkOnceUsedDmd dmd) + \end{code} %************************************************************************ |