diff options
| author | Joachim Breitner <mail@joachim-breitner.de> | 2014-01-06 14:12:57 +0000 |
|---|---|---|
| committer | Joachim Breitner <mail@joachim-breitner.de> | 2014-01-09 17:31:47 +0000 |
| commit | 7e6bb343d1550982feec6b3b3255e55676b7f1db (patch) | |
| tree | a56f7e8ff39e0ca5bc1fcf2437e6798fb27211ff | |
| parent | fca15ac53af8308608a44d6e7b9faaff1cf30d70 (diff) | |
| download | haskell-wip/cbv-conv-thunk.tar.gz | |
Speculative evaluate thunks known to Convergewip/cbv-conv-thunk
This is an attempt to use the by-products of nested cpr analysis.
| -rw-r--r-- | compiler/basicTypes/Demand.lhs | 11 | ||||
| -rw-r--r-- | compiler/basicTypes/Id.lhs | 7 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.lhs | 2 |
3 files changed, 16 insertions, 4 deletions
diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs index 4fbf3ca184..0e7996eea9 100644 --- a/compiler/basicTypes/Demand.lhs +++ b/compiler/basicTypes/Demand.lhs @@ -27,9 +27,9 @@ module Demand ( peelFV, DmdResult, CPRResult, - isBotRes, isTopRes, resTypeArgDmd, + isBotRes, isTopRes, resTypeArgDmd, topRes, convRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes, - appIsBottom, isBottomingSig, isConvSig, pprIfaceStrictSig, + appIsBottom, isBottomingSig, isConvSig, pprIfaceStrictSig, trimCPRInfo, returnsCPR, returnsCPR_maybe, StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig, convergeSig, isNopSig, splitStrictSig, increaseStrictSigArity, @@ -812,6 +812,10 @@ isBotRes :: DmdResult -> Bool isBotRes Diverges = True isBotRes _ = False +isConvRes :: DmdResult -> Bool +isConvRes (Converges {}) = True +isConvRes _ = False + trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult trimCPRInfo trim_all trim_sums res = trimR res @@ -1439,6 +1443,9 @@ isNopSig (StrictSig ty) = isNopDmdType ty isBottomingSig :: StrictSig -> Bool isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res +isConvSig :: StrictSig -> Bool +isConvSig (StrictSig (DmdType _ _ res)) = isConvRes res + nopSig, botSig :: StrictSig nopSig = StrictSig nopDmdType botSig = StrictSig botDmdType diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 50b3641958..9ad99f3e99 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -47,7 +47,7 @@ module Id ( -- ** Predicates on Ids isImplicitId, isDeadBinder, - isStrictId, + isStrictId, isConvId, isExportedId, isLocalId, isGlobalId, isRecordSelector, isNaughtyRecordSelector, isClassOpId_maybe, isDFunId, @@ -495,6 +495,11 @@ isStrictId id -- Take the best of both strictnesses - old and new (isStrictDmd (idDemandInfo id)) +isConvId :: Id -> Bool +isConvId id + = ASSERT2( isId id, text "isConvId: not an id: " <+> ppr id ) + (isConvSig (idStrictness id)) + --------------------------------- -- UNFOLDING idUnfolding :: Id -> Unfolding diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 03150c6e12..422e3d07ad 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1347,7 +1347,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } - | isStrictId bndr -> -- Includes coercions + | isStrictId bndr || isConvId bndr -> -- Includes coercions do { simplExprF (rhs_se `setFloats` env) rhs (StrictBind bndr bndrs body env cont) } |