[commit: ghc] wip/T10918: First stab at #10918 (ab21472)

[git at git.haskell.org]

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

On branch  : wip/T10918
Link       : http://ghc.haskell.org/trac/ghc/changeset/ab214720d0f7e7d0d8ea1c998c9618c7dca6dda1/ghc

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

commit ab214720d0f7e7d0d8ea1c998c9618c7dca6dda1
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Thu Oct 1 23:22:19 2015 +0200

    First stab at #10918


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

ab214720d0f7e7d0d8ea1c998c9618c7dca6dda1
 compiler/simplCore/CallArity.hs  | 9 ++++++---
 compiler/simplCore/SimplUtils.hs | 2 +-
 2 files changed, 7 insertions(+), 4 deletions(-)

diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index c2a5ad0..24ee9bd 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -16,7 +16,7 @@ import CoreSyn
 import Id
 import CoreArity ( typeArity )
 import CoreUtils ( exprIsHNF )
---import Outputable
+-- import Outputable
 import UnVarGraph
 import Demand
 
@@ -500,7 +500,7 @@ callArityAnal arity int (Let bind e)
 -- Which bindings should we look at?
 -- See Note [Which variables are interesting]
 isInteresting :: Var -> Bool
-isInteresting v = 0 < length (typeArity (idType v))
+isInteresting v = True -- 0 < length (typeArity (idType v))
 
 interestingBinds :: CoreBind -> [Var]
 interestingBinds = filter isInteresting . bindersOf
@@ -521,7 +521,7 @@ callArityBind boring_vars ae_body int (NonRec v rhs)
   | otherwise
   = -- pprTrace "callArityBind:NonRec"
     --          (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])
-    (final_ae, NonRec v' rhs')
+    (final_ae, NonRec v'' rhs')
   where
     is_thunk = not (exprIsHNF rhs)
     -- If v is boring, we will not find it in ae_body, but always assume (0, False)
@@ -552,6 +552,9 @@ callArityBind boring_vars ae_body int (NonRec v rhs)
 
     v' = v `setIdCallArity` trimmed_arity
 
+    v'' | called_once = v' `setIdDemandInfo` oneifyDmd (idDemandInfo v')
+        | otherwise   = v'
+
 
 -- Recursive let. See Note [Recursion and fixpointing]
 callArityBind boring_vars ae_body int b@(Rec binds)
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
index 59d3a05..f8945b3 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -1038,7 +1038,7 @@ preInlineUnconditionally dflags env top_lvl bndr rhs
     act = idInlineActivation bndr
     try_once in_lam int_cxt     -- There's one textual occurrence
         | not in_lam = isNotTopLevel top_lvl || early_phase
-        | otherwise  = int_cxt && canInlineInLam rhs
+        | otherwise  = (int_cxt && canInlineInLam rhs) || isSingleUsed (idDemandInfo bndr)
 
 -- Be very careful before inlining inside a lambda, because (a) we must not
 -- invalidate occurrence information, and (b) we want to avoid pushing a