Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : new-demand
http://hackage.haskell.org/trac/ghc/changeset/0445bfaf0022e1388856c206a88cda7bad0863b0 >--------------------------------------------------------------- commit 0445bfaf0022e1388856c206a88cda7bad0863b0 Author: Ilya Sergey <[email protected]> Date: Fri Aug 10 17:14:25 2012 +0100 some fixes to improve WW results >--------------------------------------------------------------- compiler/coreSyn/CoreLint.lhs | 11 +++++------ compiler/simplCore/SimplUtils.lhs | 7 ++++--- compiler/simplCore/Simplify.lhs | 10 +++++----- compiler/stranal/NewDmdAnal.lhs | 1 + compiler/stranal/NewWorkWrap.lhs | 9 +++++---- 5 files changed, 20 insertions(+), 18 deletions(-) diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index ba6a147..e93526d 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -22,7 +22,7 @@ module CoreLint ( lintCoreBindings, lintUnfolding ) where #include "HsVersions.h" -import Demand +import NewDemand import CoreSyn import CoreFVs import CoreUtils @@ -205,16 +205,15 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) -- Check whether arity and demand type are consistent (only if demand analysis -- already happened) - ; checkL (case maybeDmdTy of - Just (StrictSig dmd_ty) -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs - Nothing -> True) + ; checkL (case dmdTy of + StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs) (mkArityMsg binder) } -- We should check the unfolding, if any, but this is tricky because -- the unfolding is a SimplifiableCoreExpr. Give up for now. where binder_ty = idType binder - maybeDmdTy = idStrictness_maybe binder + dmdTy = nd_idStrictness binder bndr_vars = varSetElems (idFreeVars binder) lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) | otherwise = return () @@ -1246,7 +1245,7 @@ mkArityMsg binder hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty] ] - where (StrictSig dmd_ty) = idStrictness binder + where (StrictSig dmd_ty) = nd_idStrictness binder mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc mkCastErr expr co from_ty expr_ty diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 87aefba..fdfc045 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -52,7 +52,8 @@ import CoreUnfold import Name import Id import Var -import Demand +--import Demand +import NewDemand import SimplMonad import Type hiding( substTy ) import Coercion hiding( substCo, substTy ) @@ -400,7 +401,7 @@ mkArgInfo fun rules n_val_args call_cont vanilla_stricts = repeat False arg_stricts - = case splitStrictSig (idStrictness fun) of + = case splitStrictSig (nd_idStrictness fun) of (demands, result_info) | not (demands `lengthExceeds` n_val_args) -> -- Enough args, use the strictness given. @@ -1157,7 +1158,7 @@ tryEtaExpand env bndr rhs manifest_arity = manifestArity rhs old_arity = idArity bndr - _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr + _dmd_arity = length $ fst $ splitStrictSig $ nd_idStrictness bndr findArity :: DynFlags -> Id -> CoreExpr -> Arity -> Arity -- This implements the fixpoint loop for arity analysis diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index e2a2644..cf98cf1 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -33,7 +33,8 @@ import FamInstEnv ( topNormaliseType ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) import CoreMonad ( Tick(..), SimplifierMode(..) ) import CoreSyn -import Demand ( isStrictDmd, StrictSig(..), dmdTypeDepth ) +-- import Demand ( isStrictDmd, StrictSig(..), dmdTypeDepth ) +import qualified NewDemand as ND ( isStrictDmd, StrictSig(..), dmdTypeDepth ) import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold import CoreUtils @@ -680,9 +681,8 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- eta-expansion *reduces* the arity of the binding to less -- than that of the strictness sig. This can happen: see Note [Arity decrease]. info3 | isEvaldUnfolding new_unfolding - || (case strictnessInfo info2 of - Just (StrictSig dmd_ty) -> new_arity < dmdTypeDepth dmd_ty - Nothing -> False) + || (case nd_strictnessInfo info2 of + ND.StrictSig dmd_ty -> new_arity < ND.dmdTypeDepth dmd_ty) = zapDemandInfo info2 `orElse` info2 | otherwise = info2 @@ -1814,7 +1814,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont ok_for_spec = exprOkForSpeculation scrut is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect - strict_case_bndr = isStrictDmd (idDemandInfo case_bndr) + strict_case_bndr = ND.isStrictDmd (nd_idDemandInfo case_bndr) scrut_is_var (Cast s _) = scrut_is_var s scrut_is_var (Var _) = True diff --git a/compiler/stranal/NewDmdAnal.lhs b/compiler/stranal/NewDmdAnal.lhs index 88f5999..23e2b0c 100644 --- a/compiler/stranal/NewDmdAnal.lhs +++ b/compiler/stranal/NewDmdAnal.lhs @@ -184,6 +184,7 @@ dmdAnal env dmd (Lam var body) (deferType lam_ty, Lam var' body') dmdAnal env dmd (Case scrut case_bndr ty [alt@(DataAlt dc, _, _)]) + -- Only one alternative with a product constructor | let tycon = dataConTyCon dc , isProductTyCon tycon , not (isRecursiveTyCon tycon) diff --git a/compiler/stranal/NewWorkWrap.lhs b/compiler/stranal/NewWorkWrap.lhs index 28a41a9..6c3dbd8 100644 --- a/compiler/stranal/NewWorkWrap.lhs +++ b/compiler/stranal/NewWorkWrap.lhs @@ -463,10 +463,11 @@ worthSplittingFun ds res -- and hence do_strict_ww is False if arity is zero and there is no CPR -- See Note [Worker-wrapper for bottoming functions] where - worth_it (JD {strd=SProd _, absd=a}) = isUsed a -- Product arg to evaluate - worth_it (JD {strd=HyperStr, absd=a}) = isUsed a -- hyper-strict argument, safe to do W/W - worth_it (JD {absd=Abs}) = True -- Absent arg - worth_it _ = False + worth_it (JD {strd=HyperStr, absd=a}) = isUsed a -- A Hyper-strict argument, safe to do W/W + worth_it (JD {strd=SProd _, absd=a}) = isUsed a -- Product arg to evaluate + worth_it (JD {strd=Str, absd=UProd _}) = True -- Strictly used product arg + worth_it (JD {absd=Abs}) = True -- Absent arg + worth_it _ = False worthSplittingThunk :: Demand -- Demand on the thunk -> DmdResult -- CPR info for the thunk _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
