diff options
| author | Joachim Breitner <mail@joachim-breitner.de> | 2013-12-09 18:40:09 +0000 |
|---|---|---|
| committer | Joachim Breitner <mail@joachim-breitner.de> | 2013-12-16 22:08:06 +0100 |
| commit | 0e2fd365301748ac7535ed15f46d159814b71438 (patch) | |
| tree | 9cd25d509eefc61115b350f7c34f2d3e1e4b107e /compiler/stranal | |
| parent | 72b62242288d23299d77245faed8c5fc4dab1d4f (diff) | |
| download | haskell-0e2fd365301748ac7535ed15f46d159814b71438.tar.gz | |
Make types of bothDmdType more precise
by only passing the demand on the free variables, and whether the
argument (resp. scrunitee) may or will diverge.
Diffstat (limited to 'compiler/stranal')
| -rw-r--r-- | compiler/stranal/DmdAnal.lhs | 9 |
1 files changed, 4 insertions, 5 deletions
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index cbdcc67736..a942c4eab6 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -115,7 +115,7 @@ dmdTransformThunkDmd e -- See |-* relation in the companion paper dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* - -> CoreExpr -> (DmdType, CoreExpr) + -> CoreExpr -> (BothDmdArg, CoreExpr) dmdAnalStar env dmd e | (cd, defer_and_use) <- toCleanDmd dmd , (dmd_ty, e') <- dmdAnal env cd e @@ -255,7 +255,7 @@ dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) scrut_dmd = scrut_dmd1 `bothCleanDmd` scrut_dmd2 (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut - res_ty = alt_ty1 `bothDmdType` scrut_ty + res_ty = alt_ty1 `bothDmdType` toBothDmdArg scrut_ty in -- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd @@ -271,7 +271,7 @@ dmdAnal env dmd (Case scrut case_bndr ty alts) (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd) alts (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr - res_ty = alt_ty `bothDmdType` scrut_ty + res_ty = alt_ty `bothDmdType` toBothDmdArg scrut_ty in -- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut -- , text "scrut_ty" <+> ppr scrut_ty @@ -509,7 +509,6 @@ dmdTransform env var dmd | otherwise -- Local non-letrec-bound thing = unitVarDmd var (mkOnceUsedDmd dmd) - \end{code} %************************************************************************ @@ -698,7 +697,7 @@ addVarDmd (DmdType fv ds res) var dmd addLazyFVs :: DmdType -> DmdEnv -> DmdType addLazyFVs dmd_ty lazy_fvs - = dmd_ty `bothDmdType` mkDmdType lazy_fvs [] topRes + = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs -- Using bothDmdType (rather than just both'ing the envs) -- is vital. Consider -- let f = \x -> (x,y) |