[commit: ghc] wip/cbv-conv-thunk: Speculative evaluate thunks known to Converge (7b543b7)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/cbv-conv-thunk
Link       : http://ghc.haskell.org/trac/ghc/changeset/7b543b7439c7e01fe765c7080fd7041360202dd8/ghc

>---------------------------------------------------------------

commit 7b543b7439c7e01fe765c7080fd7041360202dd8
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Mon Jan 6 14:12:57 2014 +0000

    Speculative evaluate thunks known to Converge
    
    This is an attempt to use the by-products of nested cpr analysis.


>---------------------------------------------------------------

7b543b7439c7e01fe765c7080fd7041360202dd8
 compiler/basicTypes/Demand.lhs  |    9 ++++++++-
 compiler/basicTypes/Id.lhs      |    7 ++++++-
 compiler/simplCore/Simplify.lhs |    4 ++--
 3 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/compiler/basicTypes/Demand.lhs b/compiler/basicTypes/Demand.lhs
index 2da8a2e..62a53d7 100644
--- a/compiler/basicTypes/Demand.lhs
+++ b/compiler/basicTypes/Demand.lhs
@@ -29,7 +29,7 @@ module Demand (
         DmdResult, CPRResult,
         isBotRes, isTopRes, resTypeArgDmd,
         topRes, botRes, cprProdRes, vanillaCprProdRes, cprSumRes,
-        appIsBottom, isBottomingSig, pprIfaceStrictSig, 
+        appIsBottom, isBottomingSig, isConvSig, pprIfaceStrictSig,
         trimCPRInfo, returnsCPR, returnsCPR_maybe,
         StrictSig(..), mkStrictSig, mkClosedStrictSig, nopSig, botSig, cprProdSig,
         isNopSig, splitStrictSig, increaseStrictSigArity,
@@ -803,6 +803,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
@@ -1405,6 +1409,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 50b3641..9ad99f3 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 03150c6..9cdb686 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -28,7 +28,7 @@ import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
 --import TyCon            ( isEnumerationTyCon ) -- temporalily commented out. See #8326
 import CoreMonad        ( Tick(..), SimplifierMode(..) )
 import CoreSyn
-import Demand           ( StrictSig(..), dmdTypeDepth )
+import Demand           ( StrictSig(..), dmdTypeDepth, splitStrictSig )
 import PprCore          ( pprParendExpr, pprCoreExpr )
 import CoreUnfold
 import CoreUtils
@@ -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) }