[Git][ghc/ghc][wip/T23208] DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Tue Apr 11 18:59:43 UTC 2023
Sebastian Graf pushed to branch wip/T23208 at Glasgow Haskell Compiler / GHC
Commits:
14d53950 by Sebastian Graf at 2023-04-11T20:57:25+02:00
DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208)
In #23208 we observed that the demand signature of a binder occuring in a RULE
wasn't unleashed, leading to a transitively used binder being discarded as
absent. The solution was to use the same code path that we already use for
handling exported bindings.
See the changes to `Note [Absence analysis for stable unfoldings and RULES]`
for more details.
There is a single regression in T18894 because we are more conservative around
stable unfoldings now. Unfortunately it is not easily fixed; let's wait until
there is a concrete motivation before invest more time.
Fixes #23208.
- - - - -
7 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Types/Demand.hs
- testsuite/tests/stranal/should_compile/T18894.stderr
- + testsuite/tests/stranal/should_run/T23208.hs
- + testsuite/tests/stranal/should_run/T23208.stderr
- + testsuite/tests/stranal/should_run/T23208_Lib.hs
- testsuite/tests/stranal/should_run/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -97,28 +97,33 @@ dmdAnalProgram opts fam_envs rules binds
where
anal_body env'
| WithDmdType body_ty bs' <- go env' bs
- = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs'
+ = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs'
cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]
cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs')
- add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType
- add_exported_uses env = foldl' (add_exported_use env)
-
- -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@
- -- corresponds to the demand type of @(id, e)@, but is a lot more direct.
- -- See Note [Analysing top-level bindings].
- add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType
- add_exported_use env dmd_ty id
- | isExportedId id || elemVarSet id rule_fvs
- -- See Note [Absence analysis for stable unfoldings and RULES]
- = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))
- | otherwise
- = dmd_ty
+ keep_alive_roots :: AnalEnv -> [Id] -> PlusDmdArg
+ -- See Note [Absence analysis for stable unfoldings and RULES]
+ -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in
+ -- orphan RULES
+ keep_alive_roots env ids = keepAlive env (filter is_root ids)
+
+ is_root :: Id -> Bool
+ is_root id = isExportedId id || elemVarSet id rule_fvs
rule_fvs :: IdSet
rule_fvs = rulesRhsFreeIds rules
+keepAlive :: AnalEnv -> [Id] -> PlusDmdArg
+-- See Note [Absence analysis for stable unfoldings and RULES]
+keepAlive _ [] = (emptyVarEnv, topDiv)
+keepAlive env ids
+ = foldl1' plusDmdArg $ fmap (fst . dmdAnalStar env topDmd . Var) ids
+
+keepAliveSet :: AnalEnv -> IdSet -> PlusDmdArg
+keepAliveSet env ids = keepAlive env (nonDetEltsUniqSet ids)
+ -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative
+
-- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings
-- that satisfy this function.
--
@@ -343,7 +348,7 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec
-- See Note [Absence analysis for stable unfoldings and RULES]
rule_fvs = bndrRuleAndUnfoldingIds id
- final_ty = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs
+ final_ty = body_ty' `plusDmdType` rhs_ty `plusDmdType` keepAliveSet env rule_fvs
-- | Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
@@ -415,7 +420,7 @@ dmdAnalStar env (n :* sd) e
, n' <- anticipateANF e n
-- See Note [Anticipating ANF in demand analysis]
-- and Note [Analysing with absent demand]
- = (toPlusDmdArg $ multDmdType n' dmd_ty, e')
+ = (discardArgDmds $ multDmdType n' dmd_ty, e')
-- Main Demand Analysis machinery
dmdAnal, dmdAnal' :: AnalEnv
@@ -532,7 +537,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs])
= alt_ty2
WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut
- res_ty = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty
+ res_ty = alt_ty3 `plusDmdType` discardArgDmds scrut_ty
in
-- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
-- , text "dmd" <+> ppr dmd
@@ -569,7 +574,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
= deferAfterPreciseException alt_ty1
| otherwise
= alt_ty1
- res_ty = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty
+ res_ty = scrut_ty `plusDmdType` discardArgDmds alt_ty2
in
-- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
@@ -1103,7 +1108,8 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
NonRecursive -> rhs_fv
-- See Note [Absence analysis for stable unfoldings and RULES]
- rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id
+ -- Since the result of keepAliveSet will have topDiv, rhs_div == _rhs_div'
+ (rhs_fv2, _rhs_div') = (rhs_fv1, rhs_div) `plusDmdArg` keepAliveSet env (bndrRuleAndUnfoldingIds id)
-- See Note [Lazy and unleashable free variables]
!(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
@@ -1365,8 +1371,8 @@ GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity.
Note [Absence analysis for stable unfoldings and RULES]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticket #18638 shows that it's really important to do absence analysis
-for stable unfoldings. Consider
+Among others, tickets #18638 and #23208 show that it's really important to do
+absence analysis for stable unfoldings. Consider
g = blah
@@ -1383,9 +1389,8 @@ and transform to
Now if f is subsequently inlined, we'll use 'g' and ... disaster.
-SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands
-on its free variables) so that no variable mentioned in its unfolding
-is Absent. This is done by the function Demand.keepAliveDmdEnv.
+SOLUTION: if f has a stable unfolding, analyse every free variable as if it
+was a variable occuring in a 'topDmd' context. This is done in `keepAlive`.
ALSO: do the same for Ids free in the RHS of any RULES for f.
@@ -1401,6 +1406,28 @@ Now f's optimised RHS will be \x.a, but if we change g to (error "..")
disaster. But regardless, #18638 was a more complicated version of
this, that actually happened in practice.
+PPS: You might wonder why we don't simply take the free vars of the
+unfolding/RULE and map them to topDmd. The reason is that any of the free vars
+might have demand signatures themselves that in turn keep transitive free
+variables alive and that we hence need to unleash! This came up in #23208.
+Consider
+
+ err :: Int -> b
+ err = error "really important message"
+
+ sg :: Int -> Int
+ sg _ = case err of {} -- Str=<1B>b {err:->S}
+
+ g :: a -> a -- g is exported
+ g x = x
+ {-# RULES "g" g @Int = sg #-}
+
+Here, `err` is only kept alive by `sg`'s demand signature: It doesn't occur
+in the lazy_fvs of `sg`'s RHS at all. Hence when we `keepAlive` `sg` because it
+occurs in the RULEs of `g` (which is exported), we better unleash the demand
+signature of `sg`, too! In #23208 we failed to do so and observed an absent
+error instead of the `really important message`.
+
Note [DmdAnal for DataCon wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We give DataCon wrappers a (necessarily flat) demand signature in
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -44,8 +44,7 @@ module GHC.Types.Demand (
unboxDeeplyDmd,
-- * Demand environments
- DmdEnv, emptyDmdEnv,
- keepAliveDmdEnv, reuseEnv,
+ DmdEnv, emptyDmdEnv, reuseEnv,
-- * Divergence
Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv,
@@ -56,10 +55,9 @@ module GHC.Types.Demand (
nopDmdType, botDmdType,
lubDmdType, plusDmdType, multDmdType,
-- *** PlusDmdArg
- PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,
+ PlusDmdArg, mkPlusDmdArg, discardArgDmds, plusDmdArg,
-- ** Other operations
peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,
- keepAliveDmdType,
-- * Demand signatures
DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig,
@@ -85,9 +83,8 @@ module GHC.Types.Demand (
import GHC.Prelude
-import GHC.Types.Var ( Var, Id )
+import GHC.Types.Var
import GHC.Types.Var.Env
-import GHC.Types.Var.Set
import GHC.Types.Unique.FM
import GHC.Types.Basic
import GHC.Data.Maybe ( orElse )
@@ -1466,7 +1463,7 @@ lubDivergence _ _ = Dunno
-- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2
-- (See Note [Default demand on free variables and arguments] for why)
--- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence'
+-- | See Note [Asymmetry of plusDmdType], which concludes that 'plusDivergence'
-- needs to be symmetric.
-- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv at .
-- But that regresses in too many places (every infinite loop, basically) to be
@@ -1750,23 +1747,6 @@ multDmdEnv n env = mapVarEnv (multDmd n) env
reuseEnv :: DmdEnv -> DmdEnv
reuseEnv = multDmdEnv C_1N
--- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have
--- /some/ usage in the returned demand types -- they are not Absent.
--- See Note [Absence analysis for stable unfoldings and RULES]
--- in "GHC.Core.Opt.DmdAnal".
-keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv
-keepAliveDmdEnv env vs
- = nonDetStrictFoldVarSet add env vs
- where
- add :: Id -> DmdEnv -> DmdEnv
- add v env = extendVarEnv_C add_dmd env v topDmd
-
- add_dmd :: Demand -> Demand -> Demand
- -- If the existing usage is Absent, make it used
- -- Otherwise leave it alone
- add_dmd dmd _ | isAbsDmd dmd = topDmd
- | otherwise = dmd
-
-- | Characterises how an expression
--
-- * Evaluates its free variables ('dt_env')
@@ -1811,20 +1791,27 @@ type PlusDmdArg = (DmdEnv, Divergence)
mkPlusDmdArg :: DmdEnv -> PlusDmdArg
mkPlusDmdArg env = (env, topDiv)
-toPlusDmdArg :: DmdType -> PlusDmdArg
-toPlusDmdArg (DmdType fv _ r) = (fv, r)
+discardArgDmds :: DmdType -> PlusDmdArg
+discardArgDmds (DmdType fv _ r) = (fv, r)
plusDmdType :: DmdType -> PlusDmdArg -> DmdType
-plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)
- -- See Note [Asymmetry of 'plus*']
- -- 'plus' takes the argument/result info from its *first* arg,
- -- using its second arg just for its free-var info.
- | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd
- = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient
+plusDmdType (DmdType fv ds d) pda
+ -- See Note [Asymmetry of plusDmdType]
+ -- 'plus' takes the argument demands from its *first* arg, using its second
+ -- arg just for its free-var info and divergence.
+ | (fv', d') <- plusDmdArg (fv,d) pda
+ = DmdType fv' ds d'
+
+plusDmdArg :: PlusDmdArg -> PlusDmdArg -> PlusDmdArg
+plusDmdArg (fv1, d1) (fv2, d2)
+ -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric.
+ | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd
+ = (fv1, d1 `plusDivergence` d2) -- a very common case that is much more efficient
+ | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd
+ = (fv2, d1 `plusDivergence` d2) -- another very common case that is much more efficient
| otherwise
- = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))
- ds1
- (r1 `plusDivergence` t2)
+ = ( plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)
+ , d1 `plusDivergence` d2)
botDmdType :: DmdType
botDmdType = DmdType emptyDmdEnv [] botDiv
@@ -1914,11 +1901,6 @@ findIdDemand (DmdType fv _ res) id
deferAfterPreciseException :: DmdType -> DmdType
deferAfterPreciseException = lubDmdType exnDmdType
--- | See 'keepAliveDmdEnv'.
-keepAliveDmdType :: DmdType -> VarSet -> DmdType
-keepAliveDmdType (DmdType fvs ds res) vars =
- DmdType (fvs `keepAliveDmdEnv` vars) ds res
-
{- Note [deferAfterPreciseException]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The big picture is in Note [Precise exceptions and strictness analysis]
@@ -1999,7 +1981,7 @@ Note that 'lubDmdType' maintains this kind of equality by using 'plusVarEnv_CD',
involving 'defaultFvDmd' for any entries present in one 'dt_env' but not the
other.
-Note [Asymmetry of 'plus*']
+Note [Asymmetry of plusDmdType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
'plus' for DmdTypes is *asymmetrical*, because there can only one
be one type contributing argument demands! For example, given (e1 e2), we get
=====================================
testsuite/tests/stranal/should_compile/T18894.stderr
=====================================
@@ -1,48 +1,54 @@
-==================== Demand analysis ====================
-Result size of Demand analysis
+==================== Demand analysis (including Boxity) ====================
+Result size of Demand analysis (including Boxity)
= {terms: 189, types: 95, coercions: 0, joins: 0/2}
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
- 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}]
$trModule = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
- 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}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
- 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}]
$trModule = "T18894"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
- 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}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T18894.$trModule :: GHC.Types.Module
[LclIdX,
- 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}]
T18894.$trModule = GHC.Types.Module $trModule $trModule
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- 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}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 42, types: 15, coercions: 0, joins: 0/1}
@@ -51,8 +57,9 @@ g2 [InlPrag=NOINLINE, Dmd=LC(S,C(1,!P(M!P(L),1!P(L))))]
[LclId,
Arity=2,
Str=<L><1!P(1L)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 106 20}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20 20] 106 20}]
g2
= \ (m :: Int) (ds [Dmd=1!P(1L)] :: Int) ->
case ds of { GHC.Types.I# ds [Dmd=1L] ->
@@ -64,8 +71,9 @@ g2
let {
c1# :: GHC.Prim.Int#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 2 0}]
c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in
case GHC.Prim.-# (GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild) c1#
of ds2
@@ -81,22 +89,25 @@ g2
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- 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}]
lvl = GHC.Types.I# 2#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- 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}]
lvl = GHC.Types.I# 2#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- 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}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 36, types: 19, coercions: 0, joins: 0/0}
@@ -104,8 +115,9 @@ h2 :: Int -> Int
[LclIdX,
Arity=1,
Str=<1P(SL)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 162 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20] 162 10}]
h2
= \ (ds [Dmd=1P(SL)] :: Int) ->
case ds of wild { GHC.Types.I# ds [Dmd=SL] ->
@@ -128,22 +140,25 @@ h2
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- 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}]
lvl = GHC.Types.I# 15#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- 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}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
lvl :: (Int, Int)
[LclId,
- 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}]
lvl = (lvl, lvl)
-- RHS size: {terms: 36, types: 10, coercions: 0, joins: 0/1}
@@ -151,8 +166,9 @@ g1 [InlPrag=NOINLINE, Dmd=LC(L,!P(L,L))] :: Int -> (Int, Int)
[LclId,
Arity=1,
Str=<1!P(1L)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 86 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20] 86 10}]
g1
= \ (ds [Dmd=1!P(1L)] :: Int) ->
case ds of { GHC.Types.I# ds [Dmd=1L] ->
@@ -164,8 +180,9 @@ g1
let {
c1# :: GHC.Prim.Int#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 2 0}]
c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in
case GHC.Prim.-# (GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild) c1#
of ds2
@@ -181,15 +198,17 @@ g1
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- 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}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
lvl :: (Int, Int)
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 30 0}]
lvl = g1 (GHC.Types.I# 2#)
-- RHS size: {terms: 28, types: 18, coercions: 0, joins: 0/0}
@@ -197,8 +216,9 @@ h1 :: Int -> Int
[LclIdX,
Arity=1,
Str=<1!P(SL)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 111 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20] 111 10}]
h1
= \ (ds [Dmd=1!P(SL)] :: Int) ->
case ds of wild [Dmd=M!P(1L)] { GHC.Types.I# ds [Dmd=SL] ->
@@ -224,43 +244,49 @@ Result size of Demand analysis
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
- 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}]
$trModule = "main"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
- 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}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Prim.Addr#
[LclId,
- 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}]
$trModule = "T18894"#
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
$trModule :: GHC.Types.TrName
[LclId,
- 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}]
$trModule = GHC.Types.TrNameS $trModule
-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
T18894.$trModule :: GHC.Types.Module
[LclIdX,
- 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}]
T18894.$trModule = GHC.Types.Module $trModule $trModule
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- 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}]
lvl = GHC.Types.I# 0#
-- RHS size: {terms: 39, types: 17, coercions: 0, joins: 0/1}
@@ -269,8 +295,9 @@ $wg2 [InlPrag=NOINLINE, Dmd=LC(S,C(1,!P(M!P(L),1!P(L))))]
[LclId[StrictWorker([])],
Arity=2,
Str=<L><1L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 30] 76 20}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20 30] 76 20}]
$wg2
= \ (m :: Int) (ww [Dmd=1L] :: GHC.Prim.Int#) ->
case ww of ds [Dmd=ML] {
@@ -281,8 +308,9 @@ $wg2
let {
c1# :: GHC.Prim.Int#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 2 0}]
c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in
case GHC.Prim.-# (GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild) c1#
of ds2
@@ -297,8 +325,9 @@ $wg2
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
lvl :: Int
[LclId,
- 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}]
lvl = GHC.Types.I# 2#
-- RHS size: {terms: 36, types: 23, coercions: 0, joins: 0/0}
@@ -306,8 +335,9 @@ h2 :: Int -> Int
[LclIdX,
Arity=1,
Str=<1P(SL)>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 162 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [20] 162 10}]
h2
= \ (ds [Dmd=1P(SL)] :: Int) ->
case ds of wild { GHC.Types.I# ds [Dmd=SL] ->
@@ -333,8 +363,9 @@ $wg1 [InlPrag=NOINLINE, Dmd=LC(L,!P(L,L))]
[LclId[StrictWorker([])],
Arity=1,
Str=<1L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 56 20}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [30] 56 20}]
$wg1
= \ (ww [Dmd=1L] :: GHC.Prim.Int#) ->
case ww of ds {
@@ -345,8 +376,9 @@ $wg1
let {
c1# :: GHC.Prim.Int#
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}]
+ Unf=Unf{Src=<vanilla>, TopLvl=False,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 2 0}]
c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in
case GHC.Prim.-# (GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild) c1#
of ds2
@@ -361,17 +393,19 @@ $wg1
-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0}
lvl :: (Int, Int)
[LclId,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
- WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=False, ConLike=False, WorkFree=False, Expandable=False,
+ Guidance=IF_ARGS [] 50 10}]
lvl = case $wg1 2# of { (# ww, ww #) -> (GHC.Types.I# ww, ww) }
-- RHS size: {terms: 22, types: 16, coercions: 0, joins: 0/0}
-$wh1 [InlPrag=[2], Dmd=LC(S,!P(L))] :: GHC.Prim.Int# -> Int
+$wh1 [InlPrag=[2]] :: GHC.Prim.Int# -> Int
[LclId[StrictWorker([])],
Arity=1,
Str=<1L>,
- Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
- WorkFree=True, Expandable=True, Guidance=IF_ARGS [50] 91 10}]
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [50] 91 10}]
$wh1
= \ (ww [Dmd=1L] :: GHC.Prim.Int#) ->
case ww of ds [Dmd=ML] {
@@ -388,8 +422,8 @@ h1 [InlPrag=[2]] :: Int -> Int
[LclIdX,
Arity=1,
Str=<1!P(1L)>,
- Unf=Unf{Src=InlineStable, 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= \ (ds [Occ=Once1!, Dmd=S!P(SL)] :: Int) ->
case ds of { GHC.Types.I# ww [Occ=Once1, Dmd=SL] -> $wh1 ww }}]
=====================================
testsuite/tests/stranal/should_run/T23208.hs
=====================================
@@ -0,0 +1,4 @@
+import T23208_Lib
+
+main = print $ g (15 :: Int)
+
=====================================
testsuite/tests/stranal/should_run/T23208.stderr
=====================================
@@ -0,0 +1,3 @@
+T23208: really important message
+CallStack (from HasCallStack):
+ error, called at T23208_Lib.hs:4:7 in main:T23208_Lib
=====================================
testsuite/tests/stranal/should_run/T23208_Lib.hs
=====================================
@@ -0,0 +1,12 @@
+module T23208_Lib (g) where
+
+err :: Int -> b
+err = error "really important message"
+
+sg :: Int -> Int
+sg n = err n
+{-# NOINLINE sg #-}
+g :: a -> a
+g x = x
+{-# NOINLINE g #-}
+{-# RULES "g" g @Int = sg #-}
=====================================
testsuite/tests/stranal/should_run/all.T
=====================================
@@ -32,3 +32,4 @@ test('T22475', normal, compile_and_run, [''])
test('T22475b', normal, compile_and_run, [''])
# T22549: Do not strictify DFuns, otherwise we will <<loop>>
test('T22549', normal, compile_and_run, ['-fdicts-strict -fno-specialise'])
+test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14d53950b9314842b3665ea2d953334a27a6698d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/14d53950b9314842b3665ea2d953334a27a6698d
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/20230411/39c68a9b/attachment-0001.html>
More information about the ghc-commits
mailing list