Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : new-demand
http://hackage.haskell.org/trac/ghc/changeset/454769260ba6c93039faa042135e43c7e254c77c >--------------------------------------------------------------- commit 454769260ba6c93039faa042135e43c7e254c77c Author: Ilya Sergey <[email protected]> Date: Tue Aug 14 14:35:13 2012 +0100 let-floating bug fixed >--------------------------------------------------------------- compiler/basicTypes/Id.lhs | 6 +++- compiler/basicTypes/NewDemand.lhs | 7 +++-- compiler/simplCore/Simplify.lhs | 8 ++++-- compiler/stranal/NewWorkWrap.lhs | 9 ++++--- compiler/stranal/NewWwLib.lhs | 40 ++++++++++++++++++------------------ 5 files changed, 38 insertions(+), 32 deletions(-) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 5416258..b319052 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -520,8 +520,10 @@ nd_zapIdStrictness id = modifyIdInfo (`nd_setStrictnessInfo` ND.topSig) id isStrictId :: Id -> Bool isStrictId id = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) - (isStrictDmd (idDemandInfo id)) || - (isStrictType (idType id)) + ((isStrictDmd (idDemandInfo id)) || + (isStrictType (idType id))) || + -- Take the best of both strictnesses - old and new + (ND.isStrictDmd (nd_idDemandInfo id)) --------------------------------- -- UNFOLDING diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs index 5f2af35..f11ffb7 100644 --- a/compiler/basicTypes/NewDemand.lhs +++ b/compiler/basicTypes/NewDemand.lhs @@ -493,9 +493,10 @@ replicateDmd n (JD {strd=x, absd=y}) = zipWith mkJointDmd (replicateStrDmd n x) -- Check whether is a product demand isProdDmd :: Demand -> Bool -isProdDmd (JD {strd = SProd _}) = True -isProdDmd (JD {absd = UProd _}) = True -isProdDmd _ = False +isProdDmd (JD {strd = SProd _, absd = UProd _}) = True +isProdDmd (JD {strd = SProd _, absd = a}) = isPolyAbsDmd a +isProdDmd (JD {strd = s, absd = UProd _}) = isPolyStrDmd s +isProdDmd _ = False isPolyDmd :: Demand -> Bool isPolyDmd (JD {strd=a, absd=b}) = isPolyStrDmd a && isPolyAbsDmd b diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index c94b05e..5c8e19d 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -681,11 +681,13 @@ completeBind env top_lvl old_bndr new_bndr new_rhs -- We also have to nuke demand info if for some reason -- eta-expansion *reduces* the arity of the binding to less -- than that of the strictness sig. This can happen: see Note [Arity decrease]. - info3 | withNewDemand dflags && (isEvaldUnfolding new_unfolding + info3 | withNewDemand dflags + , isEvaldUnfolding new_unfolding || (case nd_strictnessInfo info2 of - ND.StrictSig dmd_ty -> new_arity < ND.dmdTypeDepth dmd_ty)) + ND.StrictSig dmd_ty -> new_arity < ND.dmdTypeDepth dmd_ty) = nd_zapDemandInfo info2 `orElse` info2 - | (not $ withNewDemand dflags) && isEvaldUnfolding new_unfolding + | not $ withNewDemand dflags + , isEvaldUnfolding new_unfolding || (case strictnessInfo info2 of Just (StrictSig dmd_ty) -> new_arity < dmdTypeDepth dmd_ty Nothing -> False) diff --git a/compiler/stranal/NewWorkWrap.lhs b/compiler/stranal/NewWorkWrap.lhs index a8261e4..b921844 100644 --- a/compiler/stranal/NewWorkWrap.lhs +++ b/compiler/stranal/NewWorkWrap.lhs @@ -465,9 +465,9 @@ worthSplittingFun ds res -- See Note [Worker-wrapper for bottoming functions] worth_it (JD {strd=HyperStr, absd=a}) = isUsed a -- A Hyper-strict argument, safe to do W/W -- See not [Worthy functions for Worker-Wrapper split] - 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 (JD {strd=SProd _}) = True -- Product arg to evaluate + worth_it (JD {strd=Str, absd=UProd _}) = True -- Strictly used product arg worth_it _ = False worthSplittingThunk :: Demand -- Demand on the thunk @@ -477,9 +477,10 @@ worthSplittingThunk dmd res = worth_it dmd || returnsCPR res where -- Split if the thing is unpacked - worth_it (JD {strd=SProd _, absd=a}) = someCompUsed a + worth_it (JD {strd=SProd _, absd=a}) = someCompUsed a + worth_it (JD {strd=Str, absd=UProd _}) = True -- second component points out that at least some of - worth_it _ = False + worth_it _ = False \end{code} Note [Worthy functions for Worker-Wrapper split] diff --git a/compiler/stranal/NewWwLib.lhs b/compiler/stranal/NewWwLib.lhs index 5acb0ee..78378b1 100644 --- a/compiler/stranal/NewWwLib.lhs +++ b/compiler/stranal/NewWwLib.lhs @@ -380,26 +380,6 @@ mkWWstr_one dflags arg JD {absd=Abs} | Just work_fn <- mk_absent_let dflags arg -> return ([], nop_fn, work_fn) - -- Unpack case, - -- see note [Unpacking arguments with product and polymorphic demands] - d | isStrictDmd d && isUsedDmd d - , 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 - -- otherwise is polymorphic demand - else replicateDmd (length inst_con_arg_tys) d - -> do uniqs <- getUniquesM - let - unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys - unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs - unbox_fn = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con - rebox_fn = Let (NonRec arg con_app) - con_app = mkProductBox unpk_args (idType arg) - (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds - return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) - -- Don't pass the arg, rebox instead - -- `seq` demand; evaluate in wrapper in the hope -- of dropping seqs in the worker JD {strd=Str, absd=UHead} @@ -422,6 +402,26 @@ mkWWstr_one dflags arg -- But the Evald flag is pretty weird, and I worry that it might disappear -- during simplification, so for now I've just nuked this whole case + -- Unpack case, + -- see note [Unpacking arguments with product and polymorphic demands] + d | isStrictDmd d && isUsedDmd d + , 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 + -- otherwise is polymorphic demand + else replicateDmd (length inst_con_arg_tys) d + -> do uniqs <- getUniquesM + let + unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys + unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs + unbox_fn = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con + rebox_fn = Let (NonRec arg con_app) + con_app = mkProductBox unpk_args (idType arg) + (worker_args, wrap_fn, work_fn) <- mkWWstr dflags unpk_args_w_ds + return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) + -- Don't pass the arg, rebox instead + -- Other cases _other_demand -> return ([arg], nop_fn, nop_fn) _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
