[commit: ghc] master: Zap stable unfoldings in worker/wrapper (87c5fdb)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/87c5fdbba118db1938d699951a811cc2f6206d4d/ghc

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

commit 87c5fdbba118db1938d699951a811cc2f6206d4d
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Jun 28 14:45:40 2017 +0100

    Zap stable unfoldings in worker/wrapper
    
    This patch fixes the buglet described in Trac #13890.


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

87c5fdbba118db1938d699951a811cc2f6206d4d
 compiler/basicTypes/Id.hs      | 9 +++++++--
 compiler/simplCore/Simplify.hs | 3 +--
 compiler/stranal/WwLib.hs      | 7 +++++--
 3 files changed, 13 insertions(+), 6 deletions(-)

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 8a5e28a..290e262 100644
--- a/compiler/basicTypes/Id.hs
+++ b/compiler/basicTypes/Id.hs
@@ -53,7 +53,7 @@ module Id (
         setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
         zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo,
         zapIdUsedOnceInfo, zapIdTailCallInfo,
-        zapFragileIdInfo, zapIdStrictness,
+        zapFragileIdInfo, zapIdStrictness, zapStableUnfolding,
         transferPolyIdInfo,
 
         -- ** Predicates on Ids
@@ -117,7 +117,7 @@ module Id (
 #include "HsVersions.h"
 
 import DynFlags
-import CoreSyn ( CoreRule, evaldUnfolding, Unfolding( NoUnfolding ) )
+import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding, Unfolding( NoUnfolding ) )
 
 import IdInfo
 import BasicTypes
@@ -867,6 +867,11 @@ zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo
 zapIdTailCallInfo :: Id -> Id
 zapIdTailCallInfo = zapInfo zapTailCallInfo
 
+zapStableUnfolding :: Id -> Id
+zapStableUnfolding id
+ | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding
+ | otherwise                              = id
+
 {-
 Note [transferPolyIdInfo]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 1c5534f..8bccbfe 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -1519,8 +1519,7 @@ simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se
         ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }
   where
     zapped_bndr  -- See Note [Zap unfolding when beta-reducing]
-      | isId bndr, isStableUnfolding (realIdUnfolding bndr)
-                  = setIdUnfolding bndr NoUnfolding
+      | isId bndr = zapStableUnfolding bndr
       | otherwise = bndr
 
       -- discard a non-counting tick on a lambda.  This may change the
diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs
index 8d41426..f83aafe 100644
--- a/compiler/stranal/WwLib.hs
+++ b/compiler/stranal/WwLib.hs
@@ -587,8 +587,11 @@ mkWWstr_one dflags fam_envs arg
         ; let   unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs
                 unbox_fn  = mkUnpackCase (Var arg) co uniq1
                                          data_con unpk_args
-                rebox_fn  = Let (NonRec arg con_app)
-                con_app   = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
+                arg_no_unf = zapStableUnfolding arg
+                             -- See Note [Zap unfolding when beta-reducing]
+                             -- in Simplify.hs; and see Trac #13890
+                rebox_fn   = Let (NonRec arg_no_unf con_app)
+                con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
          ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs unpk_args
          ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
                            -- Don't pass the arg, rebox instead