From 7e6bb343d1550982feec6b3b3255e55676b7f1db Mon Sep 17 00:00:00 2001
From: Joachim Breitner <mail@joachim-breitner.de>
Date: Mon, 6 Jan 2014 14:12:57 +0000
Subject: [PATCH] Speculative evaluate thunks known to Converge
This is an attempt to use the by-products of nested cpr analysis.
---
compiler/basicTypes/Demand.lhs | 11 +++++++++--
compiler/basicTypes/Id.lhs | 7 ++++++-
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 4fbf3ca18451..0e7996eea971 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 50b36419585b..9ad99f3e9956 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 03150c6e1237..422e3d07ad6b 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) }
--
GitLab