Zap stable unfoldings in worker/wrapper
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 28 Jun 2017 13:45:40 +0000 (14:45 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 28 Jun 2017 13:45:40 +0000 (14:45 +0100)
This patch fixes the buglet described in Trac #13890.

compiler/basicTypes/Id.hs
compiler/simplCore/Simplify.hs
compiler/stranal/WwLib.hs

index 8a5e28a..290e262 100644 (file)
@@ -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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
index 1c5534f..8bccbfe 100644 (file)
@@ -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
index 8d41426..f83aafe 100644 (file)
@@ -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