X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FDmdAnal.lhs;fp=compiler%2Fstranal%2FDmdAnal.lhs;h=e8aa22c326d7b7a5a9c6bee192b0af5b25bf6686;hp=4660aad56a95160871da7e4f630d68fdb1f53134;hb=71c7067b7cc2b06265c97190e6a09c272ad7a175;hpb=979c11345ee532a4fc56aab54f51d2924c0ea841 diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 4660aad..e8aa22c 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -32,7 +32,7 @@ import TyCon ( isProductTyCon, isRecursiveTyCon ) import Id ( Id, idType, idInlineActivation, isDataConWorkId, isGlobalId, idArity, idStrictness, idStrictness_maybe, - setIdStrictness, idDemandInfo, + setIdStrictness, idDemandInfo, idUnfolding, idDemandInfo_maybe, setIdDemandInfo ) @@ -205,14 +205,14 @@ dmdAnal sigs dmd (Lam var body) = let sigs' = extendSigsWithLam sigs var (body_ty, body') = dmdAnal sigs' body_dmd body - (lam_ty, var') = annotateLamIdBndr body_ty var + (lam_ty, var') = annotateLamIdBndr sigs body_ty var in (lam_ty, Lam var' body') | otherwise -- Not enough demand on the lambda; but do the body = let -- anyway to annotate it and gather free var info (body_ty, body') = dmdAnal sigs evalDmd body - (lam_ty, var') = annotateLamIdBndr body_ty var + (lam_ty, var') = annotateLamIdBndr sigs body_ty var in (deferType lam_ty, Lam var' body') @@ -728,17 +728,27 @@ annotateBndr dmd_ty@(DmdType fv ds res) var annotateBndrs = mapAccumR annotateBndr -annotateLamIdBndr :: DmdType -- Demand type of body +annotateLamIdBndr :: SigEnv + -> DmdType -- Demand type of body -> Id -- Lambda binder -> (DmdType, -- Demand type of lambda Id) -- and binder annotated with demand -annotateLamIdBndr dmd_ty@(DmdType fv ds res) id +annotateLamIdBndr sigs dmd_ty@(DmdType fv ds res) id -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) - (DmdType fv' (hacked_dmd:ds) res, setIdDemandInfo id hacked_dmd) + (final_ty, setIdDemandInfo id hacked_dmd) where + -- Watch out! See note [Lambda-bound unfoldings] + final_ty = case maybeUnfoldingTemplate (idUnfolding id) of + Nothing -> main_ty + Just unf -> main_ty `bothType` unf_ty + where + (unf_ty, _) = dmdAnal sigs dmd unf + + main_ty = DmdType fv' (hacked_dmd:ds) res + (fv', dmd) = removeFV fv id res hacked_dmd = argDemand dmd -- This call to argDemand is vital, because otherwise we label @@ -764,6 +774,16 @@ zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd | otherwise = dmd \end{code} +Note [Lamba-bound unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow a lambda-bound variable to carry an unfolding, a facility that is used +exclusively for join points; see Note [Case binders and join points]. If so, +we must be careful to demand-analyse the RHS of the unfolding! Example + \x. \y{=Just x}. +Then if uses 'y', then transitively it uses 'x', and we must not +forget that fact, otherwise we might make 'x' absent when it isn't. + + %************************************************************************ %* * \subsection{Strictness signatures}