[commit: ghc] wip/T9388: Introduce the new state hack in the demand analyzer (c76f59b)

[git at git.haskell.org]

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

On branch  : wip/T9388
Link       : http://ghc.haskell.org/trac/ghc/changeset/c76f59b6d6cdea0b1ae8449e13777f9b9bfae80e/ghc

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

commit c76f59b6d6cdea0b1ae8449e13777f9b9bfae80e
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Sun Feb 22 10:36:15 2015 +0100

    Introduce the new state hack in the demand analyzer
    
    The new state hack, as proposed by SPJ in #9388, applies only to bound
    expressions. It is implemented by constructing an artificial incoming demand that claims that it is called at most once.
    
    (Currently, it also applies to non-top-level let-bound expressions. This
    needs to be revisited.)


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

c76f59b6d6cdea0b1ae8449e13777f9b9bfae80e
 compiler/basicTypes/Demand.hs |  5 ++++-
 compiler/basicTypes/Id.hs     |  7 ++++++-
 compiler/stranal/DmdAnal.hs   | 11 ++++++++---
 3 files changed, 18 insertions(+), 5 deletions(-)

diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs
index ecf22bc..7b08a71 100644
--- a/compiler/basicTypes/Demand.hs
+++ b/compiler/basicTypes/Demand.hs
@@ -37,7 +37,7 @@ module Demand (
 
         seqDemand, seqDemandList, seqDmdType, seqStrictSig,
 
-        evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,
+        evalDmd, cleanEvalDmd, cleanEvalProdDmd, cleanEvalStateHackDmd, isStrictDmd,
         splitDmdTy, splitFVs,
         deferAfterIO,
         postProcessUnsat, postProcessDmdTypeM,
@@ -634,6 +634,9 @@ cleanEvalDmd = mkCleanDmd HeadStr Used
 cleanEvalProdDmd :: Arity -> CleanDemand
 cleanEvalProdDmd n = mkCleanDmd HeadStr (UProd (replicate n useTop))
 
+cleanEvalStateHackDmd :: CleanDemand
+cleanEvalStateHackDmd = mkCleanDmd HeadStr (mkUCall One Used)
+
 isSingleUsed :: JointDmd -> Bool
 isSingleUsed (JD {absd=a}) = is_used_once a
   where
diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 23d9c30..7459cc1 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -71,7 +71,7 @@ module Id (
         isOneShotBndr, isOneShotLambda, isProbablyOneShotLambda,
         setOneShotLambda, clearOneShotLambda,
         updOneShotInfo, setIdOneShotInfo,
-        isStateHackType,
+        isStateHackType, isStateHackFunType,
 
         -- ** Reading 'IdInfo' fields
         idArity,
@@ -674,6 +674,11 @@ isStateHackType ty
         -- Another good example is in fill_in in PrelPack.hs.  We should be able to
         -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
 
+isStateHackFunType :: Type -> Bool
+isStateHackFunType ty
+  = case splitFunTy_maybe ty of
+        Just (arg_ty, _) -> isStateHackType arg_ty
+        Nothing -> False
 
 -- | Returns whether the lambda associated with the 'Id' is certainly applied at most once.
 -- You probably want to use 'isOneShotBndr' instead
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
index 27fa35f..d615562 100644
--- a/compiler/stranal/DmdAnal.hs
+++ b/compiler/stranal/DmdAnal.hs
@@ -619,9 +619,14 @@ dmdAnalRhs top_lvl rec_flag env id rhs
         -- See Note [NOINLINE and strictness]
 
     -- See Note [Product demands for function body]
-    body_dmd = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of
-                 Nothing            -> cleanEvalDmd
-                 Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
+    body_dmd
+        | Just (dc, _, _, _) <- deepSplitProductType_maybe (ae_fam_envs env) (exprType body)
+        = cleanEvalProdDmd (dataConRepArity dc)
+        | isStateHackFunType $ topNormaliseType (ae_fam_envs env) (exprType body)
+        = -- pprTrace "new state hack" (ppr (exprType body)) $
+          cleanEvalStateHackDmd
+        | otherwise
+        = cleanEvalDmd
 
     -- See Note [Lazy and unleashable free variables]
     -- See Note [Aggregated demand for cardinality]