Allow CSE'ing of work-wrapped bindings (#14186)

the worker/wrapper creates an artificial INLINE pragma, which caused CSE
to not do its work. We now recognize such artificial pragmas by using
`NoUserInline` instead of `Inline` as the `InlineSpec`.

Differential Revision: https://phabricator.haskell.org/D3939

11 files changed, 39 insertions, 29 deletions

diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs
index c6ffaad0d4..3e556a165b 100644
--- a/compiler/basicTypes/BasicTypes.hs
+++ b/compiler/basicTypes/BasicTypes.hs
@@ -85,7 +85,7 @@ module BasicTypes(
         isNeverActive, isAlwaysActive, isEarlyActive,
 
         RuleMatchInfo(..), isConLike, isFunLike,
-        InlineSpec(..), isEmptyInlineSpec,
+        InlineSpec(..), noUserInlineSpec,
         InlinePragma(..), defaultInlinePragma, alwaysInlinePragma,
         neverInlinePragma, dfunInlinePragma,
         isDefaultInlinePragma,
@@ -1221,8 +1221,8 @@ data InlineSpec   -- What the user's INLINE pragma looked like
   = Inline
   | Inlinable
   | NoInline
-  | EmptyInlineSpec  -- Used in a place-holder InlinePragma in SpecPrag or IdInfo,
-                     -- where there isn't any real inline pragma at all
+  | NoUserInline -- Used when the pragma did not come from the user,
+                 -- e.g. in `defaultInlinePragma` or when created by CSE
   deriving( Eq, Data, Show )
         -- Show needed for Lexer.x
 
@@ -1232,7 +1232,7 @@ This data type mirrors what you can write in an INLINE or NOINLINE pragma in
 the source program.
 
 If you write nothing at all, you get defaultInlinePragma:
-   inl_inline = EmptyInlineSpec
+   inl_inline = NoUserInline
    inl_act    = AlwaysActive
    inl_rule   = FunLike
 
@@ -1305,16 +1305,16 @@ isFunLike :: RuleMatchInfo -> Bool
 isFunLike FunLike = True
 isFunLike _       = False
 
-isEmptyInlineSpec :: InlineSpec -> Bool
-isEmptyInlineSpec EmptyInlineSpec = True
-isEmptyInlineSpec _               = False
+noUserInlineSpec :: InlineSpec -> Bool
+noUserInlineSpec NoUserInline = True
+noUserInlineSpec _            = False
 
 defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma
   :: InlinePragma
 defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"
                                    , inl_act = AlwaysActive
                                    , inl_rule = FunLike
-                                   , inl_inline = EmptyInlineSpec
+                                   , inl_inline = NoUserInline
                                    , inl_sat = Nothing }
 
 alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }
@@ -1334,7 +1334,7 @@ isDefaultInlinePragma :: InlinePragma -> Bool
 isDefaultInlinePragma (InlinePragma { inl_act = activation
                                     , inl_rule = match_info
                                     , inl_inline = inline })
-  = isEmptyInlineSpec inline && isAlwaysActive activation && isFunLike match_info
+  = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info
 
 isInlinePragma :: InlinePragma -> Bool
 isInlinePragma prag = case inl_inline prag of
@@ -1379,10 +1379,10 @@ instance Outputable RuleMatchInfo where
    ppr FunLike = text "FUNLIKE"
 
 instance Outputable InlineSpec where
-   ppr Inline          = text "INLINE"
-   ppr NoInline        = text "NOINLINE"
-   ppr Inlinable       = text "INLINABLE"
-   ppr EmptyInlineSpec = empty
+   ppr Inline       = text "INLINE"
+   ppr NoInline     = text "NOINLINE"
+   ppr Inlinable    = text "INLINABLE"
+   ppr NoUserInline = text "NOUSERINLINE" -- what is better?
 
 instance Outputable InlinePragma where
   ppr = pprInline
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 2b39eeb7a2..d704f7ba08 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -362,10 +362,10 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
 
   | otherwise
   = case inlinePragmaSpec inline_prag of
-          EmptyInlineSpec -> (gbl_id, rhs)
-          NoInline        -> (gbl_id, rhs)
-          Inlinable       -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
-          Inline          -> inline_pair
+          NoUserInline -> (gbl_id, rhs)
+          NoInline     -> (gbl_id, rhs)
+          Inlinable    -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+          Inline       -> inline_pair
 
   where
     inline_prag   = idInlinePragma gbl_id
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 5e630e56ac..bcdee68edf 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -805,7 +805,7 @@ rep_specialise nm ty ispec loc
        ; ty1 <- repHsSigType ty
        ; phases <- repPhases $ inl_act ispec
        ; let inline = inl_inline ispec
-       ; pragma <- if isEmptyInlineSpec inline
+       ; pragma <- if noUserInlineSpec inline
                    then -- SPECIALISE
                      repPragSpec nm1 ty1 phases
                    else -- SPECIALISE INLINE
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index a9df2b2554..727a04adca 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -660,7 +660,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases)
        ; let (inline', dflt,srcText) = case inline of
                Just inline1 -> (cvtInline inline1, dfltActivation inline1,
                                 src inline1)
-               Nothing      -> (EmptyInlineSpec,   AlwaysActive,
+               Nothing      -> (NoUserInline,   AlwaysActive,
                                 "{-# SPECIALISE")
        ; let ip = InlinePragma { inl_src    = SourceText srcText
                                , inl_inline = inline'
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 85c002b481..089e2440f6 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -1069,8 +1069,8 @@ ppr_sig (SpecSig var ty inl@(InlinePragma { inl_inline = spec }))
                                              (interpp'SP ty) inl)
     where
       pragmaSrc = case spec of
-        EmptyInlineSpec -> "{-# SPECIALISE"
-        _               -> "{-# SPECIALISE_INLINE"
+        NoUserInline -> "{-# SPECIALISE"
+        _            -> "{-# SPECIALISE_INLINE"
 ppr_sig (InlineSig var inl)
   = pragSrcBrackets (inl_src inl) "{-# INLINE"  (pprInline inl
                                    <+> pprPrefixOcc (unLoc var))
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index e3deb31bd5..a4507fc233 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2311,7 +2311,7 @@ sigdecl :: { LHsDecl GhcPs }
         | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
              {% ams (
                  let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
-                                             (EmptyInlineSpec, FunLike) (snd $2)
+                                             (NoUserInline, FunLike) (snd $2)
                   in sLL $1 $> $ SigD (SpecSig $3 (fromOL $5) inl_prag))
                     (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }
 
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index ffbcdb4877..53d7836d68 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -24,7 +24,8 @@ import Type             ( tyConAppArgs )
 import CoreSyn
 import Outputable
 import BasicTypes       ( TopLevelFlag(..), isTopLevel
-                        , isAlwaysActive, isAnyInlinePragma )
+                        , isAlwaysActive, isAnyInlinePragma,
+                          inlinePragmaSpec, noUserInlineSpec )
 import TrieMap
 import Util             ( filterOut )
 import Data.List        ( mapAccumL )
@@ -205,6 +206,10 @@ is small).  The conclusion here is this:
   might replace <rhs> by 'bar', and then later be unable to see that it
   really was <rhs>.
 
+An except to the rule is when the INLINE pragma is not from the user, e.g. from
+WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec
+is then true.
+
 Note that we do not (currently) do CSE on the unfolding stored inside
 an Id, even if is a 'stable' unfolding.  That means that when an
 unfolding happens, it is always faithful to what the stable unfolding
@@ -386,7 +391,8 @@ addBinding env in_id out_id rhs'
                    _      -> False
 
 noCSE :: InId -> Bool
-noCSE id =  not (isAlwaysActive (idInlineActivation id))
+noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&
+            not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))
              -- See Note [CSE for INLINE and NOINLINE]
          || isAnyInlinePragma (idInlinePragma id)
              -- See Note [CSE for stable unfoldings]
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
index dfbb16a9cb..83f1ed78bb 100644
--- a/compiler/specialise/Specialise.hs
+++ b/compiler/specialise/Specialise.hs
@@ -1341,7 +1341,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
                         -- See Note [Specialising imported functions] in OccurAnal
 
                   | InlinePragma { inl_inline = Inlinable } <- inl_prag
-                  = (inl_prag { inl_inline = EmptyInlineSpec }, noUnfolding)
+                  = (inl_prag { inl_inline = NoUserInline }, noUnfolding)
 
                   | otherwise
                   = (inl_prag, specUnfolding poly_tyvars spec_app
diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs
index 9d741f5f4c..630ec11442 100644
--- a/compiler/stranal/WorkWrap.hs
+++ b/compiler/stranal/WorkWrap.hs
@@ -374,6 +374,10 @@ it appears in the first place in the defining module.
 At one stage I tried making the wrapper inlining always-active, and
 that had a very bad effect on nofib/imaginary/x2n1; a wrapper was
 inlined before the specialisation fired.
+
+The use an inl_inline of NoUserInline to distinguish this pragma from one
+that was given by the user. In particular, CSE will not happen if there is a
+user-specified pragma, but should happen for w/w’ed things (#14186).
 -}
 
 tryWW   :: DynFlags
@@ -521,7 +525,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
             wrap_act  = ActiveAfter NoSourceText 0
             wrap_rhs  = wrap_fn work_id
             wrap_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
-                                     , inl_inline = Inline
+                                     , inl_inline = NoUserInline
                                      , inl_sat    = Nothing
                                      , inl_act    = wrap_act
                                      , inl_rule   = rule_match_info }
diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs
index 3ff93b6bfa..f3331ac237 100644
--- a/compiler/typecheck/TcSigs.hs
+++ b/compiler/typecheck/TcSigs.hs
@@ -540,7 +540,7 @@ addInlinePrags poly_id prags_for_me
 
     warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls)
        | inlinePragmaActivation prag1 == inlinePragmaActivation prag2
-       , isEmptyInlineSpec (inlinePragmaSpec prag1)
+       , noUserInlineSpec (inlinePragmaSpec prag1)
        =    -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop
             -- and inl2 is a user NOINLINE pragma; we don't want to complain
          warn_multiple_inlines inl2 inls
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 2859033814..9254e97985 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -1031,14 +1031,14 @@ instance Binary RuleMatchInfo where
                       else return FunLike
 
 instance Binary InlineSpec where
-    put_ bh EmptyInlineSpec = putByte bh 0
+    put_ bh NoUserInline    = putByte bh 0
     put_ bh Inline          = putByte bh 1
     put_ bh Inlinable       = putByte bh 2
     put_ bh NoInline        = putByte bh 3
 
     get bh = do h <- getByte bh
                 case h of
-                  0 -> return EmptyInlineSpec
+                  0 -> return NoUserInline
                   1 -> return Inline
                   2 -> return Inlinable
                   _ -> return NoInline