[commit: ghc] wip/T14068: Loopification: Keep IdInfo on the outer binder (deab10c)

[git at git.haskell.org]

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

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

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

commit deab10c80b98655cdf9ed22addaba8b0966797e0
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Aug 1 11:43:15 2017 -0400

    Loopification: Keep IdInfo on the outer binder
    
    e.g. RULES should be unaffected. Also localise the inner binder.


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

deab10c80b98655cdf9ed22addaba8b0966797e0
 compiler/coreSyn/CoreOpt.hs    | 14 +++++++++++---
 compiler/simplCore/Simplify.hs |  3 +--
 2 files changed, 12 insertions(+), 5 deletions(-)

diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index 88f7b41..5949cf6 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -651,7 +651,8 @@ joinPointBinding_maybe bndr rhs
   = Nothing
 
 -- | like joinPointBinding_maybe, but looks for RecursiveTailCalled
-loopificationJoinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)
+-- Returns both the new outer and the new inner binder
+loopificationJoinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InBndr, InExpr)
 loopificationJoinPointBinding_maybe bndr rhs
   | not (isId bndr)
   = Nothing
@@ -664,8 +665,15 @@ loopificationJoinPointBinding_maybe bndr rhs
   , not (badUnfoldingForJoin join_arity bndr)
   , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
   = let occ' = occ { occ_tail = AlwaysTailCalled join_arity }
-        bndr' = setIdOccInfo bndr occ'
-    in  Just (bndr' `asJoinId` join_arity, mkLams bndrs body)
+        -- What all do we have to zap?
+        join_bndr = (`asJoinId` join_arity) $
+                     (`setIdOccInfo` occ') $
+                     zapFragileIdInfo $
+                     localiseId $
+                     bndr
+        -- RULES etc stay with bindr'
+        bndr' = zapIdTailCallInfo bndr
+    in  Just (bndr', join_bndr, mkLams bndrs body)
 
   | otherwise
   = Nothing
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 362989e..c612b2f 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -1668,10 +1668,9 @@ simplRecE env pairs body cont
 -- lets loopify it and simplify that
 maybeLoopify :: InBind -> Maybe InBind
 maybeLoopify (Rec [(bndr, rhs)])
-  | Just (join_bndr, join_rhs) <- loopificationJoinPointBinding_maybe bndr rhs
+  | Just (bndr', join_bndr, join_rhs) <- loopificationJoinPointBinding_maybe bndr rhs
   = do  { let Just arity = isJoinId_maybe join_bndr
         ; let (join_params, _join_body) = collectNBinders arity join_rhs
-        ; let bndr' = zapFragileIdInfo bndr -- TODO: What do we have to zap here?
         ; let rhs' = mkLams join_params $
                      mkLetRec [(join_bndr,join_rhs)] $
                      mkVarApps (Var join_bndr) join_params