Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : cardinality
http://hackage.haskell.org/trac/ghc/changeset/b93d8ed23ae74f5271e930d1a7a3a410cdc335b1 >--------------------------------------------------------------- commit b93d8ed23ae74f5271e930d1a7a3a410cdc335b1 Author: Ilya Sergey <[email protected]> Date: Wed Sep 19 20:01:59 2012 +0100 and ad-hoc fix fo splitting environment problem >--------------------------------------------------------------- compiler/basicTypes/Demand.lhs | 15 ++++++++------- compiler/stranal/DmdAnal.lhs | 15 ++++++++++----- 2 files changed, 18 insertions(+), 12 deletions(-) diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index a809371..23483af 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -30,7 +30,7 @@ module Demand ( isProdDmd, isPolyDmd, replicateDmd, splitProdDmd, peelCallDmd, mkCallDmd, isProdUsage, -- cardinality stuff - markAsUsedType, isSingleUsed, isUsageCallDmd + markAsUsedType, markAsUsedEnv, isSingleUsed, isUsageCallDmd ) where #include "HsVersions.h" @@ -246,10 +246,12 @@ usedMany :: AbsDmd usedMany = (Used Many) isUsedOnce :: AbsDmd -> Bool -isUsedOnce Abs = True -isUsedOnce a - | One <- card a = True -isUsedOnce _ = False +isUsedOnce Abs = True +isUsedOnce (Used One) = True +isUsedOnce (UHead One) = True +isUsedOnce (UCall One _) = True +isUsedOnce (UProd One ux) = all isUsedOnce ux +isUsedOnce _ = False absCall :: Count -> AbsDmd -> AbsDmd absCall _ Abs = Abs @@ -331,7 +333,7 @@ markAsUsed Abs = Abs markAsUsed (Used _) = Used Many markAsUsed (UHead _) = UHead Many markAsUsed (UProd _ x) = UProd Many $ map markAsUsed x -markAsUsed (UCall _ x) = markAsUsed x +markAsUsed (UCall _ x) = UCall Many $ markAsUsed x seqAbsDmd :: AbsDmd -> () seqAbsDmd (Used c) = c `seq` () @@ -539,7 +541,6 @@ peelCallDmd (JD {strd = Str, absd = UCall c a}) = Just (mkJointDmd Lazy a, peelCallDmd (JD {strd = SCall d, absd = Used _}) = Just (mkJointDmd d top, Many) peelCallDmd _ = Nothing - splitCallDmd :: JointDmd -> (Int, JointDmd) splitCallDmd (JD {strd = SCall d, absd = UCall _ a}) = case splitCallDmd (mkJointDmd d a) of diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 1abc92b..f8f4256 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -664,7 +664,7 @@ annotateLamIdBndr env (DmdType fv ds res) id mkSigTy :: TopLevelFlag -> RecFlag -> AnalEnv -> Id -> CoreExpr -> DmdType -> (DmdEnv, StrictSig) mkSigTy top_lvl rec_flag env id rhs dmd_ty - = mk_sig_ty thunk_cpr_ok rhs dmd_ty + = mk_sig_ty thunk_cpr_ok rec_flag rhs dmd_ty where id_dmd = idDemandInfo id @@ -679,18 +679,23 @@ mkSigTy top_lvl rec_flag env id rhs dmd_ty | isStrictDmd id_dmd = True | otherwise = False -mk_sig_ty :: Bool -> CoreExpr -> DmdType -> (DmdEnv, StrictSig) -mk_sig_ty thunk_cpr_ok rhs (DmdType fv dmds res) - = (lazy_fv, mkStrictSig dmd_ty) +mk_sig_ty :: Bool -> RecFlag -> CoreExpr -> DmdType -> (DmdEnv, StrictSig) +mk_sig_ty thunk_cpr_ok rec_flag rhs (DmdType fv dmds res) + = (lazy_no_card, mkStrictSig dmd_ty) -- Re unused never_inline, see Note [NOINLINE and strictness] where dmd_ty = mkDmdType unleashed_fv dmds res' - -- See Note [Lazy and unleasheable free variables] lazy_fv = filterUFM (not . can_be_unleahsed) fv unleashed_fv = filterUFM can_be_unleahsed fv can_be_unleahsed d = isStrictDmd d + -- [TODO]: discuss if it is a good idea + -- A trade-off do not include lazy-single-used guys + lazy_no_card = case rec_flag of + Recursive -> markAsUsedEnv lazy_fv + NonRecursive -> lazy_fv + -- final_dmds = setUnpackStrategy dmds -- Set the unpacking strategy _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
