Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : cardinality
http://hackage.haskell.org/trac/ghc/changeset/8adb606c9c4bb139a76d1c2bd56b6004946ddf5a >--------------------------------------------------------------- commit 8adb606c9c4bb139a76d1c2bd56b6004946ddf5a Author: ilyasergey <ilya.ser...@gmail.com> Date: Thu Nov 8 16:34:35 2012 +0100 product demand machinery adapted to handle cardinality >--------------------------------------------------------------- compiler/basicTypes/Demand.lhs | 20 ++++++++++---------- compiler/basicTypes/MkId.lhs | 2 +- compiler/specialise/SpecConstr.lhs | 2 +- compiler/stranal/DmdAnal.lhs | 5 +++-- compiler/stranal/WwLib.lhs | 2 +- 5 files changed, 16 insertions(+), 15 deletions(-) diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index 6e333f2..2f29da5 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -242,7 +242,7 @@ isUsedOnce Abs = True isUsedOnce (Used One) = True isUsedOnce (UHead One) = True isUsedOnce (UCall One _) = True -isUsedOnce (UProd One ux) = all isUsedOnce ux +isUsedOnce (UProd One ux) = True isUsedOnce _ = False absCall :: Count -> AbsDmd -> AbsDmd @@ -417,12 +417,12 @@ mkJointDmd s a (HyperStr, UProd c _) -> JD {strd = HyperStr, absd = Used c} _ -> JD {strd = s, absd = a} -mkProdDmd :: [JointDmd] -> JointDmd -mkProdDmd dx +mkProdDmd :: Count -> [JointDmd] -> JointDmd +mkProdDmd c dx = mkJointDmd sp up where sp = strProd $ map strd dx - up = absProd One $ map absd dx + up = absProd c $ map absd dx instance LatticeLike JointDmd where bot = mkJointDmd bot bot @@ -621,15 +621,15 @@ isPolyDmd :: Demand -> Bool isPolyDmd (JD {strd=a, absd=b}) = isPolyStrDmd a && isPolyAbsDmd b -- Split a product to parameteres -splitProdDmd :: Demand -> [Demand] -splitProdDmd JD {strd=SProd sx, absd=UProd _ ux} - = ASSERT( sx `lengthIs` (length ux) ) zipWith mkJointDmd sx ux +splitProdDmd :: Demand -> (Count, [Demand]) +splitProdDmd JD {strd=SProd sx, absd=UProd c ux} + = ASSERT( sx `lengthIs` (length ux) ) (c, zipWith mkJointDmd sx ux) splitProdDmd JD {strd=SProd sx, absd=u} | isPolyAbsDmd u - = zipWith mkJointDmd sx (replicateAbsDmd (length sx) u) -splitProdDmd (JD {strd=s, absd=UProd _ ux}) + = (card u, zipWith mkJointDmd sx (replicateAbsDmd (length sx) u)) +splitProdDmd (JD {strd=s, absd=UProd c ux}) | isPolyStrDmd s - = zipWith mkJointDmd (replicateStrDmd (length ux) s) ux + = (c, zipWith mkJointDmd (replicateStrDmd (length ux) s) ux) splitProdDmd d = pprPanic "splitProdDmd" (ppr d) \end{code} diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 05b45ab..25c7453 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -486,7 +486,7 @@ mkDictSelId dflags no_unf name clas strict_sig = mkStrictSig (mkTopDmdType [arg_dmd] topRes) arg_dmd | new_tycon = evalDmd - | otherwise = mkProdDmd [ if the_arg_id == id then evalDmd else absDmd + | otherwise = mkProdDmd Many [ if the_arg_id == id then evalDmd else absDmd | id <- arg_ids ] diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs index 08d06ad..ab9ef85 100644 --- a/compiler/specialise/SpecConstr.lhs +++ b/compiler/specialise/SpecConstr.lhs @@ -1439,7 +1439,7 @@ calcSpecStrictness fn qvars pats go_one env d (Var v) = extendVarEnv_C both env v d go_one env d e | isProdDmd d - , ds <- splitProdDmd d + , (_, ds) <- splitProdDmd d , (Var _, args) <- collectArgs e = go env ds args go_one env _ _ = env diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 569c3ea..e6a1757 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -243,7 +243,8 @@ dmdAnal dflags _ env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) -- The insight is, of course, that a demand on y is a demand on the -- scrutinee, so we need to `both` it with the scrut demand - alt_dmd = mkProdDmd [idDemandInfo b | b <- bndrs', isId b] + alt_dmd = mkProdDmd One [idDemandInfo b | b <- bndrs', isId b] + -- the scrutinee is used just once scrut_dmd = alt_dmd `both` idDemandInfo case_bndr' @@ -561,7 +562,7 @@ dmdTransform env var dmd -- Invariant: res_dmd does not have call demand as its component arg_ds = if isPolyDmd res_dmd then replicateDmd arity res_dmd - else splitProdDmd res_dmd + else snd $ splitProdDmd res_dmd in mkDmdType emptyDmdEnv arg_ds con_res -- Must remember whether it's a product, hence con_res, not TopRes diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index 2ed5640..34312d3 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -432,7 +432,7 @@ mkWWstr_one dflags arg , isProdDmd d || isPolyDmd d , Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys) <- deepSplitProductType_maybe (idType arg) - , cs <- if isProdDmd d then splitProdDmd d + , cs <- if isProdDmd d then snd $ splitProdDmd d -- otherwise is polymorphic demand else replicateDmd (length inst_con_arg_tys) d -> do uniqs <- getUniquesM _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
