[commit: ghc] wip/T14068: Prevent inlining of loopified programs (b4ab3a5)

[git at git.haskell.org]

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

On branch  : wip/T14068
Link       : http://ghc.haskell.org/trac/ghc/changeset/b4ab3a5f1fa051be9c5689f7ecef16458b2d700d/ghc

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

commit b4ab3a5f1fa051be9c5689f7ecef16458b2d700d
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri Aug 4 15:34:11 2017 -0400

    Prevent inlining of loopified programs
    
    Previously, a recursive function is not inlineable. After loopification,
    it turns into a non-recursive function, and suddenly it is. While this
    is in general desirable, it has many knock-on effects, which makes it
    hard to evaluate and debug loopification. Therefore, this commit (tries to)
    prevent this inlining. When this results in no unfixable regressions,
    then we can tackle the next step.
    
    It is surprisingly hard to reliably prevent inlining, it seems, so I
    have been playing whack-a-mole a bit:
     * simpl_binds has two copies of the ids around, one in the env and one
       in the AST. If maybeLoopify changes only one of them, then things go wrong.
       Worked-around that for now, but probably not ideal.
       TODO: Apply maybeLoopify before entering simplTopBinds
     * Also, worker-wrapper needs to preserve the no-inlining better.


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

b4ab3a5f1fa051be9c5689f7ecef16458b2d700d
 compiler/coreSyn/CoreOpt.hs    | 8 +++++++-
 compiler/simplCore/Simplify.hs | 4 +++-
 compiler/stranal/WorkWrap.hs   | 1 +
 3 files changed, 11 insertions(+), 2 deletions(-)

diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index 605a679..550a0a7 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -673,8 +673,14 @@ loopificationJoinPointBinding_maybe bndr rhs
                      zapFragileIdInfo $
                      localiseId $
                      bndr
+
         -- RULES etc stay with bindr'
-        bndr' = zapIdTailCallInfo bndr
+        -- Also, previously, the function was recursive, and hence not inlineable.
+        -- To tread with caution, let's keep it this way
+        bndr' = (`setIdUnfolding` noUnfolding) $
+                (`setInlinePragma` neverInlinePragma) $
+                zapIdTailCallInfo $
+                bndr
     in  Just (bndr', join_bndr, mkLams bndrs body)
 
   | otherwise
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 7eaf96a..6e75a80 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -145,7 +145,9 @@ simplTopBinds env0 binds0
                                       ; return (float `addFloats` floats, env2) }
 
     simpl_bind env bind | Just bind' <- maybeLoopify bind
-                        = simpl_bind env bind'
+                        = do -- update the env, as maybeLoopify changes the id info
+                             env1 <- simplRecBndrs env (bindersOf bind')
+                             simpl_bind env1 bind'
     simpl_bind env (Rec pairs)  = simplRecBind env TopLevel Nothing pairs
     simpl_bind env (NonRec b r) = do { (env', b') <- addBndrRules env b (lookupRecBndr env b)
                                      ; simplRecOrTopPair env' TopLevel
diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs
index ac8798e..49045d9 100644
--- a/compiler/stranal/WorkWrap.hs
+++ b/compiler/stranal/WorkWrap.hs
@@ -479,6 +479,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
             work_act = case work_inline of
               -- See Note [Activation for workers]
               NoInline -> inl_act inl_prag
+              NoUserInline | isNeverActive (inl_act inl_prag) -> inl_act inl_prag
               _        -> wrap_act
             work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
                                      , inl_inline = work_inline