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

[git at git.haskell.org]

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

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

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

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

    First stab at #10918


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

02c6765facb2003272b03e6b8d9a33d9e1cee4c2
 compiler/simplCore/CallArity.hs  | 7 +++++--
 compiler/simplCore/SimplUtils.hs | 2 +-
 2 files changed, 6 insertions(+), 3 deletions(-)

diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
index bd997c3..9a59c22 100644
--- a/compiler/simplCore/CallArity.hs
+++ b/compiler/simplCore/CallArity.hs
@@ -510,7 +510,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
@@ -531,7 +531,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)
@@ -562,6 +562,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 1577efd..aa82ea4 100644
--- a/compiler/simplCore/SimplUtils.hs
+++ b/compiler/simplCore/SimplUtils.hs
@@ -1039,7 +1039,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