From addeefc054b64286dfc231d394885bfdecfd261d Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Thu, 28 Jul 2022 14:55:16 +0100
Subject: [PATCH] Refactor UnfoldingSource and IfaceUnfolding
I finally got tired of the way that IfaceUnfolding reflected
a previous structure of unfoldings, not the current one. This
MR refactors UnfoldingSource and IfaceUnfolding to be simpler
and more consistent.
It's largely just a refactor, but in UnfoldingSource (which moves
to GHC.Types.Basic, since it is now used in IfaceSyn too), I
distinguish between /user-specified/ and /system-generated/ stable
unfoldings.
data UnfoldingSource
= VanillaSrc
| StableUserSrc -- From a user-specified pragma
| StableSystemSrc -- From a system-generated unfolding
| CompulsorySrc
This has a minor effect in CSE (see the use of isisStableUserUnfolding
in GHC.Core.Opt.CSE), which I tripped over when working on
specialisation, but it seems like a Good Thing to know anyway.
---
compiler/GHC/Core.hs | 67 +++-------
compiler/GHC/Core/Opt/CSE.hs | 69 +++++-----
compiler/GHC/Core/Opt/Simplify/Iteration.hs | 8 +-
compiler/GHC/Core/Opt/Simplify/Utils.hs | 2 +-
compiler/GHC/Core/Opt/WorkWrap.hs | 10 +-
compiler/GHC/Core/Ppr.hs | 5 -
compiler/GHC/Core/SimpleOpt.hs | 2 +-
compiler/GHC/Core/Tidy.hs | 2 +-
compiler/GHC/Core/Unfold.hs | 24 +---
compiler/GHC/Core/Unfold/Make.hs | 118 +++++++++---------
compiler/GHC/CoreToIface.hs | 17 ++-
compiler/GHC/HsToCore.hs | 2 +-
compiler/GHC/HsToCore/Binds.hs | 15 +--
compiler/GHC/HsToCore/Foreign/C.hs | 5 +-
compiler/GHC/Iface/Rename.hs | 8 +-
compiler/GHC/Iface/Syntax.hs | 94 ++++++--------
compiler/GHC/Iface/Tidy.hs | 12 +-
compiler/GHC/IfaceToCore.hs | 31 ++---
compiler/GHC/Tc/TyCl/Instance.hs | 4 +-
compiler/GHC/Types/Basic.hs | 61 ++++++++-
compiler/GHC/Types/Id/Make.hs | 28 ++---
.../deSugar/should_compile/T19969.stderr | 4 +-
.../tests/deSugar/should_compile/T2431.stderr | 10 +-
.../tests/numeric/should_compile/T7116.stdout | 4 +-
.../should_compile/OpaqueNoRebox.stderr | 11 +-
.../simplCore/should_compile/T13143.stderr | 6 +-
.../simplCore/should_compile/T18013.stderr | 2 +-
.../simplCore/should_compile/T18355.stderr | 19 +--
.../tests/simplCore/should_compile/T21261.hs | 6 +
.../simplCore/should_compile/T21261.stderr | 49 +++-----
.../simplCore/should_compile/T3717.stderr | 2 +-
.../simplCore/should_compile/T3772.stdout | 4 +-
.../simplCore/should_compile/T4201.stdout | 6 +-
.../simplCore/should_compile/T4908.stderr | 2 +-
.../simplCore/should_compile/T4930.stderr | 2 +-
.../simplCore/should_compile/T7360.stderr | 8 +-
.../simplCore/should_compile/T7865.stdout | 2 +-
.../should_compile/spec-inline.stderr | 4 +-
38 files changed, 359 insertions(+), 366 deletions(-)
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 664e8cac437c..c1ed8d741da5 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -65,7 +65,8 @@ module GHC.Core (
maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
- isStableUnfolding, isInlineUnfolding, isBootUnfolding,
+ isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding,
+ isInlineUnfolding, isBootUnfolding,
hasCoreUnfolding, hasSomeUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
@@ -1338,36 +1339,6 @@ data Unfolding
------------------------------------------------
-data UnfoldingSource
- = -- See also Note [Historical note: unfoldings for wrappers]
-
- InlineRhs -- The current rhs of the function
- -- Replace uf_tmpl each time around
-
- | InlineStable -- From an INLINE or INLINABLE pragma
- -- INLINE if guidance is UnfWhen
- -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever
- -- (well, technically an INLINABLE might be made
- -- UnfWhen if it was small enough, and then
- -- it will behave like INLINE outside the current
- -- module, but that is the way automatic unfoldings
- -- work so it is consistent with the intended
- -- meaning of INLINABLE).
- --
- -- uf_tmpl may change, but only as a result of
- -- gentle simplification, it doesn't get updated
- -- to the current RHS during compilation as with
- -- InlineRhs.
- --
- -- See Note [InlineStable]
-
- | InlineCompulsory -- Something that *has* no binding, so you *must* inline it
- -- Only a few primop-like things have this property
- -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding).
- -- Inline absolutely always, however boring the context.
-
-
-
-- | 'UnfoldingGuidance' says when unfolding should take place
data UnfoldingGuidance
= UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl
@@ -1472,12 +1443,6 @@ bootUnfolding = BootUnfolding
mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon
-isStableSource :: UnfoldingSource -> Bool
--- Keep the unfolding template
-isStableSource InlineCompulsory = True
-isStableSource InlineStable = True
-isStableSource InlineRhs = False
-
-- | Retrieves the template of an unfolding: panics if none is known
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate = uf_tmpl
@@ -1542,8 +1507,8 @@ expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) =
expandUnfolding_maybe _ = Nothing
isCompulsoryUnfolding :: Unfolding -> Bool
-isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
-isCompulsoryUnfolding _ = False
+isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src
+isCompulsoryUnfolding _ = False
isStableUnfolding :: Unfolding -> Bool
-- True of unfoldings that should not be overwritten
@@ -1552,6 +1517,16 @@ isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
isStableUnfolding (DFunUnfolding {}) = True
isStableUnfolding _ = False
+isStableUserUnfolding :: Unfolding -> Bool
+-- True of unfoldings that arise from an INLINE or INLINEABLE pragma
+isStableUserUnfolding (CoreUnfolding { uf_src = src }) = isStableUserSource src
+isStableUserUnfolding _ = False
+
+isStableSystemUnfolding :: Unfolding -> Bool
+-- True of unfoldings that arise from an INLINE or INLINEABLE pragma
+isStableSystemUnfolding (CoreUnfolding { uf_src = src }) = isStableSystemSource src
+isStableSystemUnfolding _ = False
+
isInlineUnfolding :: Unfolding -> Bool
-- ^ True of a /stable/ unfolding that is
-- (a) always inlined; that is, with an `UnfWhen` guidance, or
@@ -1608,8 +1583,8 @@ ones are
We consider even a StableUnfolding as fragile, because it needs substitution.
-Note [InlineStable]
-~~~~~~~~~~~~~~~~~
+Note [Stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~
When you say
{-# INLINE f #-}
f x = <rhs>
@@ -1619,10 +1594,11 @@ with it. Meanwhile, we can optimise <rhs> to our heart's content,
leaving the original unfolding intact in Unfolding of 'f'. For example
all xs = foldr (&&) True xs
any p = all . map p {-# INLINE any #-}
-We optimise any's RHS fully, but leave the InlineRule saying "all . map p",
-which deforests well at the call site.
+We optimise any's RHS fully, but leave the stable unfolding for `any`
+saying "all . map p", which deforests well at the call site.
-So INLINE pragma gives rise to an InlineRule, which captures the original RHS.
+So INLINE pragma gives rise to a stable unfolding, which captures the
+original RHS.
Moreover, it's only used when 'f' is applied to the
specified number of arguments; that is, the number of argument on
@@ -1636,9 +1612,6 @@ on the left, thus
it'd only inline when applied to three arguments. This slightly-experimental
change was requested by Roman, but it seems to make sense.
-See also Note [Inlining an InlineRule] in GHC.Core.Unfold.
-
-
Note [OccInfo in unfoldings and rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In unfoldings and rules, we guarantee that the template is occ-analysed,
diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs
index ff1bd3782e41..64f845cc54aa 100644
--- a/compiler/GHC/Core/Opt/CSE.hs
+++ b/compiler/GHC/Core/Opt/CSE.hs
@@ -19,7 +19,7 @@ import GHC.Types.Var.Env ( mkInScopeSet )
import GHC.Types.Id ( Id, idType, idHasRules, zapStableUnfolding
, idInlineActivation, setInlineActivation
, zapIdOccInfo, zapIdUsageInfo, idInlinePragma
- , isJoinId, isJoinId_maybe )
+ , isJoinId, isJoinId_maybe, idUnfolding )
import GHC.Core.Utils ( mkAltExpr
, exprIsTickedString
, stripTicksE, stripTicksT, mkTicks )
@@ -228,7 +228,7 @@ 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
+An exception 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.
@@ -262,27 +262,31 @@ There could conceivably be merit in rewriting the RHS of bar:
but now bar's inlining behaviour will change, and importing
modules might see that. So it seems dodgy and we don't do it.
-Stable unfoldings are also created during worker/wrapper when we decide
-that a function's definition is so small that it should always inline.
-In this case we still want to do CSE (#13340). Hence the use of
-isAnyInlinePragma rather than isStableUnfolding.
-
-Now consider
- foo = <expr>
- bar {-# Unf = Stable ... #-}
- = <expr>
-
-where the unfolding was added by strictness analysis, say. Then
-CSE goes ahead, so we get
- bar = foo
-and probably use SUBSTITUTE that will make 'bar' dead. But just
-possibly not -- see Note [Dealing with ticks]. In that case we might
-be left with
- bar = tick t1 (tick t2 foo)
-in which case we would really like to get rid of the stable unfolding
-(generated by the strictness analyser, say). Hence the zapStableUnfolding
-in cse_bind. Not a big deal, and only makes a difference when ticks
-get into the picture.
+Wrinkles
+
+* Stable unfoldings are also created during worker/wrapper when we
+ decide that a function's definition is so small that it should
+ always inline, or indeed for the wrapper function itself. In this
+ case we still want to do CSE (#13340). Hence the use of
+ isStableUserUnfolding/isStableSystemUnfolding rather than
+ isStableUnfolding.
+
+* Consider
+ foo = <expr>
+ bar {-# Unf = Stable ... #-}
+ = <expr>
+ where the unfolding was added by strictness analysis, say. Then
+ CSE goes ahead, so we get
+ bar = foo
+ and probably use SUBSTITUTE that will make 'bar' dead. But just
+ possibly not -- see Note [Dealing with ticks]. In that case we might
+ be left with
+ bar = tick t1 (tick t2 foo)
+ in which case we would really like to get rid of the stable unfolding
+ (generated by the strictness analyser, say).
+
+ Hence the zapStableUnfolding in cse_bind. Not a big deal, and only
+ makes a difference when ticks get into the picture.
Note [Corner case for case expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -508,14 +512,17 @@ extendCSEnvWithBinding env in_id out_id rhs' cse_done
-- | Given a binder `let x = e`, this function
-- determines whether we should add `e -> x` to the cs_map
noCSE :: InId -> Bool
-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]
- || isJoinId id
- -- See Note [CSE for join points?]
-
+noCSE id
+ | isJoinId id = no_cse -- See Note [CSE for join points?]
+ | isStableUserUnfolding unf = no_cse -- See Note [CSE for stable unfoldings]
+ | user_activation_control = no_cse -- See Note [CSE for INLINE and NOINLINE]
+ | otherwise = yes_cse
+ where
+ unf = idUnfolding id
+ user_activation_control = not (isAlwaysActive (idInlineActivation id))
+ && not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))
+ yes_cse = False
+ no_cse = True
{- Note [Take care with literal strings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index afee252a40de..d2bdace3e233 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -628,7 +628,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
, extendIdSubst (setInScopeFromF env floats) old_bndr $
DoneEx triv_rhs Nothing ) }
- else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl InlineRhs bndr triv_rhs
+ else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc bndr triv_rhs
; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)
`setIdUnfolding` wrap_unf
floats' = floats `extendFloats` NonRec bndr' triv_rhs
@@ -659,7 +659,7 @@ tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)
= case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers
unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
| isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })
- _ -> mkLetUnfolding uf_opts top_lvl InlineRhs work_id work_rhs
+ _ -> mkLetUnfolding uf_opts top_lvl VanillaSrc work_id work_rhs
tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings
= do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr
@@ -841,7 +841,7 @@ makeTrivial env top_lvl dmd occ_fs expr
-- the 'floats' from prepareRHS; but they are all fresh, so there is
-- no danger of introducing name shadowig in eta expansion
- ; unf <- mkLetUnfolding uf_opts top_lvl InlineRhs var expr2
+ ; unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc var expr2
; let final_id = addLetBndrInfo var arity_type unf
bind = NonRec final_id expr2
@@ -4110,7 +4110,7 @@ simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf
| otherwise
= -- Otherwise, we end up retaining all the SimpleEnv
let !opts = seUnfoldingOpts env
- in mkLetUnfolding opts (bindContextLevel bind_cxt) InlineRhs id new_rhs
+ in mkLetUnfolding opts (bindContextLevel bind_cxt) VanillaSrc id new_rhs
-------------------
mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 86ad7df93d45..6a143c8be8bc 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -2077,7 +2077,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
= (poly_id `setIdUnfolding` unf, poly_rhs)
where
poly_rhs = mkLams tvs_here rhs
- unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs
+ unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False poly_rhs
-- We want the unfolding. Consider
-- let
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index fc1d9e278569..711ce6dbd8c9 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -210,7 +210,7 @@ Solution:
It's important that both get this, because the specialiser uses
the existence of a /user-specified/ INLINE/INLINABLE pragma to
- drive specialiation of imported functions. See GHC.Core.Opt.Specialise
+ drive specialisation of imported functions. See GHC.Core.Opt.Specialise
Note [Specialising imported functions]
* Remember, the subsequent inlining behaviour of the wrapper is expressed by
@@ -892,9 +892,13 @@ mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl
, inl_rule = rule_info }) rules
= InlinePragma { inl_src = SourceText "{-# INLINE"
, inl_sat = Nothing
- , inl_inline = fn_inl -- See Note [Worker/wrapper for INLINABLE functions]
+
+ , inl_inline = fn_inl
+ -- See Note [Worker/wrapper for INLINABLE functions]
+
, inl_act = activeAfter wrapper_phase
- -- See Note [Wrapper activation]
+ -- See Note [Wrapper activation]
+
, inl_rule = rule_info } -- RuleMatchInfo is (and must be) unaffected
where
-- See Note [Wrapper activation]
diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs
index d4b2cbeb9356..e24dc20fb982 100644
--- a/compiler/GHC/Core/Ppr.hs
+++ b/compiler/GHC/Core/Ppr.hs
@@ -618,11 +618,6 @@ instance Outputable UnfoldingGuidance where
int size,
int discount ]
-instance Outputable UnfoldingSource where
- ppr InlineCompulsory = text "Compulsory"
- ppr InlineStable = text "InlineStable"
- ppr InlineRhs = text "<vanilla>"
-
instance Outputable Unfolding where
ppr NoUnfolding = text "No unfolding"
ppr BootUnfolding = text "No unfolding (from boot)"
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 75a5ed27a0f7..d8f2b4b5bd80 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -756,7 +756,7 @@ add_info env old_bndr top_level new_rhs new_bndr
| otherwise
= unfolding_from_rhs
- unfolding_from_rhs = mkUnfolding uf_opts InlineRhs
+ unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc
(isTopLevel top_level)
False -- may be bottom or not
new_rhs
diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs
index 3a73ce7dd518..af48f42f23a6 100644
--- a/compiler/GHC/Core/Tidy.hs
+++ b/compiler/GHC/Core/Tidy.hs
@@ -400,7 +400,7 @@ two reasons:
(a) To make printing tidy core nicer
- (b) Because we tidy RULES and InlineRules, which may then propagate
+ (b) Because we tidy RULES and unfoldings, which may then propagate
via --make into the compilation of the next module, and we want
the benefit of that occurrence analysis when we use the rule or
or inline the function. In particular, it's vital not to lose
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 0cf19d81f8e3..49ef7ca02cd0 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -1307,20 +1307,6 @@ Note [Things to watch]
Make sure that x does not inline unconditionally!
Lest we get extra allocation.
-Note [Inlining an InlineRule]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-An InlineRules is used for
- (a) programmer INLINE pragmas
- (b) inlinings from worker/wrapper
-
-For (a) the RHS may be large, and our contract is that we *only* inline
-when the function is applied to all the arguments on the LHS of the
-source-code defn. (The uf_arity in the rule.)
-
-However for worker/wrapper it may be worth inlining even if the
-arity is not satisfied (as we do in the CoreUnfolding case) so we don't
-require saturation.
-
Note [Nested functions]
~~~~~~~~~~~~~~~~~~~~~~~
At one time we treated a call of a non-top-level function as
@@ -1399,8 +1385,8 @@ RULE) so there's no gain.
However, watch out:
* Consider this:
- foo = _inline_ (\n. [n])
- bar = _inline_ (foo 20)
+ foo = \n. [n]) {-# INLINE foo #-}
+ bar = foo 20 {-# INLINE bar #-}
baz = \n. case bar of { (m:_) -> m + n }
Here we really want to inline 'bar' so that we can inline 'foo'
and the whole thing unravels as it should obviously do. This is
@@ -1408,9 +1394,9 @@ However, watch out:
structure rather than a list.
So the non-inlining of lone_variables should only apply if the
- unfolding is regarded as cheap; because that is when exprIsConApp_maybe
- looks through the unfolding. Hence the "&& is_wf" in the
- InlineRule branch.
+ unfolding is regarded as expandable; because that is when
+ exprIsConApp_maybe looks through the unfolding. Hence the "&&
+ is_exp" in the CaseCtxt branch of interesting_call
* Even a type application or coercion isn't a lone variable.
Consider
diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs
index 538af3db3d74..e545f4a9f32f 100644
--- a/compiler/GHC/Core/Unfold/Make.hs
+++ b/compiler/GHC/Core/Unfold/Make.hs
@@ -8,13 +8,12 @@ module GHC.Core.Unfold.Make
, mkFinalUnfolding
, mkSimpleUnfolding
, mkWorkerUnfolding
- , mkInlineUnfolding
- , mkInlineUnfoldingWithArity
+ , mkInlineUnfoldingWithArity, mkInlineUnfoldingNoArity
, mkInlinableUnfolding
, mkWrapperUnfolding
- , mkCompulsoryUnfolding
- , mkCompulsoryUnfolding'
+ , mkCompulsoryUnfolding, mkCompulsoryUnfolding'
, mkDFunUnfolding
+ , mkDataConUnfolding
, specUnfolding
, certainlyWillInline
)
@@ -50,15 +49,14 @@ mkFinalUnfolding opts src strict_sig expr
(isDeadEndSig strict_sig)
expr
+-- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first
+mkCompulsoryUnfolding' :: SimpleOpts -> CoreExpr -> Unfolding
+mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts expr)
+
-- | Used for things that absolutely must be unfolded
-mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
-mkCompulsoryUnfolding opts expr = mkCompulsoryUnfolding' (simpleOptExpr opts expr)
-
--- | Same as 'mkCompulsoryUnfolding' but no simple optimiser pass is performed
--- on the unfolding.
-mkCompulsoryUnfolding' :: CoreExpr -> Unfolding
-mkCompulsoryUnfolding' expr
- = mkCoreUnfolding InlineCompulsory True
+mkCompulsoryUnfolding :: CoreExpr -> Unfolding
+mkCompulsoryUnfolding expr
+ = mkCoreUnfolding CompulsorySrc True
expr
(UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter
, ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
@@ -71,7 +69,7 @@ mkCompulsoryUnfolding' expr
mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding
mkSimpleUnfolding !opts rhs
- = mkUnfolding opts InlineRhs False False rhs
+ = mkUnfolding opts VanillaSrc False False rhs
mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding bndrs con ops
@@ -80,11 +78,21 @@ mkDFunUnfolding bndrs con ops
, df_args = map occurAnalyseExpr ops }
-- See Note [Occurrence analysis of unfoldings]
+mkDataConUnfolding :: CoreExpr -> Unfolding
+-- Used for non-newtype data constructors with non-trivial wrappers
+mkDataConUnfolding expr
+ = mkCoreUnfolding StableSystemSrc True expr guide
+ -- No need to simplify the expression
+ where
+ guide = UnfWhen { ug_arity = manifestArity expr
+ , ug_unsat_ok = unSaturatedOk
+ , ug_boring_ok = False }
+
mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
-- Make the unfolding for the wrapper in a worker/wrapper split
-- after demand/CPR analysis
mkWrapperUnfolding opts expr arity
- = mkCoreUnfolding InlineStable True
+ = mkCoreUnfolding StableSystemSrc True
(simpleOptExpr opts expr)
(UnfWhen { ug_arity = arity
, ug_unsat_ok = unSaturatedOk
@@ -103,13 +111,13 @@ mkWorkerUnfolding opts work_fn
mkWorkerUnfolding _ _ _ = noUnfolding
--- | Make an unfolding that may be used unsaturated
+-- | Make an INLINE unfolding that may be used unsaturated
-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its
-- manifest arity (the number of outer lambdas applications will
-- resolve before doing any work).
-mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
-mkInlineUnfolding opts expr
- = mkCoreUnfolding InlineStable
+mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
+mkInlineUnfoldingNoArity opts src expr
+ = mkCoreUnfolding src
True -- Note [Top-level flag on inline rules]
expr' guide
where
@@ -119,11 +127,11 @@ mkInlineUnfolding opts expr
, ug_boring_ok = boring_ok }
boring_ok = inlineBoringOk expr'
--- | Make an unfolding that will be used once the RHS has been saturated
+-- | Make an INLINE unfolding that will be used once the RHS has been saturated
-- to the given arity.
-mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding
-mkInlineUnfoldingWithArity arity opts expr
- = mkCoreUnfolding InlineStable
+mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding
+mkInlineUnfoldingWithArity opts src arity expr
+ = mkCoreUnfolding src
True -- Note [Top-level flag on inline rules]
expr' guide
where
@@ -136,9 +144,9 @@ mkInlineUnfoldingWithArity arity opts expr
boring_ok | arity == 0 = True
| otherwise = inlineBoringOk expr'
-mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding
-mkInlinableUnfolding opts expr
- = mkUnfolding (so_uf_opts opts) InlineStable False False expr'
+mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
+mkInlinableUnfolding opts src expr
+ = mkUnfolding (so_uf_opts opts) src False False expr'
where
expr' = simpleOptExpr opts expr
@@ -316,29 +324,29 @@ mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
-> UnfoldingGuidance -> Unfolding
-- Occurrence-analyses the expression before capturing it
mkCoreUnfolding src top_lvl expr guidance
- =
-
- let is_value = exprIsHNF expr
- is_conlike = exprIsConLike expr
- is_work_free = exprIsWorkFree expr
- is_expandable = exprIsExpandable expr
- in
- -- See #20905 for what is going on here. We are careful to make sure we only
- -- have one copy of an unfolding around at once.
- -- Note [Thoughtful forcing in mkCoreUnfolding]
- CoreUnfolding { uf_tmpl = is_value `seq`
- is_conlike `seq`
- is_work_free `seq`
- is_expandable `seq`
- occurAnalyseExpr expr,
- -- See Note [Occurrence analysis of unfoldings]
- uf_src = src,
- uf_is_top = top_lvl,
- uf_is_value = is_value,
- uf_is_conlike = is_conlike,
- uf_is_work_free = is_work_free,
- uf_expandable = is_expandable,
- uf_guidance = guidance }
+ = CoreUnfolding { uf_tmpl = is_value `seq`
+ is_conlike `seq`
+ is_work_free `seq`
+ is_expandable `seq`
+ occurAnalyseExpr expr
+ -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]
+ -- See #20905 for what a discussion of these 'seq's
+ -- We are careful to make sure we only
+ -- have one copy of an unfolding around at once.
+ -- Note [Thoughtful forcing in mkCoreUnfolding]
+
+ , uf_src = src
+ , uf_is_top = top_lvl
+ , uf_is_value = is_value
+ , uf_is_conlike = is_conlike
+ , uf_is_work_free = is_work_free
+ , uf_expandable = is_expandable
+ , uf_guidance = guidance }
+ where
+ is_value = exprIsHNF expr
+ is_conlike = exprIsConLike expr
+ is_work_free = exprIsWorkFree expr
+ is_expandable = exprIsExpandable expr
----------------
certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding
@@ -358,14 +366,12 @@ certainlyWillInline opts fn_info rhs'
UnfIfGoodArgs { ug_size = size, ug_args = args }
-> do_cunf size args src' tmpl'
where
- src' = -- Do not change InlineCompulsory!
- case src of
- InlineCompulsory -> InlineCompulsory
- _ -> InlineStable
- tmpl' = -- Do not overwrite stable unfoldings!
- case src of
- InlineRhs -> occurAnalyseExpr rhs'
- _ -> uf_tmpl fn_unf
+ src' | isCompulsorySource src = src -- Do not change InlineCompulsory!
+ | otherwise = StableSystemSrc
+
+ tmpl' | isStableSource src = uf_tmpl fn_unf
+ | otherwise = occurAnalyseExpr rhs'
+ -- Do not overwrite stable unfoldings!
DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense
-- to do so, and even if it is currently a
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index 2564320eaafa..0060d82f26c3 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -501,20 +501,11 @@ toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
, uf_src = src
, uf_guidance = guidance })
= Just $ HsUnfold lb $
- case src of
- InlineStable
- -> case guidance of
- UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
- -> IfInlineRule arity unsat_ok boring_ok if_rhs
- _other -> IfCoreUnfold True if_rhs
- InlineCompulsory -> IfCompulsory if_rhs
- InlineRhs -> IfCoreUnfold False if_rhs
+ IfCoreUnfold src (toIfGuidance src guidance) (toIfaceExpr rhs)
-- Yes, even if guidance is UnfNever, expose the unfolding
-- If we didn't want to expose the unfolding, GHC.Iface.Tidy would
-- have stuck in NoUnfolding. For supercompilation we want
-- to see that unfolding!
- where
- if_rhs = toIfaceExpr rhs
toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })
= Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))
@@ -531,6 +522,12 @@ toIfUnfolding _ BootUnfolding = Nothing
toIfUnfolding _ NoUnfolding = Nothing
+toIfGuidance :: UnfoldingSource -> UnfoldingGuidance -> IfGuidance
+toIfGuidance src guidance
+ | UnfWhen arity unsat_ok boring_ok <- guidance
+ , isStableSource src = IfWhen arity unsat_ok boring_ok
+ | otherwise = IfNoGuidance
+
{-
************************************************************************
* *
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
index 983f3086b549..6da39a27bc03 100644
--- a/compiler/GHC/HsToCore.hs
+++ b/compiler/GHC/HsToCore.hs
@@ -787,7 +787,7 @@ mkUnsafeCoercePrimPair _old_id old_expr
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding' rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
`setArityInfo` arity
ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
index 053c9959a2bc..b5e31de53260 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ b/compiler/GHC/HsToCore/Binds.hs
@@ -390,7 +390,7 @@ makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
makeCorePair dflags gbl_id is_default_method dict_arity rhs
| is_default_method -- Default methods are *always* inlined
-- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance
- = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding simpl_opts rhs, rhs)
+ = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs)
| otherwise
= case inlinePragmaSpec inline_prag of
@@ -402,19 +402,20 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs
where
simpl_opts = initSimpleOpts dflags
inline_prag = idInlinePragma gbl_id
- inlinable_unf = mkInlinableUnfolding simpl_opts rhs
+ inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs
inline_pair
| Just arity <- inlinePragmaSat inline_prag
-- Add an Unfolding for an INLINE (but not for NOINLINE)
-- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
, let real_arity = dict_arity + arity
- -- NB: The arity in the InlineRule takes account of the dictionaries
- = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity simpl_opts rhs
+ -- NB: The arity passed to mkInlineUnfoldingWithArity
+ -- must take account of the dictionaries
+ = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs
, etaExpand real_arity rhs)
| otherwise
= pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
- (gbl_id `setIdUnfolding` mkInlineUnfolding simpl_opts rhs, rhs)
+ (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs)
dictArity :: [Var] -> Arity
-- Don't count coercion variables in arity
@@ -542,7 +543,7 @@ this:
fromT :: T Bool -> Bool
{ fromT_1 ((TBool b)) = not b } } }
-Note the nested AbsBind. The arity for the InlineRule on $cfromT should be
+Note the nested AbsBind. The arity for the unfolding on $cfromT should be
gotten from the binding for fromT_1.
It might be better to have just one level of AbsBinds, but that requires more
@@ -976,7 +977,7 @@ And from that we want the rule
But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External
Name, and you can't bind them in a lambda or forall without getting things
-confused. Likewise it might have an InlineRule or something, which would be
+confused. Likewise it might have a stable unfolding or something, which would be
utterly bogus. So we really make a fresh Id, with the same unique and type
as the old one, but with an Internal name and no IdInfo.
diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs
index a35e3feca655..13ba3123f4c4 100644
--- a/compiler/GHC/HsToCore/Foreign/C.hs
+++ b/compiler/GHC/HsToCore/Foreign/C.hs
@@ -324,9 +324,8 @@ dsFCall fn_id co fcall mDeclHeader = do
wrap_rhs = mkLams (tvs ++ args) wrapper_body
wrap_rhs' = Cast wrap_rhs co
simpl_opts = initSimpleOpts dflags
- fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
- (length args)
- simpl_opts
+ fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts
+ StableSystemSrc (length args)
wrap_rhs'
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])
diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
index fdbe0dd55a84..1a7acea25fbb 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ b/compiler/GHC/Iface/Rename.hs
@@ -600,12 +600,8 @@ rnIfaceInfoItem i
= pure i
rnIfaceUnfolding :: Rename IfaceUnfolding
-rnIfaceUnfolding (IfCoreUnfold stable if_expr)
- = IfCoreUnfold stable <$> rnIfaceExpr if_expr
-rnIfaceUnfolding (IfCompulsory if_expr)
- = IfCompulsory <$> rnIfaceExpr if_expr
-rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)
- = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfCoreUnfold src guide if_expr)
+ = IfCoreUnfold src guide <$> rnIfaceExpr if_expr
rnIfaceUnfolding (IfDFunUnfold bs ops)
= IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 1affa46b42c7..7e7a1aa0c80d 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -13,7 +13,7 @@ module GHC.Iface.Syntax (
IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,
IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..),
IfaceBinding(..), IfaceConAlt(..),
- IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..),
+ IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceClassBody(..),
@@ -360,21 +360,12 @@ data IfaceInfoItem
-- only later attached to the Id. Partial reason: some are orphans.
data IfaceUnfolding
- = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
- -- Possibly could eliminate the Bool here, the information
- -- is also in the InlinePragma.
-
- | IfCompulsory IfaceExpr -- default methods and unsafeCoerce#
- -- for more about unsafeCoerce#, see
- -- Note [Wiring in unsafeCoerce#] in "GHC.HsToCore"
-
- | IfInlineRule Arity -- INLINE pragmas
- Bool -- OK to inline even if *un*-saturated
- Bool -- OK to inline even if context is boring
- IfaceExpr
-
+ = IfCoreUnfold UnfoldingSource IfGuidance IfaceExpr
| IfDFunUnfold [IfaceBndr] [IfaceExpr]
+data IfGuidance
+ = IfNoGuidance -- Compute it from the IfaceExpr
+ | IfWhen Arity Bool Bool -- Just like UnfWhen in Core.UnfoldingGuidance
-- We only serialise the IdDetails of top-level Ids, and even then
-- we only need a very limited selection. Notably, none of the
@@ -1488,17 +1479,15 @@ instance Outputable IfaceJoinInfo where
ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)
instance Outputable IfaceUnfolding where
- ppr (IfCompulsory e) = text "<compulsory>" <+> parens (ppr e)
- ppr (IfCoreUnfold s e) = (if s
- then text "<stable>"
- else Outputable.empty)
- <+> parens (ppr e)
- ppr (IfInlineRule a uok bok e) = sep [text "InlineRule"
- <+> ppr (a,uok,bok),
- pprParendIfaceExpr e]
+ ppr (IfCoreUnfold src guide e)
+ = sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ]
ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot)
2 (sep (map pprParendIfaceExpr es))
+instance Outputable IfGuidance where
+ ppr IfNoGuidance = empty
+ ppr (IfWhen a u b) = angleBrackets (ppr a <> comma <> ppr u <> ppr b)
+
{-
************************************************************************
* *
@@ -1742,9 +1731,7 @@ freeNamesItem (HsLFInfo (IfLFCon n)) = unitNameSet n
freeNamesItem _ = emptyNameSet
freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfCoreUnfold _ _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es
freeNamesIfExpr :: IfaceExpr -> NameSet
@@ -2264,39 +2251,41 @@ instance Binary IfaceInfoItem where
_ -> HsTagSig <$> get bh
instance Binary IfaceUnfolding where
- put_ bh (IfCoreUnfold s e) = do
+ put_ bh (IfCoreUnfold s g e) = do
putByte bh 0
put_ bh s
+ put_ bh g
put_ bh e
- put_ bh (IfInlineRule a b c d) = do
- putByte bh 1
- put_ bh a
- put_ bh b
- put_ bh c
- put_ bh d
put_ bh (IfDFunUnfold as bs) = do
- putByte bh 2
+ putByte bh 1
put_ bh as
put_ bh bs
- put_ bh (IfCompulsory e) = do
- putByte bh 3
- put_ bh e
get bh = do
h <- getByte bh
case h of
0 -> do s <- get bh
+ g <- get bh
e <- get bh
- return (IfCoreUnfold s e)
- 1 -> do a <- get bh
- b <- get bh
- c <- get bh
- d <- get bh
- return (IfInlineRule a b c d)
- 2 -> do as <- get bh
+ return (IfCoreUnfold s g e)
+ _ -> do as <- get bh
bs <- get bh
return (IfDFunUnfold as bs)
- _ -> do e <- get bh
- return (IfCompulsory e)
+
+instance Binary IfGuidance where
+ put_ bh IfNoGuidance = putByte bh 0
+ put_ bh (IfWhen a b c ) = do
+ putByte bh 1
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfNoGuidance
+ _ -> do a <- get bh
+ b <- get bh
+ c <- get bh
+ return (IfWhen a b c)
instance Binary IfaceAlt where
put_ bh (IfaceAlt a b c) = do
@@ -2610,16 +2599,15 @@ instance NFData IfaceInfoItem where
HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?
HsTagSig sig -> sig `seq` ()
+instance NFData IfGuidance where
+ rnf = \case
+ IfNoGuidance -> ()
+ IfWhen a b c -> a `seq` b `seq` c `seq` ()
+
instance NFData IfaceUnfolding where
rnf = \case
- IfCoreUnfold inlinable expr ->
- rnf inlinable `seq` rnf expr
- IfCompulsory expr ->
- rnf expr
- IfInlineRule arity b1 b2 e ->
- rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e
- IfDFunUnfold bndrs exprs ->
- rnf bndrs `seq` rnf exprs
+ IfCoreUnfold src guidance expr -> src `seq` rnf guidance `seq` rnf expr
+ IfDFunUnfold bndrs exprs -> rnf bndrs `seq` rnf exprs
instance NFData IfaceExpr where
rnf = \case
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 515402abc5a6..68733b36712a 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -875,9 +875,9 @@ dffvBind(x,r)
dffvLetBndr :: Bool -> Id -> DFFV ()
-- Gather the free vars of the RULES and unfolding of a binder
-- We always get the free vars of a *stable* unfolding, but
--- for a *vanilla* one (InlineRhs), the flag controls what happens:
+-- for a *vanilla* one (VanillaSrc), the flag controls what happens:
-- True <=> get fvs of even a *vanilla* unfolding
--- False <=> ignore an InlineRhs
+-- False <=> ignore a VanillaSrc
-- For nested bindings (call from dffvBind) we always say "False" because
-- we are taking the fvs of the RHS anyway
-- For top-level bindings (call from addExternal, via bndrFvsInOrder)
@@ -889,10 +889,9 @@ dffvLetBndr vanilla_unfold id
idinfo = idInfo id
go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
- = case src of
- InlineRhs | vanilla_unfold -> dffvExpr rhs
- | otherwise -> return ()
- _ -> dffvExpr rhs
+ | isStableSource src = dffvExpr rhs
+ | vanilla_unfold = dffvExpr rhs
+ | otherwise = return ()
go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })
= extendScopeList bndrs $ mapM_ dffvExpr args
@@ -1292,7 +1291,6 @@ tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
= tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info
| otherwise
= minimal_unfold_info
--- unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig orig_rhs
-- NB: use `orig_rhs` not `tidy_rhs` in this call to mkFinalUnfolding
-- else you get a black hole (#22122). Reason: mkFinalUnfolding
-- looks at IdInfo, and that is knot-tied in tidyTopBind (the Rec case)
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index a7c3162930ab..4ef629593c84 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -57,6 +57,7 @@ import GHC.Core.FamInstEnv
import GHC.Core
import GHC.Core.Unify( RoughMatchTc(..) )
import GHC.Core.Utils
+import GHC.Core.Unfold( calcUnfoldingGuidance )
import GHC.Core.Unfold.Make
import GHC.Core.Lint
import GHC.Core.Make
@@ -97,6 +98,7 @@ import GHC.Types.Unique.FM
import GHC.Types.Unique.DSet ( mkUniqDSet )
import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import GHC.Types.Unique.Supply
+import GHC.Types.Demand( isDeadEndSig )
import GHC.Types.Literal
import GHC.Types.Var as Var
import GHC.Types.Var.Set
@@ -1655,8 +1657,8 @@ tcIdInfo ignore_prags toplvl name ty info = do
need_prag :: IfaceInfoItem -> Bool
-- Always read in compulsory unfoldings
-- See Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy
- need_prag (HsUnfold _ (IfCompulsory {})) = True
- need_prag _ = False
+ need_prag (HsUnfold _ (IfCoreUnfold src _ _)) = isCompulsorySource src
+ need_prag _ = False
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
@@ -1716,25 +1718,16 @@ tcLFInfo lfi = case lfi of
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
-- See Note [Lazily checking Unfoldings]
-tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
+tcUnfolding toplvl name _ info (IfCoreUnfold src if_guidance if_expr)
= do { uf_opts <- unfoldingOpts <$> getDynFlags
- ; expr <- tcUnfoldingRhs False toplvl name if_expr
- ; let unf_src | stable = InlineStable
- | otherwise = InlineRhs
- ; return $ mkFinalUnfolding uf_opts unf_src strict_sig expr }
+ ; expr <- tcUnfoldingRhs (isCompulsorySource src) toplvl name if_expr
+ ; let guidance = case if_guidance of
+ IfWhen arity unsat_ok boring_ok -> UnfWhen arity unsat_ok boring_ok
+ IfNoGuidance -> calcUnfoldingGuidance uf_opts is_top_bottoming expr
+ ; return $ mkCoreUnfolding src True expr guidance }
where
-- Strictness should occur before unfolding!
- strict_sig = dmdSigInfo info
-
-tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
- = do { expr <- tcUnfoldingRhs True toplvl name if_expr
- ; return $ mkCompulsoryUnfolding' expr }
-
-tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
- = do { expr <- tcUnfoldingRhs False toplvl name if_expr
- ; return $ mkCoreUnfolding InlineStable True expr guidance }
- where
- guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
+ is_top_bottoming = isTopLevel toplvl && isDeadEndSig (dmdSigInfo info)
tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
= bindIfaceBndrs bs $ \ bs' ->
@@ -1765,7 +1758,7 @@ in the middle of checking (so looking at it would cause a loop).
Conclusion: `tcUnfolding` must return an `Unfolding` whose `uf_src` field is readable without
forcing the `uf_tmpl` field. In particular, all the functions used at the end of
-`tcUnfolding` (such as `mkFinalUnfolding`, `mkCompulsoryUnfolding'`, `mkCoreUnfolding`) must be
+`tcUnfolding` (such as `mkFinalUnfolding`, `mkCoreUnfolding`) must be
lazy in `expr`.
Ticket #21139
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index e1b7fc0f0fb7..8b3c34aa83c6 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -175,7 +175,7 @@ Note [Instances and loop breakers]
inline df_i in it, and that in turn means that (since it'll be a
loop-breaker because df_i isn't), op1_i will ironically never be
inlined. But this is OK: the recursion breaking happens by way of
- a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
+ a RULE (the magic ClassOp rule above), and RULES work inside stable
unfoldings. See Note [RULEs enabled in InitialPhase] in GHC.Core.Opt.Simplify.Utils
Note [ClassOp/DFun selection]
@@ -1349,7 +1349,7 @@ addDFunPrags :: DFunId -> [Id] -> DFunId
-- is messing with.
addDFunPrags dfun_id sc_meth_ids
| is_newtype
- = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 defaultSimpleOpts con_app
+ = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity defaultSimpleOpts StableSystemSrc 0 con_app
`setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
| otherwise
= dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs
index 027fe63bad77..bb8dcde29f7c 100644
--- a/compiler/GHC/Types/Basic.hs
+++ b/compiler/GHC/Types/Basic.hs
@@ -98,6 +98,9 @@ module GHC.Types.Basic (
setInlinePragmaActivation, setInlinePragmaRuleMatchInfo,
pprInline, pprInlineDebug,
+ UnfoldingSource(..), isStableSource, isStableUserSource,
+ isStableSystemSource, isCompulsorySource,
+
SuccessFlag(..), succeeded, failed, successIf,
IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit,
@@ -1433,7 +1436,7 @@ If you write nothing at all, you get defaultInlinePragma:
It's not possible to get that combination by *writing* something, so
if an Id has defaultInlinePragma it means the user didn't specify anything.
-If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding.
+If inl_inline = Inline or Inlineable, then the Id should have a stable unfolding.
If you want to know where InlinePragmas take effect: Look in GHC.HsToCore.Binds.makeCorePair
@@ -1778,6 +1781,62 @@ pprInline' emptyInline (InlinePragma
| otherwise = ppr info
+{- *********************************************************************
+* *
+ UnfoldingSource
+* *
+********************************************************************* -}
+
+data UnfoldingSource
+ = -- See also Note [Historical note: unfoldings for wrappers]
+ VanillaSrc -- The current rhs of the function
+ -- Replace uf_tmpl each time around
+
+ -- See Note [Stable unfoldings] in GHC.Core
+ | StableUserSrc -- From a user-specified INLINE or INLINABLE pragma
+ | StableSystemSrc -- From a wrapper, or system-generated unfolding
+
+ | CompulsorySrc -- Something that *has* no binding, so you *must* inline it
+ -- Only a few primop-like things have this property
+ -- (see "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding).
+ -- Inline absolutely always, however boring the context.
+
+isStableUserSource :: UnfoldingSource -> Bool
+isStableUserSource StableUserSrc = True
+isStableUserSource _ = False
+
+isStableSystemSource :: UnfoldingSource -> Bool
+isStableSystemSource StableSystemSrc = True
+isStableSystemSource _ = False
+
+isCompulsorySource :: UnfoldingSource -> Bool
+isCompulsorySource CompulsorySrc = True
+isCompulsorySource _ = False
+
+isStableSource :: UnfoldingSource -> Bool
+isStableSource CompulsorySrc = True
+isStableSource StableSystemSrc = True
+isStableSource StableUserSrc = True
+isStableSource VanillaSrc = False
+
+instance Binary UnfoldingSource where
+ put_ bh CompulsorySrc = putByte bh 0
+ put_ bh StableUserSrc = putByte bh 1
+ put_ bh StableSystemSrc = putByte bh 2
+ put_ bh VanillaSrc = putByte bh 3
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return CompulsorySrc
+ 1 -> return StableUserSrc
+ 2 -> return StableSystemSrc
+ _ -> return VanillaSrc
+
+instance Outputable UnfoldingSource where
+ ppr CompulsorySrc = text "Compulsory"
+ ppr StableUserSrc = text "StableUser"
+ ppr StableSystemSrc = text "StableSystem"
+ ppr VanillaSrc = text "<vanilla>"
{-
************************************************************************
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 59452d2912a0..7b0e15df9107 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -483,8 +483,8 @@ mkDictSelId name clas
info | new_tycon
= base_info `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkInlineUnfoldingWithArity 1
- defaultSimpleOpts
+ `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts
+ StableSystemSrc 1
(mkDictSelRhs clas val_index)
-- See Note [Single-method classes] in GHC.Tc.TyCl.Instance
-- for why alwaysInlinePragma
@@ -492,8 +492,8 @@ mkDictSelId name clas
| otherwise
= base_info `setRuleInfo` mkRuleInfo [rule]
`setInlinePragInfo` neverInlinePragma
- `setUnfoldingInfo` mkInlineUnfoldingWithArity 1
- defaultSimpleOpts
+ `setUnfoldingInfo` mkInlineUnfoldingWithArity defaultSimpleOpts
+ StableSystemSrc 1
(mkDictSelRhs clas val_index)
-- Add a magic BuiltinRule, but no unfolding
-- so that the rule is always available to fire.
@@ -600,7 +600,7 @@ mkDataConWorkId wkr_name data_con
newtype_unf = assertPpr (isVanillaDataCon data_con && isSingleton arg_tys)
(ppr data_con) $
-- Note [Newtype datacons]
- mkCompulsoryUnfolding defaultSimpleOpts $
+ mkCompulsoryUnfolding $
mkLams univ_tvs $ Lam id_arg1 $
wrapNewTypeBody tycon res_ty_args (Var id_arg1)
@@ -719,9 +719,9 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con
-- See Note [Inline partially-applied constructor wrappers]
-- Passing Nothing here allows the wrapper to inline when
-- unsaturated.
- wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding defaultSimpleOpts wrap_rhs
+ wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs
-- See Note [Compulsory newtype unfolding]
- | otherwise = mkInlineUnfolding defaultSimpleOpts wrap_rhs
+ | otherwise = mkDataConUnfolding wrap_rhs
wrap_rhs = mkLams wrap_tvs $
mkLams wrap_args $
wrapFamInstBody tycon res_ty_args $
@@ -1431,14 +1431,14 @@ nullAddrId :: Id
nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts (Lit nullAddrLit)
+ `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit)
------------------------------------------------
seqId :: Id -- See Note [seqId magic]
seqId = pcMiscPrelId seqName ty info
where
info = noCafIdInfo `setInlinePragInfo` inline_prag
- `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
`setArityInfo` arity
inline_prag
@@ -1484,7 +1484,7 @@ oneShotId :: Id -- See Note [The oneShot function]
oneShotId = pcMiscPrelId oneShotName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
`setArityInfo` arity
ty = mkInfForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar ] $
mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ] $
@@ -1525,7 +1525,7 @@ leftSectionId :: Id
leftSectionId = pcMiscPrelId leftSectionName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
`setArityInfo` arity
ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $
mkSpecForAllTys [openAlphaTyVar, openBetaTyVar] $
@@ -1550,7 +1550,7 @@ rightSectionId :: Id
rightSectionId = pcMiscPrelId rightSectionName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
`setArityInfo` arity
ty = mkInfForAllTys [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar
, multiplicityTyVar1, multiplicityTyVar2 ] $
@@ -1576,7 +1576,7 @@ coerceId :: Id
coerceId = pcMiscPrelId coerceName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
- `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
`setArityInfo` 2
eqRTy = mkTyConApp coercibleTyCon [ tYPE_r, a, b ]
eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE_r, tYPE_r, a, b ]
@@ -1813,7 +1813,7 @@ voidPrimId :: Id -- Global constant :: Void#
-- We cannot define it in normal Haskell, since it's
-- a top-level unlifted value.
voidPrimId = pcMiscPrelId voidPrimIdName unboxedUnitTy
- (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts unboxedUnitExpr)
+ (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding unboxedUnitExpr)
unboxedUnitExpr :: CoreExpr
unboxedUnitExpr = Var (dataConWorkId unboxedUnitDataCon)
diff --git a/testsuite/tests/deSugar/should_compile/T19969.stderr b/testsuite/tests/deSugar/should_compile/T19969.stderr
index 3ded6f27a498..555a333349a6 100644
--- a/testsuite/tests/deSugar/should_compile/T19969.stderr
+++ b/testsuite/tests/deSugar/should_compile/T19969.stderr
@@ -16,7 +16,7 @@ g [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
Arity=1,
Str=<B>b,
Cpr=b,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True)
Tmpl= f}]
@@ -28,7 +28,7 @@ h [InlPrag=INLINE (sat-args=1)] :: [Int] -> [Int]
Arity=1,
Str=<B>b,
Cpr=b,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True)
Tmpl= f}]
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 9a1f79839d0e..3ff19d51ea60 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -7,7 +7,7 @@ Result size of Tidy Core
T2431.$WRefl [InlPrag=INLINE[final] CONLIKE] :: forall a. a :~: a
[GblId[DataConWrapper],
Caf=NoCafRefs,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False)
Tmpl= \ (@a) -> T2431.Refl @a @a @~(<a>_N :: a GHC.Prim.~# a)}]
@@ -64,8 +64,8 @@ T2431.$tc:~: :: GHC.Types.TyCon
[GblId, Unf=OtherCon []]
T2431.$tc:~:
= GHC.Types.TyCon
- 4608886815921030019##
- 6030312177285011233##
+ 4608886815921030019##64
+ 6030312177285011233##64
T2431.$trModule
$tc:~:2
0#
@@ -103,8 +103,8 @@ T2431.$tc'Refl :: GHC.Types.TyCon
[GblId, Unf=OtherCon []]
T2431.$tc'Refl
= GHC.Types.TyCon
- 2478588351447975921##
- 2684375695874497811##
+ 2478588351447975921##64
+ 2684375695874497811##64
T2431.$trModule
$tc'Refl2
1#
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index 90aeda659de3..407a057855c7 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -45,7 +45,7 @@ dr :: Double -> Double
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once1!] :: Double) ->
@@ -73,7 +73,7 @@ fr :: Float -> Float
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once1!] :: Float) ->
diff --git a/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.stderr b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.stderr
index ad82c9e16c02..2be1c412dfdb 100644
--- a/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.stderr
+++ b/testsuite/tests/simplCore/should_compile/OpaqueNoRebox.stderr
@@ -45,7 +45,7 @@ OpaqueNoRebox.$trModule
-- RHS size: {terms: 7, types: 8, coercions: 0, joins: 0/0}
f [InlPrag=OPAQUE] :: (Int, Int) -> Int
[GblId, Arity=1, Str=<1P(1L,1L)>, Unf=OtherCon []]
-f = / (ds :: (Int, Int)) ->
+f = \ (ds :: (Int, Int)) ->
case ds of { (x, y) -> GHC.Num.$fNumInt_$c+ x y }
-- RHS size: {terms: 19, types: 14, coercions: 0, joins: 0/0}
@@ -54,10 +54,10 @@ g [InlPrag=[2]] :: (Int, Int) -> Int
Arity=1,
Str=<1P(SL,SL)>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
- Tmpl= / (p [Occ=Once1!] :: (Int, Int)) ->
+ Tmpl= \ (p [Occ=Once1!] :: (Int, Int)) ->
case p of wild { (x [Occ=Once1!], _ [Occ=Dead]) ->
case x of { GHC.Types.I# x1 [Occ=Once1] ->
case f (f wild, f wild) of { GHC.Types.I# y [Occ=Once1] ->
@@ -65,7 +65,7 @@ g [InlPrag=[2]] :: (Int, Int) -> Int
}
}
}}]
-g = / (p :: (Int, Int)) ->
+g = \ (p :: (Int, Int)) ->
case p of wild { (x, ds1) ->
case x of { GHC.Types.I# x1 ->
case f (f wild, f wild) of { GHC.Types.I# y ->
@@ -73,3 +73,6 @@ g = / (p :: (Int, Int)) ->
}
}
}
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr
index 16189c6daaac..1d4b3dd9fa52 100644
--- a/testsuite/tests/simplCore/should_compile/T13143.stderr
+++ b/testsuite/tests/simplCore/should_compile/T13143.stderr
@@ -12,12 +12,12 @@ T13143.$wf = \ _ [Occ=Dead] (@a) -> T13143.$wf GHC.Prim.(##) @a
end Rec }
-- RHS size: {terms: 4, types: 3, coercions: 0, joins: 0/0}
-f [InlPrag=[final]] :: forall a. Int -> a
+f [InlPrag=NOINLINE[final]] :: forall a. Int -> a
[GblId,
Arity=1,
Str=<B>b,
Cpr=b,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)
Tmpl= \ (@a) _ [Occ=Dead] -> T13143.$wf GHC.Prim.(##) @a}]
@@ -94,7 +94,7 @@ g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int
Arity=3,
Str=<1L><1L><1!P(L)>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False)
Tmpl= \ (ds [Occ=Once1] :: Bool)
diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr
index b94cec212b4e..719f70df19d7 100644
--- a/testsuite/tests/simplCore/should_compile/T18013.stderr
+++ b/testsuite/tests/simplCore/should_compile/T18013.stderr
@@ -139,7 +139,7 @@ mapMaybeRule [InlPrag=[2]]
[GblId,
Arity=1,
Str=<1!P(L,LCS(C1(C1(P(L,1L)))))>,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (@a) (@b) (f [Occ=Once1!] :: Rule IO a b) ->
diff --git a/testsuite/tests/simplCore/should_compile/T18355.stderr b/testsuite/tests/simplCore/should_compile/T18355.stderr
index 6b7372c5afd7..a21a492b6d85 100644
--- a/testsuite/tests/simplCore/should_compile/T18355.stderr
+++ b/testsuite/tests/simplCore/should_compile/T18355.stderr
@@ -1,25 +1,16 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 32, types: 23, coercions: 0, joins: 0/0}
+ = {terms: 32, types: 21, coercions: 0, joins: 0/0}
--- RHS size: {terms: 17, types: 10, coercions: 0, joins: 0/0}
+-- RHS size: {terms: 17, types: 9, coercions: 0, joins: 0/0}
f :: forall {a}. Num a => a -> Bool -> a -> a
[GblId,
Arity=4,
- Str=<S,1*U(1*C1(C1(U)),1*C1(C1(U)),A,A,A,A,A)><L,U><S,1*U><L,U>,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Str=<1P(MC1(C1(L)),MC1(C1(L)),A,A,A,A,A)><L><1L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
- Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False)
- Tmpl= \ (@a)
- ($dNum [Occ=Once2] :: Num a)
- (x [Occ=Once2] :: a)
- (b [Occ=Once1!] :: Bool)
- (eta [Occ=Once2, OS=OneShot] :: a) ->
- case b of {
- False -> - @a $dNum x eta;
- True -> + @a $dNum x eta
- }}]
+ Guidance=IF_ARGS [60 0 70 0] 100 0}]
f = \ (@a)
($dNum :: Num a)
(x :: a)
diff --git a/testsuite/tests/simplCore/should_compile/T21261.hs b/testsuite/tests/simplCore/should_compile/T21261.hs
index 167d3f0f865b..888c2fed1321 100644
--- a/testsuite/tests/simplCore/should_compile/T21261.hs
+++ b/testsuite/tests/simplCore/should_compile/T21261.hs
@@ -1,3 +1,9 @@
+{-# OPTIONS_GHC -fno-worker-wrapper #-}
+
+-- The -fno-worker-wrapper stops f1, f2 etc from worker/wrappering
+-- via CPR analysis, after which they inline ane confuse the
+-- detection of eta-expansion or otherwise
+
module T21261 where
-- README: The convention here is that bindings starting with 'yes' should be
diff --git a/testsuite/tests/simplCore/should_compile/T21261.stderr b/testsuite/tests/simplCore/should_compile/T21261.stderr
index fadd73c2190e..6ed7bb993302 100644
--- a/testsuite/tests/simplCore/should_compile/T21261.stderr
+++ b/testsuite/tests/simplCore/should_compile/T21261.stderr
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 139, types: 130, coercions: 0, joins: 0/0}
+ = {terms: 127, types: 120, coercions: 0, joins: 0/0}
lvl = I# 3#
@@ -13,58 +13,49 @@ f2 = \ c -> case c lvl2 of { __DEFAULT -> c lvl lvl1 }
yes1or2 = f2
-lvl3 = I# 2#
+lvl3 = I# 42#
-$wf4
+lvl4 = I# 2#
+
+f4
= \ c ->
- case c lvl2 lvl3 of { __DEFAULT ->
- case c lvl lvl1 of { __DEFAULT -> 42# }
+ case c lvl2 lvl4 of { __DEFAULT ->
+ case c lvl lvl1 of { __DEFAULT -> lvl3 }
}
-f4 = \ c -> case $wf4 c of ww { __DEFAULT -> I# ww }
-
-no3
- = \ c ->
- case $wf4 (\ x y z -> c x y z) of ww { __DEFAULT -> I# ww }
+no3 = \ c -> f4 (\ x y z -> c x y z)
-f6 = \ c -> case c lvl2 of { __DEFAULT -> c lvl3 lvl }
+f6 = \ c -> case c lvl2 of { __DEFAULT -> c lvl4 lvl }
no_tricky = \ c -> f6 (\ x y -> c x y)
-$wf7 = \ c -> (# case c lvl2 of { __DEFAULT -> c lvl lvl1 } #)
-
-f7 = \ c -> case $wf7 c of { (# ww #) -> Just ww }
+f7 = \ c -> Just (case c lvl2 of { __DEFAULT -> c lvl lvl1 })
no_tricky_lazy = \ c -> f7 (\ x y -> c x y)
-$wf5
+f5
= \ c ->
- (# case c lvl2 lvl3 of { I# x ->
+ Just
+ (case c lvl2 lvl4 of { I# x ->
case c lvl lvl1 of { I# y -> I# (+# x y) }
- } #)
-
-f5 = \ c -> case $wf5 c of { (# ww #) -> Just ww }
+ })
yes2_lazy = f5
-$wf3
+f3
= \ c ->
- case c lvl2 lvl3 of { I# x ->
- case c lvl lvl1 of { I# y -> +# x y }
+ case c lvl2 lvl4 of { I# x ->
+ case c lvl lvl1 of { I# y -> I# (+# x y) }
}
-f3 = \ c -> case $wf3 c of ww { __DEFAULT -> I# ww }
-
yes2 = f3
-$wf1
+f1
= \ c ->
- case c lvl2 lvl3 of { I# x ->
- case c lvl lvl1 of { I# y -> +# x y }
+ case c lvl2 lvl4 of { I# x ->
+ case c lvl lvl1 of { I# y -> I# (+# x y) }
}
-f1 = \ c -> case $wf1 c of ww { __DEFAULT -> I# ww }
-
yes1 = f1
diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr
index f13121413269..5da8a9f3023f 100644
--- a/testsuite/tests/simplCore/should_compile/T3717.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3717.stderr
@@ -58,7 +58,7 @@ foo [InlPrag=[2]] :: Int -> Int
Arity=1,
Str=<1!P(1L)>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (ds [Occ=Once1!] :: Int) ->
diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout
index 4a67fd841331..6faaab181a95 100644
--- a/testsuite/tests/simplCore/should_compile/T3772.stdout
+++ b/testsuite/tests/simplCore/should_compile/T3772.stdout
@@ -62,12 +62,12 @@ T3772.$wfoo
}
-- RHS size: {terms: 9, types: 4, coercions: 0, joins: 0/0}
-foo [InlPrag=[final]] :: Int -> ()
+foo [InlPrag=NOINLINE[final]] :: Int -> ()
[GblId,
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (n [Occ=Once1!] :: Int) ->
diff --git a/testsuite/tests/simplCore/should_compile/T4201.stdout b/testsuite/tests/simplCore/should_compile/T4201.stdout
index 920ae576628d..68d0bc48fd67 100644
--- a/testsuite/tests/simplCore/should_compile/T4201.stdout
+++ b/testsuite/tests/simplCore/should_compile/T4201.stdout
@@ -1,4 +1,4 @@
+ [HasNoCafRefs, TagSig: <TagProper>, LambdaFormInfo: LFReEntrant 1,
Arity: 1, Strictness: <1!A>, CPR: 1,
- Unfolding: (bof
- `cast`
- (Sym (N:Foo[0]) %<'GHC.Types.Many>_N ->_R <T>_R))]
+ Unfolding: Core: <vanilla>
+ bof `cast` (Sym (N:Foo[0]) %<'GHC.Types.Many>_N ->_R <T>_R)]
diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr
index 307c9fb7280c..a306a5a5e726 100644
--- a/testsuite/tests/simplCore/should_compile/T4908.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4908.stderr
@@ -61,7 +61,7 @@ f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool
Arity=2,
Str=<1!P(1L)><MP(A,1P(1L))>,
Cpr=2,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
Tmpl= \ (ds [Occ=Once1!] :: Int) (x [Occ=Once1!] :: (Int, Int)) ->
diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index 413f8929424d..bc6bacdb4061 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -58,7 +58,7 @@ foo [InlPrag=[2]] :: Int -> Int
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (n [Occ=Once1!] :: Int) ->
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 345efa5a18af..17eb1b593420 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -9,7 +9,7 @@ T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo
Arity=1,
Caf=NoCafRefs,
Str=<SL>,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (conrep [Occ=Once1!] :: Int) ->
@@ -27,12 +27,12 @@ T7360.$wfun1
= \ (x :: Foo) -> case x of { __DEFAULT -> GHC.Prim.(##) }
-- RHS size: {terms: 6, types: 2, coercions: 0, joins: 0/0}
-fun1 [InlPrag=[final]] :: Foo -> ()
+fun1 [InlPrag=NOINLINE[final]] :: Foo -> ()
[GblId,
Arity=1,
Str=<1A>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (x [Occ=Once1] :: Foo) ->
@@ -54,7 +54,7 @@ fun2 :: forall {a}. [a] -> ((), Int)
Arity=1,
Str=<ML>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (@a) (x [Occ=Once1] :: [a]) ->
diff --git a/testsuite/tests/simplCore/should_compile/T7865.stdout b/testsuite/tests/simplCore/should_compile/T7865.stdout
index 1dd2c25893f1..c8758d3af1de 100644
--- a/testsuite/tests/simplCore/should_compile/T7865.stdout
+++ b/testsuite/tests/simplCore/should_compile/T7865.stdout
@@ -1,6 +1,6 @@
T7865.$wexpensive [InlPrag=NOINLINE]
T7865.$wexpensive
-expensive [InlPrag=[final]] :: Int -> Int
+expensive [InlPrag=NOINLINE[final]] :: Int -> Int
case T7865.$wexpensive ww of ww1 [Occ=Once1] { __DEFAULT ->
expensive
case T7865.$wexpensive ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 }
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index e0b2ad49620e..8705eeacea01 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -113,7 +113,7 @@ Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int
Arity=2,
Str=<1L><1L>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
Tmpl= \ (u [Occ=Once1] :: Maybe Int)
@@ -145,7 +145,7 @@ foo :: Int -> Int
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
Tmpl= \ (n [Occ=Once1!] :: Int) ->
--
GitLab