[Git][ghc/ghc][wip/T22272] 3 commits: Mark T21336a fragile
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Dec 13 08:57:57 UTC 2022
Simon Peyton Jones pushed to branch wip/T22272 at Glasgow Haskell Compiler / GHC
Commits:
5d1a1881 by Bryan Richter at 2022-12-12T16:22:36-05:00
Mark T21336a fragile
- - - - -
c30accc2 by Matthew Pickering at 2022-12-12T16:23:11-05:00
Add test for #21476
This issues seems to have been fixed since the ticket was made, so let's
add a test and move on.
Fixes #21476
- - - - -
dfe222cc by Gergő Érdi at 2022-12-13T08:57:41+00:00
Fix loop in the interface representation of some `Unfolding` fields
As discovered in #22272, dehydration of the unfolding info of a
recursive definition used to involve a traversal of the definition
itself, which in turn involves traversing the unfolding info. Hence,
a loop.
Instead, we now store enough data in the interface that we can produce
the unfolding info without this traversal. See Note [Tying the 'CoreUnfolding' knot]
for details.
Fixes #22272
Co-authored-by: Simon Peyton Jones <simon.peytonjones at gmail.com>
- - - - -
25 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Ppr.hs
- compiler/GHC/Core/Seq.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/Core/Unfold/Make.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- libraries/base/tests/IO/T21336/all.T
- testsuite/tests/deSugar/should_compile/T13208.stdout
- testsuite/tests/numeric/should_compile/T14170.stdout
- testsuite/tests/numeric/should_compile/T14465.stdout
- testsuite/tests/numeric/should_compile/T7116.stdout
- + testsuite/tests/simplCore/should_compile/T21476.hs
- + testsuite/tests/simplCore/should_compile/T22272.hs
- + testsuite/tests/simplCore/should_compile/T22272.stderr
- + testsuite/tests/simplCore/should_compile/T22272_A.hs
- testsuite/tests/simplCore/should_compile/T3772.stdout
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -52,7 +52,7 @@ module GHC.Core (
isRuntimeArg, isRuntimeVar,
-- * Unfolding data types
- Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
+ Unfolding(..), UnfoldingCache(..), UnfoldingGuidance(..), UnfoldingSource(..),
-- ** Constructing 'Unfolding's
noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon,
@@ -1277,15 +1277,8 @@ data Unfolding
uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
uf_src :: UnfoldingSource, -- Where the unfolding came from
uf_is_top :: Bool, -- True <=> top level binding
- uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard
- -- a `seq` on this variable
- uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function
- -- Cached version of exprIsConLike
- uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand
- -- inside an inlining
- -- Cached version of exprIsCheap
- uf_expandable :: Bool, -- True <=> can expand in RULE matching
- -- Cached version of exprIsExpandable
+ uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr
+ -- See Note [Tying the 'CoreUnfolding' knot]
uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
}
-- ^ An unfolding with redundant cached information. Parameters:
@@ -1305,7 +1298,22 @@ data Unfolding
-- uf_guidance: Tells us about the /size/ of the unfolding template
-------------------------------------------------
+-- | Properties of a 'CoreUnfolding' that could be computed on-demand from its template.
+-- See Note [UnfoldingCache]
+data UnfoldingCache
+ = UnfoldingCache {
+ uf_is_value :: !Bool, -- exprIsHNF template (cached); it is ok to discard
+ -- a `seq` on this variable
+ uf_is_conlike :: !Bool, -- True <=> applicn of constructor or CONLIKE function
+ -- Cached version of exprIsConLike
+ uf_is_work_free :: !Bool, -- True <=> doesn't waste (much) work to expand
+ -- inside an inlining
+ -- Cached version of exprIsCheap
+ uf_expandable :: !Bool -- True <=> can expand in RULE matching
+ -- Cached version of exprIsExpandable
+ }
+ deriving (Eq)
+
-- | 'UnfoldingGuidance' says when unfolding should take place
data UnfoldingGuidance
= UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl
@@ -1335,7 +1343,23 @@ data UnfoldingGuidance
| UnfNever -- The RHS is big, so don't inline it
deriving (Eq)
-{-
+{- Note [UnfoldingCache]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The UnfoldingCache field of an Unfolding holds four (strict) booleans,
+all derived from the uf_tmpl field of the unfolding.
+
+* We serialise the UnfoldingCache to and from interface files, for
+ reasons described in Note [Tying the 'CoreUnfolding' knot] in
+ GHC.IfaceToCore
+
+* Because it is a strict data type, we must be careful not to
+ pattern-match on it until we actually want its values. E.g
+ GHC.Core.Unfold.callSiteInline/tryUnfolding are careful not to force
+ it unnecessarily. Just saves a bit of work.
+
+* When `seq`ing Core to eliminate space leaks, to suffices to `seq` on
+ the cache, but not its fields, because it is strict in all fields.
+
Note [Historical note: unfoldings for wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We used to have a nice clever scheme in interface files for
@@ -1436,42 +1460,44 @@ otherCons _ = []
-- yield a value (something in HNF): returns @False@ if unsure
isValueUnfolding :: Unfolding -> Bool
-- Returns False for OtherCon
-isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
-isValueUnfolding (DFunUnfolding {}) = True
-isValueUnfolding _ = False
+isValueUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache
+isValueUnfolding (DFunUnfolding {}) = True
+isValueUnfolding _ = False
-- | Determines if it possibly the case that the unfolding will
-- yield a value. Unlike 'isValueUnfolding' it returns @True@
-- for 'OtherCon'
isEvaldUnfolding :: Unfolding -> Bool
-- Returns True for OtherCon
-isEvaldUnfolding (OtherCon _) = True
-isEvaldUnfolding (DFunUnfolding {}) = True
-isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
-isEvaldUnfolding _ = False
+isEvaldUnfolding (OtherCon _) = True
+isEvaldUnfolding (DFunUnfolding {}) = True
+isEvaldUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache
+isEvaldUnfolding _ = False
-- | @True@ if the unfolding is a constructor application, the application
-- of a CONLIKE function or 'OtherCon'
isConLikeUnfolding :: Unfolding -> Bool
-isConLikeUnfolding (OtherCon _) = True
-isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con
-isConLikeUnfolding _ = False
+isConLikeUnfolding (OtherCon _) = True
+isConLikeUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_conlike cache
+isConLikeUnfolding _ = False
-- | Is the thing we will unfold into certainly cheap?
isCheapUnfolding :: Unfolding -> Bool
-isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf
-isCheapUnfolding _ = False
+isCheapUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_work_free cache
+isCheapUnfolding _ = False
isExpandableUnfolding :: Unfolding -> Bool
-isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
-isExpandableUnfolding _ = False
+isExpandableUnfolding (CoreUnfolding { uf_cache = cache }) = uf_expandable cache
+isExpandableUnfolding _ = False
expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
-- Expand an expandable unfolding; this is used in rule matching
-- See Note [Expanding variables] in GHC.Core.Rules
-- The key point here is that CONLIKE things can be expanded
-expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
-expandUnfolding_maybe _ = Nothing
+expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs })
+ | uf_expandable cache
+ = Just rhs
+expandUnfolding_maybe _ = Nothing
isCompulsoryUnfolding :: Unfolding -> Bool
isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -4210,7 +4210,7 @@ simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf
mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource
-> InId -> OutExpr -> SimplM Unfolding
mkLetUnfolding !uf_opts top_lvl src id new_rhs
- = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)
+ = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs Nothing)
-- We make an unfolding *even for loop-breakers*.
-- Reason: (a) It might be useful to know that they are WHNF
-- (b) In GHC.Iface.Tidy we currently assume that, if we want to
@@ -4270,7 +4270,7 @@ simplStableUnfolding env bind_cxt id rhs_ty id_arity unf
-- A test case is #4138
-- But retain a previous boring_ok of True; e.g. see
-- the way it is set in calcUnfoldingGuidanceWithArity
- in return (mkCoreUnfolding src is_top_lvl expr' guide')
+ in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide')
-- See Note [Top-level flag on inline rules] in GHC.Core.Unfold
_other -- Happens for INLINABLE things
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -2169,7 +2169,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 VanillaSrc is_top_lvl False poly_rhs
+ unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False poly_rhs Nothing
-- We want the unfolding. Consider
-- let
=====================================
compiler/GHC/Core/Ppr.hs
=====================================
@@ -627,18 +627,14 @@ instance Outputable Unfolding where
<+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
2 (ppr con <+> sep (map ppr args))
ppr (CoreUnfolding { uf_src = src
- , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf
- , uf_is_conlike=conlike, uf_is_work_free=wf
- , uf_expandable=exp, uf_guidance=g })
+ , uf_tmpl=rhs, uf_is_top=top
+ , uf_cache=cache, uf_guidance=g })
= text "Unf" <> braces (pp_info $$ pp_rhs)
where
pp_info = fsep $ punctuate comma
[ text "Src=" <> ppr src
, text "TopLvl=" <> ppr top
- , text "Value=" <> ppr hnf
- , text "ConLike=" <> ppr conlike
- , text "WorkFree=" <> ppr wf
- , text "Expandable=" <> ppr exp
+ , ppr cache
, text "Guidance=" <> ppr g ]
pp_tmpl = ppUnlessOption sdocSuppressUnfoldings
(text "Tmpl=" <+> ppr rhs)
@@ -647,6 +643,15 @@ instance Outputable Unfolding where
-- Don't print the RHS or we get a quadratic
-- blowup in the size of the printout!
+instance Outputable UnfoldingCache where
+ ppr (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike
+ , uf_is_work_free = wf, uf_expandable = exp })
+ = fsep $ punctuate comma
+ [ text "Value=" <> ppr hnf
+ , text "ConLike=" <> ppr conlike
+ , text "WorkFree=" <> ppr wf
+ , text "Expandable=" <> ppr exp ]
+
{-
-----------------------------------------------------
-- Rules
=====================================
compiler/GHC/Core/Seq.hs
=====================================
@@ -104,10 +104,11 @@ seqAlts (Alt c bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts al
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
- uf_is_value = b1, uf_is_work_free = b2,
- uf_expandable = b3, uf_is_conlike = b4,
- uf_guidance = g})
- = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
+ uf_cache = cache, uf_guidance = g})
+ = seqExpr e `seq` top `seq` cache `seq` seqGuidance g
+ -- The unf_cache :: UnfoldingCache field is a strict data type,
+ -- so it is sufficient to use plain `seq` for this field
+ -- See Note [UnfoldingCache] in GHC.Core
seqUnfolding _ = ()
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -759,7 +759,7 @@ add_info env old_bndr top_level new_rhs new_bndr
unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc
(isTopLevel top_level)
False -- may be bottom or not
- new_rhs
+ new_rhs Nothing
simpleUnfoldingFun :: IdUnfoldingFun
simpleUnfoldingFun id
=====================================
compiler/GHC/Core/Tidy.hs
=====================================
@@ -375,15 +375,16 @@ tidyNestedUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = arg
(tidy_env', bndrs') = tidyBndrs tidy_env bndrs
tidyNestedUnfolding tidy_env
- unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_is_value = is_value })
+ unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_cache = cache })
| isStableSource src
= seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo
- -- This seqIt avoids a space leak: otherwise the uf_is_value,
- -- uf_is_conlike, ... fields may retain a reference to the
- -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)
+ -- This seqIt avoids a space leak: otherwise the uf_cache
+ -- field may retain a reference to the pre-tidied
+ -- expression forever (GHC.CoreToIface doesn't look at
+ -- them)
-- Discard unstable unfoldings, but see Note [Preserve evaluatedness]
- | is_value = evaldUnfolding
+ | uf_is_value cache = evaldUnfolding
| otherwise = noUnfolding
where
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -1036,11 +1036,11 @@ callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_inf
-- Things with an INLINE pragma may have an unfolding *and*
-- be a loop breaker (maybe the knot is not yet untied)
CoreUnfolding { uf_tmpl = unf_template
- , uf_is_work_free = is_wf
- , uf_guidance = guidance, uf_expandable = is_exp }
+ , uf_cache = unf_cache
+ , uf_guidance = guidance }
| active_unfolding -> tryUnfolding logger opts case_depth id lone_variable
arg_infos cont_info unf_template
- is_wf is_exp guidance
+ unf_cache guidance
| otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing
NoUnfolding -> Nothing
BootUnfolding -> Nothing
@@ -1162,11 +1162,10 @@ needed on a per-module basis.
-}
tryUnfolding :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt
- -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance
+ -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance
-> Maybe CoreExpr
-tryUnfolding logger opts !case_depth id lone_variable
- arg_infos cont_info unf_template
- is_wf is_exp guidance
+tryUnfolding logger opts !case_depth id lone_variable arg_infos
+ cont_info unf_template unf_cache guidance
= case guidance of
UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing
@@ -1178,7 +1177,7 @@ tryUnfolding logger opts !case_depth id lone_variable
-> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing
where
some_benefit = calc_some_benefit uf_arity
- enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
+ enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
| unfoldingVeryAggressive opts
@@ -1189,9 +1188,6 @@ tryUnfolding logger opts !case_depth id lone_variable
-> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing
where
some_benefit = calc_some_benefit (length arg_discounts)
- extra_doc = vcat [ text "case depth =" <+> int case_depth
- , text "depth based penalty =" <+> int depth_penalty
- , text "discounted size =" <+> int adjusted_size ]
-- See Note [Avoid inlining into deeply nested cases]
depth_treshold = unfoldingCaseThreshold opts
depth_scaling = unfoldingCaseScaling opts
@@ -1201,7 +1197,18 @@ tryUnfolding logger opts !case_depth id lone_variable
small_enough = adjusted_size <= unfoldingUseThreshold opts
discount = computeDiscount arg_discounts res_discount arg_infos cont_info
+ extra_doc = vcat [ text "case depth =" <+> int case_depth
+ , text "depth based penalty =" <+> int depth_penalty
+ , text "discounted size =" <+> int adjusted_size ]
+
where
+ -- Unpack the UnfoldingCache lazily because it may not be needed, and all
+ -- its fields are strict; so evaluating unf_cache at all forces all the
+ -- isWorkFree etc computations to take place. That risks wasting effort for
+ -- Ids that are never going to inline anyway.
+ -- See Note [UnfoldingCache] in GHC.Core
+ UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache
+
mk_doc some_benefit extra_doc yes_or_no
= vcat [ text "arg infos" <+> ppr arg_infos
, text "interesting continuation" <+> ppr cont_info
=====================================
compiler/GHC/Core/Unfold/Make.hs
=====================================
@@ -6,6 +6,7 @@ module GHC.Core.Unfold.Make
, mkUnfolding
, mkCoreUnfolding
, mkFinalUnfolding
+ , mkFinalUnfolding'
, mkSimpleUnfolding
, mkWorkerUnfolding
, mkInlineUnfoldingWithArity, mkInlineUnfoldingNoArity
@@ -35,6 +36,8 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
+import Data.Maybe ( fromMaybe )
+
-- the very simple optimiser is used to optimise unfoldings
import {-# SOURCE #-} GHC.Core.SimpleOpt
@@ -43,7 +46,14 @@ import {-# SOURCE #-} GHC.Core.SimpleOpt
mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding
-- "Final" in the sense that this is a GlobalId that will not be further
-- simplified; so the unfolding should be occurrence-analysed
-mkFinalUnfolding opts src strict_sig expr
+mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr Nothing
+
+-- See Note [Tying the 'CoreUnfolding' knot] for why interfaces need
+-- to pass a precomputed 'UnfoldingCache'
+mkFinalUnfolding' :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding
+-- "Final" in the sense that this is a GlobalId that will not be further
+-- simplified; so the unfolding should be occurrence-analysed
+mkFinalUnfolding' opts src strict_sig expr
= mkUnfolding opts src
True {- Top level -}
(isDeadEndSig strict_sig)
@@ -57,7 +67,7 @@ mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts exp
mkCompulsoryUnfolding :: CoreExpr -> Unfolding
mkCompulsoryUnfolding expr
= mkCoreUnfolding CompulsorySrc True
- expr
+ expr Nothing
(UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter
, ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })
@@ -69,7 +79,7 @@ mkCompulsoryUnfolding expr
mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding
mkSimpleUnfolding !opts rhs
- = mkUnfolding opts VanillaSrc False False rhs
+ = mkUnfolding opts VanillaSrc False False rhs Nothing
mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding
mkDFunUnfolding bndrs con ops
@@ -81,7 +91,7 @@ mkDFunUnfolding bndrs con ops
mkDataConUnfolding :: CoreExpr -> Unfolding
-- Used for non-newtype data constructors with non-trivial wrappers
mkDataConUnfolding expr
- = mkCoreUnfolding StableSystemSrc True expr guide
+ = mkCoreUnfolding StableSystemSrc True expr Nothing guide
-- No need to simplify the expression
where
guide = UnfWhen { ug_arity = manifestArity expr
@@ -93,7 +103,7 @@ mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding
-- after demand/CPR analysis
mkWrapperUnfolding opts expr arity
= mkCoreUnfolding StableSystemSrc True
- (simpleOptExpr opts expr)
+ (simpleOptExpr opts expr) Nothing
(UnfWhen { ug_arity = arity
, ug_unsat_ok = unSaturatedOk
, ug_boring_ok = boringCxtNotOk })
@@ -104,7 +114,7 @@ mkWorkerUnfolding opts work_fn
(CoreUnfolding { uf_src = src, uf_tmpl = tmpl
, uf_is_top = top_lvl })
| isStableSource src
- = mkCoreUnfolding src top_lvl new_tmpl guidance
+ = mkCoreUnfolding src top_lvl new_tmpl Nothing guidance
where
new_tmpl = simpleOptExpr opts (work_fn tmpl)
guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl
@@ -119,7 +129,7 @@ mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfoldi
mkInlineUnfoldingNoArity opts src expr
= mkCoreUnfolding src
True -- Note [Top-level flag on inline rules]
- expr' guide
+ expr' Nothing guide
where
expr' = simpleOptExpr opts expr
guide = UnfWhen { ug_arity = manifestArity expr'
@@ -133,7 +143,7 @@ mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr
mkInlineUnfoldingWithArity opts src arity expr
= mkCoreUnfolding src
True -- Note [Top-level flag on inline rules]
- expr' guide
+ expr' Nothing guide
where
expr' = simpleOptExpr opts expr
guide = UnfWhen { ug_arity = arity
@@ -146,7 +156,7 @@ mkInlineUnfoldingWithArity opts src arity expr
mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding
mkInlinableUnfolding opts src expr
- = mkUnfolding (so_uf_opts opts) src False False expr'
+ = mkUnfolding (so_uf_opts opts) src False False expr' Nothing
where
expr' = simpleOptExpr opts expr
@@ -180,7 +190,7 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args
, uf_guidance = old_guidance })
| isStableSource src -- See Note [Specialising unfoldings]
, UnfWhen { ug_arity = old_arity } <- old_guidance
- = mkCoreUnfolding src top_lvl new_tmpl
+ = mkCoreUnfolding src top_lvl new_tmpl Nothing
(old_guidance { ug_arity = old_arity - arity_decrease })
where
new_tmpl = simpleOptExpr opts $
@@ -310,11 +320,12 @@ mkUnfolding :: UnfoldingOpts
-> Bool -- Definitely a bottoming binding
-- (only relevant for top-level bindings)
-> CoreExpr
+ -> Maybe UnfoldingCache
-> Unfolding
-- Calculates unfolding guidance
-- Occurrence-analyses the expression before capturing it
-mkUnfolding opts src top_lvl is_bottoming expr
- = mkCoreUnfolding src top_lvl expr guidance
+mkUnfolding opts src top_lvl is_bottoming expr cache
+ = mkCoreUnfolding src top_lvl expr cache guidance
where
is_top_bottoming = top_lvl && is_bottoming
guidance = calcUnfoldingGuidance opts is_top_bottoming expr
@@ -322,26 +333,20 @@ mkUnfolding opts src top_lvl is_bottoming expr
-- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]
mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr
- -> UnfoldingGuidance -> Unfolding
+ -> Maybe UnfoldingCache -> UnfoldingGuidance -> Unfolding
-- Occurrence-analyses the expression before capturing it
-mkCoreUnfolding src top_lvl expr guidance
- = CoreUnfolding { uf_tmpl = is_value `seq`
- is_conlike `seq`
- is_work_free `seq`
- is_expandable `seq`
+mkCoreUnfolding src top_lvl expr precomputed_cache guidance
+ = CoreUnfolding { uf_tmpl = cache `seq`
occurAnalyseExpr expr
-- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]
- -- See #20905 for what a discussion of these 'seq's
+ -- See #20905 for what a discussion of this 'seq'.
-- 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_cache = cache
, uf_guidance = guidance }
where
is_value = exprIsHNF expr
@@ -349,6 +354,13 @@ mkCoreUnfolding src top_lvl expr guidance
is_work_free = exprIsWorkFree expr
is_expandable = exprIsExpandable expr
+ recomputed_cache = UnfoldingCache { uf_is_value = is_value
+ , uf_is_conlike = is_conlike
+ , uf_is_work_free = is_work_free
+ , uf_expandable = is_expandable }
+
+ cache = fromMaybe recomputed_cache precomputed_cache
+
----------------
certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding
-- ^ Sees if the unfolding is pretty certain to inline.
@@ -476,4 +488,3 @@ reducing memory pressure.
The result of fixing this led to a 1G reduction in peak memory usage (12G -> 11G) when
compiling a very large module (peak 3 million terms). For more discussion see #20905.
-}
-
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -2253,10 +2253,9 @@ diffUnfold env (DFunUnfolding bs1 c1 a1)
| c1 == c2 && equalLength bs1 bs2
= concatMap (uncurry (diffExpr False env')) (zip a1 a2)
where env' = rnBndrs2 env bs1 bs2
-diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)
- (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2)
- | v1 == v2 && cl1 == cl2
- && wf1 == wf2 && x1 == x2 && g1 == g2
+diffUnfold env (CoreUnfolding t1 _ _ c1 g1)
+ (CoreUnfolding t2 _ _ c2 g2)
+ | c1 == c2 && g1 == g2
= diffExpr False env t1 t2
diffUnfold _ uf1 uf2
= [fsep [ppr uf1, text "/=", ppr uf2]]
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -508,9 +508,10 @@ toIfaceJoinInfo Nothing = IfaceNotJoinPoint
toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem
toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs
, uf_src = src
+ , uf_cache = cache
, uf_guidance = guidance })
= Just $ HsUnfold lb $
- IfCoreUnfold src (toIfGuidance src guidance) (toIfaceExpr rhs)
+ IfCoreUnfold src cache (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
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -596,8 +596,8 @@ rnIfaceInfoItem i
= pure i
rnIfaceUnfolding :: Rename IfaceUnfolding
-rnIfaceUnfolding (IfCoreUnfold src guide if_expr)
- = IfCoreUnfold src guide <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfCoreUnfold src cache guide if_expr)
+ = IfCoreUnfold src cache guide <$> rnIfaceExpr if_expr
rnIfaceUnfolding (IfDFunUnfold bs ops)
= IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -49,7 +49,7 @@ import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey,
import GHC.Types.Unique ( hasKey )
import GHC.Iface.Type
import GHC.Iface.Recomp.Binary
-import GHC.Core( IsOrphan, isOrphan )
+import GHC.Core( IsOrphan, isOrphan, UnfoldingCache(..) )
import GHC.Types.Demand
import GHC.Types.Cpr
import GHC.Core.Class
@@ -365,9 +365,14 @@ data IfaceInfoItem
-- only later attached to the Id. Partial reason: some are orphans.
data IfaceUnfolding
- = IfCoreUnfold UnfoldingSource IfGuidance IfaceExpr
+ = IfCoreUnfold UnfoldingSource
+ IfUnfoldingCache -- See Note [Tying the 'CoreUnfolding' knot]
+ IfGuidance
+ IfaceExpr
| IfDFunUnfold [IfaceBndr] [IfaceExpr]
+type IfUnfoldingCache = UnfoldingCache
+
data IfGuidance
= IfNoGuidance -- Compute it from the IfaceExpr
| IfWhen Arity Bool Bool -- Just like UnfWhen in Core.UnfoldingGuidance
@@ -1522,7 +1527,7 @@ instance Outputable IfaceJoinInfo where
ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)
instance Outputable IfaceUnfolding where
- ppr (IfCoreUnfold src guide 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))
@@ -1774,7 +1779,7 @@ freeNamesItem (HsLFInfo (IfLFCon n)) = unitNameSet n
freeNamesItem _ = emptyNameSet
freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold _ _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfCoreUnfold _ _ _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es
freeNamesIfExpr :: IfaceExpr -> NameSet
@@ -2296,9 +2301,10 @@ instance Binary IfaceInfoItem where
_ -> HsTagSig <$> get bh
instance Binary IfaceUnfolding where
- put_ bh (IfCoreUnfold s g e) = do
+ put_ bh (IfCoreUnfold s c g e) = do
putByte bh 0
put_ bh s
+ putUnfoldingCache bh c
put_ bh g
put_ bh e
put_ bh (IfDFunUnfold as bs) = do
@@ -2309,9 +2315,10 @@ instance Binary IfaceUnfolding where
h <- getByte bh
case h of
0 -> do s <- get bh
+ c <- getUnfoldingCache bh
g <- get bh
e <- get bh
- return (IfCoreUnfold s g e)
+ return (IfCoreUnfold s c g e)
_ -> do as <- get bh
bs <- get bh
return (IfDFunUnfold as bs)
@@ -2332,6 +2339,26 @@ instance Binary IfGuidance where
c <- get bh
return (IfWhen a b c)
+putUnfoldingCache :: BinHandle -> IfUnfoldingCache -> IO ()
+putUnfoldingCache bh (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike
+ , uf_is_work_free = wf, uf_expandable = exp }) = do
+ let b = zeroBits .<<|. hnf .<<|. conlike .<<|. wf .<<|. exp
+ putByte bh b
+
+getUnfoldingCache :: BinHandle -> IO IfUnfoldingCache
+getUnfoldingCache bh = do
+ b <- getByte bh
+ let hnf = testBit b 3
+ conlike = testBit b 2
+ wf = testBit b 1
+ exp = testBit b 0
+ return (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike
+ , uf_is_work_free = wf, uf_expandable = exp })
+
+infixl 9 .<<|.
+(.<<|.) :: (Bits a) => a -> Bool -> a
+x .<<|. b = (if b then (`setBit` 0) else id) (x `shiftL` 1)
+
instance Binary IfaceAlt where
put_ bh (IfaceAlt a b c) = do
put_ bh a
@@ -2688,8 +2715,9 @@ instance NFData IfGuidance where
instance NFData IfaceUnfolding where
rnf = \case
- IfCoreUnfold src guidance expr -> src `seq` rnf guidance `seq` rnf expr
- IfDFunUnfold bndrs exprs -> rnf bndrs `seq` rnf exprs
+ IfCoreUnfold src cache guidance expr -> src `seq` cache `seq` rnf guidance `seq` rnf expr
+ IfDFunUnfold bndrs exprs -> rnf bndrs `seq` rnf exprs
+ -- See Note [UnfoldingCache] in GHC.Core for why it suffices to merely `seq` on cache
instance NFData IfaceExpr where
rnf = \case
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1715,7 +1715,7 @@ 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 _ (IfCoreUnfold src _ _)) = isCompulsorySource src
+ need_prag (HsUnfold _ (IfCoreUnfold src _ _ _)) = isCompulsorySource src
need_prag _ = False
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
@@ -1776,13 +1776,14 @@ tcLFInfo lfi = case lfi of
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
-- See Note [Lazily checking Unfoldings]
-tcUnfolding toplvl name _ info (IfCoreUnfold src if_guidance if_expr)
+tcUnfolding toplvl name _ info (IfCoreUnfold src cache if_guidance if_expr)
= do { uf_opts <- unfoldingOpts <$> getDynFlags
; 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 }
+ -- See Note [Tying the 'CoreUnfolding' knot]
+ ; return $ mkCoreUnfolding src True expr (Just cache) guidance }
where
-- Strictness should occur before unfolding!
is_top_bottoming = isTopLevel toplvl && isDeadEndSig (dmdSigInfo info)
@@ -1795,6 +1796,49 @@ tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
doc = text "Class ops for dfun" <+> ppr name
(_, _, cls, _) = tcSplitDFunTy dfun_ty
+{- Note [Tying the 'CoreUnfolding' knot]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The unfolding of recursive definitions can contain references to the
+Id being defined. Consider the following example:
+
+ foo :: ()
+ foo = foo
+
+The unfolding template of 'foo' is, of course, 'foo'; so the interface
+file for this module contains:
+
+ foo :: (); Unfolding = foo
+
+When rehydrating the interface file we are going to make an Id for
+'foo' (in GHC.IfaceToCore), with an 'Unfolding'. We used to make this
+'Unfolding' by calling 'mkFinalUnfolding', but that needs to populate,
+among other fields, the 'uf_is_value' field, by computing
+'exprIsValue' of the template (in this case, 'foo').
+
+'exprIsValue e' looks at the unfoldings of variables in 'e' to see if
+they are evaluated; so it consults the `uf_is_value` field of
+variables in `e`. Now we can see the problem: to set the `uf_is_value`
+field of `foo`'s unfolding, we look at its unfolding (in this case
+just `foo` itself!). Loop. This is the root cause of ticket #22272.
+
+The simple solution we chose is to serialise the various auxiliary
+fields of `CoreUnfolding` so that we don't need to recreate them when
+rehydrating. Specifically, the following fields are moved to the
+'UnfoldingCache', which is persisted in the interface file:
+
+* 'uf_is_conlike'
+* 'uf_is_value'
+* 'uf_is_work_free'
+* 'uf_expandable'
+
+These four bits make the interface files only one byte larger per
+unfolding; on the other hand, this does save calls to 'exprIsValue',
+'exprIsExpandable' etc for every imported Id.
+
+We could choose to do this only for loop breakers. But that's a bit
+more complicated and it seems good all round.
+-}
+
{- Note [Lazily checking Unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For unfoldings, we try to do the job lazily, so that we never typecheck
=====================================
libraries/base/tests/IO/T21336/all.T
=====================================
@@ -1,6 +1,9 @@
# N.B. /dev/full exists on Darwin but cannot be opened, failing with -EPERM
test('T21336a',
- [unless(opsys('linux') or opsys('freebsd'), skip), js_broken(22261)],
+ [ unless(opsys('linux') or opsys('freebsd'), skip)
+ , js_broken(22261)
+ , fragile(22022)
+ ],
compile_and_run, [''])
test('T21336b',
[unless(opsys('linux') or opsys('freebsd'), skip), js_broken(22352)],
=====================================
testsuite/tests/deSugar/should_compile/T13208.stdout
=====================================
@@ -1,6 +1,6 @@
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)}]
f = \ (@p) _ [Occ=Dead] -> GHC.Types.True
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 80 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
=====================================
testsuite/tests/numeric/should_compile/T14170.stdout
=====================================
@@ -6,44 +6,50 @@ Result size of Tidy Core
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
NatVal.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
NatVal.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
NatVal.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
NatVal.$trModule3 = GHC.Types.TrNameS NatVal.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
NatVal.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
NatVal.$trModule2 = "NatVal"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
NatVal.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
NatVal.$trModule1 = GHC.Types.TrNameS NatVal.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
NatVal.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
NatVal.$trModule
= GHC.Types.Module NatVal.$trModule3 NatVal.$trModule1
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
foo :: Integer
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
foo = GHC.Num.Integer.IS 0#
=====================================
testsuite/tests/numeric/should_compile/T14465.stdout
=====================================
@@ -6,43 +6,49 @@ Result size of Tidy Core
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
ten :: Natural
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
ten = GHC.Num.Natural.NS 10##
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
M.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
M.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
M.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
M.$trModule3 = GHC.Types.TrNameS M.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
M.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
M.$trModule2 = "M"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
M.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
M.$trModule1 = GHC.Types.TrNameS M.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
M.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
M.$trModule = GHC.Types.Module M.$trModule3 M.$trModule1
-- RHS size: {terms: 1, types: 1, coercions: 0, joins: 0/0}
@@ -50,23 +56,25 @@ minusOne :: Natural
[GblId,
Str=b,
Cpr=b,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=False, ConLike=False, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
minusOne = GHC.Prim.Exception.raiseUnderflow @Natural
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
twoTimesTwo :: Natural
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
twoTimesTwo = GHC.Num.Natural.NS 4##
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
M.one1 :: Natural
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
M.one1 = GHC.Num.Natural.NS 1##
-- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0}
@@ -74,15 +82,16 @@ plusOne :: Natural -> Natural
[GblId,
Arity=1,
Str=<1L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [0] 30 0}]
plusOne = \ (n :: Natural) -> naturalAdd n M.one1
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
one :: Natural
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
one = M.one1
=====================================
testsuite/tests/numeric/should_compile/T7116.stdout
=====================================
@@ -6,36 +6,41 @@ Result size of Tidy Core
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T7116.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T7116.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T7116.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7116.$trModule3 = GHC.Types.TrNameS T7116.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T7116.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T7116.$trModule2 = "T7116"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T7116.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7116.$trModule1 = GHC.Types.TrNameS T7116.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T7116.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T7116.$trModule
= GHC.Types.Module T7116.$trModule3 T7116.$trModule1
@@ -45,8 +50,8 @@ dr :: Double -> Double
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=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) ->
case x of { GHC.Types.D# x1 ->
@@ -62,8 +67,8 @@ dl :: Double -> Double
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
dl = dr
@@ -73,8 +78,8 @@ fr :: Float -> Float
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=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) ->
case x of { GHC.Types.F# x1 ->
@@ -92,8 +97,8 @@ fl :: Float -> Float
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
fl = fr
=====================================
testsuite/tests/simplCore/should_compile/T21476.hs
=====================================
@@ -0,0 +1,4 @@
+{-# LANGUAGE MagicHash #-}
+module T21476 where
+import GHC.Exts
+f = keepAlive#
=====================================
testsuite/tests/simplCore/should_compile/T22272.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module T22272 where
+
+import T22272_A
+
+bar :: ()
+bar = foo
=====================================
testsuite/tests/simplCore/should_compile/T22272.stderr
=====================================
@@ -0,0 +1,2 @@
+[1 of 2] Compiling T22272_A ( T22272_A.hs, T22272_A.o )
+[2 of 2] Compiling T22272 ( T22272.hs, T22272.o )
=====================================
testsuite/tests/simplCore/should_compile/T22272_A.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module T22272_A where
+
+foo :: ()
+foo = foo
=====================================
testsuite/tests/simplCore/should_compile/T3772.stdout
=====================================
@@ -6,36 +6,41 @@ Result size of Tidy Core
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T3772.$trModule4 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 20 0}]
T3772.$trModule4 = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T3772.$trModule3 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T3772.$trModule3 = GHC.Types.TrNameS T3772.$trModule4
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
T3772.$trModule2 :: GHC.Prim.Addr#
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 30 0}]
T3772.$trModule2 = "T3772"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T3772.$trModule1 :: GHC.Types.TrName
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T3772.$trModule1 = GHC.Types.TrNameS T3772.$trModule2
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T3772.$trModule :: GHC.Types.Module
[GblId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
T3772.$trModule
= GHC.Types.Module T3772.$trModule3 T3772.$trModule1
@@ -67,8 +72,8 @@ foo [InlPrag=NOINLINE[final]] :: Int -> ()
Arity=1,
Str=<1!P(L)>,
Cpr=1,
- Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=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) ->
case n of { GHC.Types.I# ww [Occ=Once1] ->
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -456,3 +456,5 @@ test('T22317', [grep_errmsg(r'ANSWER = YES') ], compile, ['-O -dinline-check m -
test('T22494', [grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
test('T22491', normal, compile, ['-O2'])
+test('T21476', normal, compile, [''])
+test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings -fno-omit-interface-pragmas -fno-ignore-interface-pragmas'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ce35a4bb732dc37e77597ca47b1d7579c92bb0f...dfe222ccfb999b2ffce782972137b28c3e2152a0
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2ce35a4bb732dc37e77597ca47b1d7579c92bb0f...dfe222ccfb999b2ffce782972137b28c3e2152a0
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221213/76dfeff6/attachment-0001.html>
More information about the ghc-commits
mailing list