[commit: ghc] wip/dmd-arity: Check idArity matching depth of idStrictness again (5e75a1f)
git at git.haskell.org
git at git.haskell.org
Thu Mar 7 17:41:41 UTC 2019
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/dmd-arity
Link : http://ghc.haskell.org/trac/ghc/changeset/5e75a1f5cbdb67df7f1bfaf574b521b5a4cadf7e/ghc
>---------------------------------------------------------------
commit 5e75a1f5cbdb67df7f1bfaf574b521b5a4cadf7e
Author: Sebastian Graf <sebastian.graf at kit.edu>
Date: Fri Feb 8 14:18:51 2019 +0100
Check idArity matching depth of idStrictness again
This was deactivated in 848f5952, but it seems the special case for
trivial right-hand sides was removed and the invariant reinstated.
>---------------------------------------------------------------
5e75a1f5cbdb67df7f1bfaf574b521b5a4cadf7e
compiler/basicTypes/Demand.hs | 23 ++++++++---------------
compiler/coreSyn/CoreLint.hs | 21 +++++++++------------
compiler/coreSyn/CoreOpt.hs | 13 ++++++++-----
3 files changed, 25 insertions(+), 32 deletions(-)
diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index a4ba7c9..d33e21e 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -38,7 +38,7 @@ module Demand (
nopSig, botSig, cprProdSig,
isTopSig, hasDemandEnvSig,
splitStrictSig, strictSigDmdEnv,
- increaseStrictSigArity, etaExpandStrictSig,
+ increaseStrictSigArity,
seqDemand, seqDemandList, seqDmdType, seqStrictSig,
@@ -1207,7 +1207,7 @@ mkDmdType fv ds res = DmdType fv ds res
dmdTypeDepth :: DmdType -> Arity
dmdTypeDepth (DmdType _ ds _) = length ds
--- This makes sure we can use the demand type with n arguments,
+-- | This makes sure we can use the demand type with n arguments,
-- It extends the argument list with the correct resTypeArgDmd
-- It also adjusts the DmdResult: Divergence survives additional arguments,
-- CPR information does not (and definite converge also would not).
@@ -1586,25 +1586,18 @@ splitStrictSig :: StrictSig -> ([Demand], DmdResult)
splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
increaseStrictSigArity :: Int -> StrictSig -> StrictSig
--- Add extra arguments to a strictness signature
+-- ^ Add extra arguments to a strictness signature.
+-- In contrast to 'ensureArgs', this /prepends/ additional argument demands
+-- and leaves the 'DmdResult' intact.
increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res))
| isTopDmdType dmd_ty = sig
- | arity_increase <= 0 = sig
+ | arity_increase == 0 = sig
+ | arity_increase < 0 = WARN (True, text "increaseStrictSigArity: negative arity increase")
+ nopSig
| otherwise = StrictSig (DmdType env dmds' res)
where
dmds' = replicate arity_increase topDmd ++ dmds
-etaExpandStrictSig :: Arity -> StrictSig -> StrictSig
--- We are expanding (\x y. e) to (\x y z. e z)
--- Add exta demands to the /end/ of the arg demands if necessary
-etaExpandStrictSig arity sig@(StrictSig dmd_ty@(DmdType env dmds res))
- | isTopDmdType dmd_ty = sig
- | arity_increase <= 0 = sig
- | otherwise = StrictSig (DmdType env dmds' res)
- where
- arity_increase = arity - length dmds
- dmds' = dmds ++ replicate arity_increase topDmd
-
isTopSig :: StrictSig -> Bool
isTopSig (StrictSig ty) = isTopDmdType ty
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 62ddb9f..e9fd0c4 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -61,7 +61,7 @@ import InstEnv ( instanceDFunId )
import OptCoercion ( checkAxInstCo )
import UniqSupply
import CoreArity ( typeArity )
-import Demand ( splitStrictSig, isBotRes )
+import Demand
import HscTypes
import DynFlags
@@ -570,15 +570,12 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
(addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
-- Only non-rule loop breakers inhibit inlining
- -- Check whether arity and demand type are consistent (only if demand analysis
- -- already happened)
- --
- -- Note (Apr 2014): this is actually ok. See Note [Demand analysis for trivial right-hand sides]
- -- in DmdAnal. After eta-expansion in CorePrep the rhs is no longer trivial.
- -- ; let dmdTy = idStrictness binder
- -- ; checkL (case dmdTy of
- -- StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
- -- (mkArityMsg binder)
+ -- Check whether arity and demand type are consistent (only if demand analysis
+ -- already happened)
+ ; let StrictSig dmd_ty = idStrictness binder
+ ; checkL
+ (idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
+ (mkArityMsg binder)
-- Check that the binder's arity is within the bounds imposed by
-- the type and the strictness signature. See Note [exprArity invariant]
@@ -2562,20 +2559,20 @@ mkKindErrMsg tyvar arg_ty
hang (text "Arg type:")
4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-{- Not needed now
mkArityMsg :: Id -> MsgDoc
mkArityMsg binder
= vcat [hsep [text "Demand type has",
ppr (dmdTypeDepth dmd_ty),
text "arguments, rhs has",
ppr (idArity binder),
+ case isJoinId_maybe binder of Just ary -> ppr ary; _ -> empty,
text "arguments,",
ppr binder],
hsep [text "Binder's strictness signature:", ppr dmd_ty]
]
where (StrictSig dmd_ty) = idStrictness binder
--}
+
mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index d0dba81..151da04 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -37,7 +37,7 @@ import Var ( isNonCoVarId )
import VarSet
import VarEnv
import DataCon
-import Demand( etaExpandStrictSig )
+import Demand( ensureArgs, nopSig, StrictSig(..) )
import OptCoercion ( optCoercion )
import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
, isInScope, substTyVarBndr, cloneTyVarBndr )
@@ -678,10 +678,13 @@ joinPointBinding_maybe bndr rhs
| AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
, (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
- , let str_sig = idStrictness bndr
- str_arity = count isId bndrs -- Strictness demands are for Ids only
- join_bndr = bndr `asJoinId` join_arity
- `setIdStrictness` etaExpandStrictSig str_arity str_sig
+ , let StrictSig dmd_ty = idStrictness bndr
+ str_arity = count isId bndrs -- Strictness demands are for Ids only
+ new_str_sig
+ | str_arity < idArity bndr = nopSig
+ | otherwise = StrictSig $ ensureArgs str_arity dmd_ty
+ join_bndr = bndr `asJoinId` join_arity
+ `setIdStrictness` new_str_sig
= Just (join_bndr, mkLams bndrs body)
| otherwise
More information about the ghc-commits
mailing list