Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : cardinality
http://hackage.haskell.org/trac/ghc/changeset/b6e84e771c6d1e2a7e995c237ea232ef39125a7f >--------------------------------------------------------------- commit b6e84e771c6d1e2a7e995c237ea232ef39125a7f Author: Ilya Sergey <[email protected]> Date: Tue Sep 4 18:41:56 2012 +0100 some enhancements >--------------------------------------------------------------- compiler/basicTypes/Demand.lhs | 20 ++++---------------- compiler/stranal/DmdAnal.lhs | 5 +++-- 2 files changed, 7 insertions(+), 18 deletions(-) diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index e512ef5..7ac53a9 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -308,8 +308,8 @@ instance LatticeLike AbsDmd where | length ux1 == length ux2 = absProd Many $ zipWith both ux1 ux2 -- is it correct? -- explain! -- possibly, wrong... - --both (UCall _ u1) (UCall _ u2) = absCall Many (u1 `lub` u2) - both (UCall _ u1) (UCall _ u2) = absCall Many (u1 `both` u2) + both (UCall _ u1) (UCall _ u2) = absCall Many (u1 `lub` u2) + -- both (UCall _ u1) (UCall _ u2) = absCall Many (u1 `both` u2) both _ _ = top -- utility functions @@ -325,7 +325,7 @@ markAsUsed Abs = Abs markAsUsed (Used _) = Used Many markAsUsed (UHead _) = UHead Many markAsUsed (UProd _ x) = UProd Many $ map markAsUsed x -markAsUsed (UCall _ x) = UCall Many $ markAsUsed x +markAsUsed (UCall _ x) = markAsUsed x seqAbsDmd :: AbsDmd -> () seqAbsDmd (Used c) = c `seq` () @@ -381,18 +381,6 @@ instance Binary AbsDmd where ux <- get bh return $ absProd c ux - -- get bh = do - -- h <- getByte bh - -- case h of - -- 0 -> return Abs - -- 1 -> return Used Many - -- 2 -> return UHead Many - -- 3 -> do u <- get bh - -- return $ absCall Many u - -- _ -> do ux <- get bh - -- return $ absProd Many ux - - -- Splitting polymorphic demands replicateAbsDmd :: Int -> AbsDmd -> [AbsDmd] replicateAbsDmd n Abs = replicate n Abs @@ -533,7 +521,7 @@ should be: <L,C(U(AU))>m mkCallDmd :: JointDmd -> JointDmd mkCallDmd (JD {strd = d, absd = a}) - = mkJointDmd (strCall d) (absCall Many a) + = mkJointDmd (strCall d) (absCall One a) -- TODO: think how to peel peelCallDmd :: JointDmd -> Maybe JointDmd diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 4eb8a79..394110a 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -393,10 +393,10 @@ dmdTransform env var dmd ------ LOCAL LET/REC BOUND THING | Just (StrictSig dmd_ty, top_lvl) <- lookupSigEnv env var - = pprTrace "dmdTransform-Local" (vcat [ppr var, ppr dmd, ppr dmd_ty]) $ + = -- pprTrace "dmdTransform-Local" (vcat [ppr var, ppr dmd, ppr dmd_ty]) $ let fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty - | otherwise = deferType dmd_ty + | otherwise = (deferType . markAsUsedType) dmd_ty -- NB: it's important to use deferType, and not just return topDmdType -- Consider let { f x y = p + x } in f 1 -- The application isn't saturated, but we must nevertheless propagate @@ -509,6 +509,7 @@ dmdAnalRhs top_lvl rec_flag env (id, rhs) where arity = idArity id -- The idArity should be up to date -- The simplifier was run just beforehand + (rhs_dmd_ty, rhs') = dmdAnal env (vanillaCall arity) rhs (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id ) -- The RHS can be eta-reduced to just a variable, _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
