[Git][ghc/ghc][wip/T23208] DmdAnal: Unleash demand signatures of free RULE and unfolding binders (#23208)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Mon Apr 24 15:03:09 UTC 2023
Sebastian Graf pushed to branch wip/T23208 at Glasgow Haskell Compiler / GHC
Commits:
5c30b235 by Sebastian Graf at 2023-04-24T16:59:55+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.
I took the chance to factor out the old notion of a `PlusDmdArg` (a pair of a
`VarEnv Demand` and a `Divergence`) into `DmdEnv`, which fits nicely into our
existing framework. As a result, I had to touch quite a few places in the code.
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.
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/CoreToStg/Prep.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,35 @@ 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] -> DmdEnv
+ -- 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 = plusDmdEnvs (map (demandRoot 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
+demandRoot :: AnalEnv -> Id -> DmdEnv
+-- See Note [Absence analysis for stable unfoldings and RULES]
+demandRoot env id = fst (dmdAnalStar env topDmd (Var id))
+
+demandRoots :: AnalEnv -> [Id] -> DmdEnv
+-- See Note [Absence analysis for stable unfoldings and RULES]
+demandRoots env roots = plusDmdEnvs (map (demandRoot env) roots)
+
+demandRootSet :: AnalEnv -> IdSet -> DmdEnv
+demandRootSet env ids = demandRoots 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 +350,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` demandRootSet env rule_fvs
-- | Let bindings can be processed in two ways:
-- Down (RHS before body) or Up (body before RHS).
@@ -360,18 +367,18 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec
dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a)
dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
NonRec id rhs
- | (env', lazy_fv, id1, rhs1) <-
+ | (env', weak_fv, id1, rhs1) <-
dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs
- -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only)
+ -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only)
Rec pairs
- | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs
- -> do_rest env' lazy_fv pairs' Rec
+ | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs
+ -> do_rest env' weak_fv pairs' Rec
where
- do_rest env' lazy_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')
+ do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')
where
WithDmdType body_ty body' = anal_body env'
-- see Note [Lazy and unleashable free variables]
- dmd_ty = addLazyFVs body_ty lazy_fv
+ dmd_ty = addWeakFVs body_ty weak_fv
WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1)
-- Important to force this as build_bind might not force it.
!pairs2 = strictZipWith do_one pairs1 id_dmds
@@ -408,14 +415,14 @@ anticipateANF e n
dmdAnalStar :: AnalEnv
-> Demand -- This one takes a *Demand*
-> CoreExpr
- -> (PlusDmdArg, CoreExpr)
+ -> (DmdEnv, CoreExpr)
dmdAnalStar env (n :* sd) e
-- NB: (:*) expands AbsDmd and BotDmd as needed
| WithDmdType dmd_ty e' <- dmdAnal env 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
@@ -428,13 +435,13 @@ dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit)
dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact
dmdAnal' _ _ (Coercion co)
- = WithDmdType (unitDmdType (coercionDmdEnv co)) (Coercion co)
+ = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co)
dmdAnal' env dmd (Var var)
= WithDmdType (dmdTransform env var dmd) (Var var)
dmdAnal' env dmd (Cast e co)
- = WithDmdType (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co)) (Cast e' co)
+ = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co)
where
WithDmdType dmd_ty e' = dmdAnal env dmd e
@@ -532,7 +539,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 +576,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
@@ -1030,7 +1037,7 @@ dmdTransform env var sd
-- * Case and constructor field binders
| otherwise
= -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $
- unitDmdType (unitVarEnv var (C_11 :* sd))
+ noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd))
{- *********************************************************************
* *
@@ -1038,6 +1045,10 @@ dmdTransform env var sd
* *
********************************************************************* -}
+-- | An environment in which all demands are weak according to 'isWeakDmd'.
+-- See Note [Lazy and unleashable free variables].
+type WeakDmds = VarEnv Demand
+
-- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature
-- for the LetDown rule. It works as follows:
--
@@ -1052,13 +1063,13 @@ dmdAnalRhsSig
-> RecFlag
-> AnalEnv -> SubDemand
-> Id -> CoreExpr
- -> (AnalEnv, DmdEnv, Id, CoreExpr)
+ -> (AnalEnv, WeakDmds, Id, CoreExpr)
-- Process the RHS of the binding, add the strictness signature
-- to the Id, and augment the environment with the signature as well.
-- See Note [NOINLINE and strictness]
dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
- = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $
- (final_env, lazy_fv, final_id, final_rhs)
+ = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $
+ (final_env, weak_fvs, final_id, final_rhs)
where
threshold_arity = thresholdArity id rhs
@@ -1076,11 +1087,11 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
= unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd
WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs
- DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
+ DmdType rhs_env rhs_dmds = rhs_dmd_ty
(final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity
- rhs_dmds rhs_div rhs'
+ rhs_dmds (de_div rhs_env) rhs'
- sig = mkDmdSigForArity threshold_arity (DmdType sig_fv final_rhs_dmds rhs_div)
+ sig = mkDmdSigForArity threshold_arity (DmdType sig_env final_rhs_dmds)
opts = ae_opts env
final_id = setIdDmdAndBoxSig opts id sig
@@ -1098,15 +1109,19 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
-- we'd have to do an additional iteration. reuseEnv makes sure that
-- we never get used-once info for FVs of recursive functions.
-- See #14816 where we try to get rid of reuseEnv.
- rhs_fv1 = case rec_flag of
- Recursive -> reuseEnv rhs_fv
- NonRecursive -> rhs_fv
+ rhs_env1 = case rec_flag of
+ Recursive -> reuseEnv rhs_env
+ NonRecursive -> rhs_env
-- See Note [Absence analysis for stable unfoldings and RULES]
- rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id
+ rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id)
-- See Note [Lazy and unleashable free variables]
- !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
+ !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2
+
+splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds)
+splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)
+ where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs
thresholdArity :: Id -> CoreExpr -> Arity
-- See Note [Demand signatures are computed for a threshold arity based on idArity]
@@ -1365,8 +1380,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 treat
+stable unfoldings as demanded. Consider
g = blah
@@ -1383,23 +1398,47 @@ 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.
-
-ALSO: do the same for Ids free in the RHS of any RULES for f.
+SOLUTION: if f has a stable unfolding, treat every free variable as a
+/demand root/, that is: Analyse it as if it was a variable occuring in a
+'topDmd' context. This is done in `demandRoot` (which we also use for exported
+top-level ids). Do the same for Ids free in the RHS of any RULES for f.
-PS: You may wonder how it can be that f's optimised RHS has somehow
-discarded 'g', but when f is inlined we /don't/ discard g in the same
-way. I think a simple example is
- g = (a,b)
- f = \x. fst g
- {-# INLINE f #-}
+Wrinkles:
-Now f's optimised RHS will be \x.a, but if we change g to (error "..")
-(since it is apparently Absent) and then inline (\x. fst g) we get
-disaster. But regardless, #18638 was a more complicated version of
-this, that actually happened in practice.
+ (W1) You may wonder how it can be that f's optimised RHS has somehow
+ discarded 'g', but when f is inlined we /don't/ discard g in the same
+ way. I think a simple example is
+ g = (a,b)
+ f = \x. fst g
+ {-# INLINE f #-}
+
+ Now f's optimised RHS will be \x.a, but if we change g to (error "..")
+ (since it is apparently Absent) and then inline (\x. fst g) we get
+ disaster. But regardless, #18638 was a more complicated version of
+ this, that actually happened in practice.
+
+ (W2) 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 demand transitive free
+ variables 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 demanded by `sg`'s demand signature: It doesn't occur
+ in the weak_fvs of `sg`'s RHS at all. Hence when we `demandRoots` `sg`
+ because it occurs in the RULEs of `g` (which is exported), we better unleash
+ the demand signature of `sg`, too! Before #23208 we simply added a 'topDmd'
+ for `sg`, failing to unleash the signature and hence observed an absent
+ error instead of the `really important message`.
Note [DmdAnal for DataCon wrappers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2101,8 +2140,7 @@ dmdFix :: TopLevelFlag
-> AnalEnv -- Does not include bindings for this binding
-> SubDemand
-> [(Id,CoreExpr)]
- -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info
-
+ -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info
dmdFix top_lvl env let_dmd orig_pairs
= loop 1 initial_pairs
where
@@ -2113,33 +2151,33 @@ dmdFix top_lvl env let_dmd orig_pairs
-- If fixed-point iteration does not yield a result we use this instead
-- See Note [Safe abortion in the fixed-point iteration]
- abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
- abort = (env, lazy_fv', zapped_pairs)
- where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs)
+ abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)])
+ abort = (env, weak_fv', zapped_pairs)
+ where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs)
-- Note [Lazy and unleashable free variables]
- non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs'
- lazy_fv' = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
+ weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs'
+ weak_fv' = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs
zapped_pairs = zapIdDmdSig pairs'
-- The fixed-point varies the idDmdSig field of the binders, and terminates if that
-- annotation does not change any more.
- loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+ loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)])
loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)
-- | (id,_) <- pairs]) $
loop' n pairs
loop' n pairs
- | found_fixpoint = (final_anal_env, lazy_fv, pairs')
+ | found_fixpoint = (final_anal_env, weak_fv, pairs')
| n == 10 = abort
| otherwise = loop (n+1) pairs'
where
found_fixpoint = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs
first_round = n == 1
- (lazy_fv, pairs') = step first_round pairs
+ (weak_fv, pairs') = step first_round pairs
final_anal_env = extendAnalEnvs top_lvl env (map fst pairs')
- step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
- step first_round pairs = (lazy_fv, pairs')
+ step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)])
+ step first_round pairs = (weak_fv, pairs')
where
-- In all but the first iteration, delete the virgin flag
start_env | first_round = env
@@ -2147,17 +2185,17 @@ dmdFix top_lvl env let_dmd orig_pairs
start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv)
- !((_,!lazy_fv), !pairs') = mapAccumL my_downRhs start pairs
+ !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs
-- mapAccumL: Use the new signature to do the next pair
-- The occurrence analyser has arranged them in a good order
-- so this can significantly reduce the number of iterations needed
- my_downRhs (env, lazy_fv) (id,rhs)
+ my_downRhs (env, weak_fv) (id,rhs)
= -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $
- ((env', lazy_fv'), (id', rhs'))
+ ((env', weak_fv'), (id', rhs'))
where
- !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs
- !lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1
+ !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs
+ !weak_fv' = plusVarEnv_C plusDmd weak_fv weak_fv1
zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ]
@@ -2231,23 +2269,24 @@ convenient to do it there.
* *
********************************************************************* -}
-unitDmdType :: DmdEnv -> DmdType
-unitDmdType dmd_env = DmdType dmd_env [] topDiv
+noArgsDmdType :: DmdEnv -> DmdType
+noArgsDmdType dmd_env = DmdType dmd_env []
coercionDmdEnv :: Coercion -> DmdEnv
coercionDmdEnv co = coercionsDmdEnv [co]
coercionsDmdEnv :: [Coercion] -> DmdEnv
-coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos)
- -- The VarSet from coVarsOfCos is really a VarEnv Var
+coercionsDmdEnv cos
+ = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos
+ -- The VarSet from coVarsOfCos is really a VarEnv Var
addVarDmd :: DmdType -> Var -> Demand -> DmdType
-addVarDmd (DmdType fv ds res) var dmd
- = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res
+addVarDmd (DmdType fv ds) var dmd
+ = DmdType (addVarDmdEnv fv var dmd) ds
-addLazyFVs :: DmdType -> DmdEnv -> DmdType
-addLazyFVs dmd_ty lazy_fvs
- = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs
+addWeakFVs :: DmdType -> WeakDmds -> DmdType
+addWeakFVs dmd_ty weak_fvs
+ = dmd_ty `plusDmdType` mkTermDmdEnv weak_fvs
-- Using plusDmdType (rather than just plus'ing the envs)
-- is vital. Consider
-- let f = \x -> (x,y)
@@ -2256,7 +2295,7 @@ addLazyFVs dmd_ty lazy_fvs
-- demand with the bottom coming up from 'error'
--
-- I got a loop in the fixpointer without this, due to an interaction
- -- with the lazy_fv filtering in dmdAnalRhsSig. Roughly, it was
+ -- with the weak_fv filtering in dmdAnalRhsSig. Roughly, it was
-- letrec f n x
-- = letrec g y = x `fatbar`
-- letrec h z = z + ...g...
@@ -2357,14 +2396,14 @@ DmdType.
But now the signature lies! (Missing variables are assumed to be absent.) To
make up for this, the code that analyses the binding keeps the demand on those
-variable separate (usually called "lazy_fv") and adds it to the demand of the
+variable separate (usually called "weak_fv") and adds it to the demand of the
whole binding later.
What if we decide _not_ to store a strictness signature for a binding at all, as
we do when aborting a fixed-point iteration? The we risk losing the information
that the strict variables are being used. In that case, we take all free variables
mentioned in the (unsound) strictness signature, conservatively approximate the
-demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".
+demand put on them (topDmd), and add that to the "weak_fv" returned by "dmdFix".
************************************************************************
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -2096,15 +2096,16 @@ calcSpecInfo :: Id -- The original function
calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
= ( spec_lam_bndrs_w_dmds
, spec_call_args
- , mkClosedDmdSig [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b] div )
+ , zapDmdEnvSig (DmdSig (dt{dt_args = spec_fn_dmds})) )
where
- DmdSig (DmdType _ fn_dmds div) = idDmdSig fn
+ DmdSig dt at DmdType{dt_args=fn_dmds} = idDmdSig fn
+ spec_fn_dmds = [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b]
val_pats = filterOut isTypeArg pats
-- Value args at call sites, used to determine how many demands to drop
- -- from the original functions demand and for setting up dmd_env.
- dmd_env = go emptyVarEnv fn_dmds val_pats
- qvar_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
+ -- from the original functions demand and for setting up arg_dmd_env.
+ arg_dmd_env = go emptyVarEnv fn_dmds val_pats
+ qvar_dmds = [ lookupVarEnv arg_dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
extra_dmds = dropList val_pats fn_dmds
-- Annotate the variables with the strictness information from
@@ -2128,12 +2129,12 @@ calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
set_dmds (v:vs) ds@(d:ds') | isTyVar v = v : set_dmds vs ds
| otherwise = setIdDemandInfo v d : set_dmds vs ds'
- go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv
+ go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand
-- We've filtered out all the type patterns already
go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats
go env _ _ = env
- go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
+ go_one :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand
go_one env d (Var v) = extendVarEnv_C plusDmd env v d
go_one env (_n :* cd) e -- NB: _n does not have to be strict
| (Var _, args) <- collectArgs e
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -1111,7 +1111,7 @@ cpeApp top_env expr
where
depth = val_args args
stricts = case idDmdSig v of
- DmdSig (DmdType _ demands _)
+ DmdSig (DmdType _ demands)
| listLengthCmp demands depth /= GT -> demands
-- length demands <= depth
| otherwise -> []
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -43,23 +43,20 @@ module GHC.Types.Demand (
-- ** Manipulating Boxity of a Demand
unboxDeeplyDmd,
- -- * Demand environments
- DmdEnv, emptyDmdEnv,
- keepAliveDmdEnv, reuseEnv,
-
-- * Divergence
Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv,
+ -- * Demand environments
+ DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs,
+ reuseEnv,
+
-- * Demand types
DmdType(..), dmdTypeDepth,
-- ** Algebra
nopDmdType, botDmdType,
- lubDmdType, plusDmdType, multDmdType,
- -- *** PlusDmdArg
- PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,
+ lubDmdType, plusDmdType, multDmdType, discardArgDmds,
-- ** Other operations
peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,
- keepAliveDmdType,
-- * Demand signatures
DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig,
@@ -85,9 +82,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 )
@@ -1054,7 +1050,7 @@ mkWorkerDemand n = C_01 :* go n
argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]]
-- ^ See Note [Computing one-shot info]
-argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args
+argsOneShots (DmdSig (DmdType _ arg_ds)) n_val_args
| unsaturated_call = []
| otherwise = go arg_ds
where
@@ -1466,7 +1462,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
@@ -1737,112 +1733,131 @@ a consequence of fixed-point iteration, it's not important that they agree.
-}
-- Subject to Note [Default demand on free variables and arguments]
-type DmdEnv = VarEnv Demand
+-- | Captures the result of an evaluation of an expression, by
+--
+-- * Listing how the free variables of that expression have been evaluted
+-- ('de_fvs')
+-- * Saying whether or not evaluation would surely diverge ('de_div')
+--
+-- See Note [Demand env Equality].
+data DmdEnv = DE { de_fvs :: !(VarEnv Demand), de_div :: !Divergence }
+
+instance Eq DmdEnv where
+ DE fv1 div1 == DE fv2 div2
+ = div1 == div2 && canonicalise div1 fv1 == canonicalise div2 fv2
+ where
+ canonicalise div fv = filterUFM (/= defaultFvDmd div) fv
+
+mkEmptyDmdEnv :: Divergence -> DmdEnv
+mkEmptyDmdEnv div = DE emptyVarEnv div
+
+-- | Build a potentially terminating 'DmdEnv' from a finite map that says what
+-- has been evaluated so far
+mkTermDmdEnv :: VarEnv Demand -> DmdEnv
+mkTermDmdEnv fvs = DE fvs topDiv
+
+nopDmdEnv :: DmdEnv
+nopDmdEnv = mkEmptyDmdEnv topDiv
-emptyDmdEnv :: DmdEnv
-emptyDmdEnv = emptyVarEnv
+botDmdEnv :: DmdEnv
+botDmdEnv = mkEmptyDmdEnv botDiv
+
+exnDmdEnv :: DmdEnv
+exnDmdEnv = mkEmptyDmdEnv exnDiv
+
+lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
+lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div
+ where
+ -- See Note [Demand env Equality]
+ lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)
+ lub_div = lubDivergence d1 d2
+
+addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv
+addVarDmdEnv env@(DE fvs div) id dmd
+ = DE (extendVarEnv fvs id (dmd `plusDmd` lookupDmdEnv env id)) div
+
+plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv
+plusDmdEnv (DE fv1 d1) (DE fv2 d2)
+ -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric.
+ | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd
+ = DE fv1 (d1 `plusDivergence` d2) -- a very common case that is much more efficient
+ | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd
+ = DE fv2 (d1 `plusDivergence` d2) -- another very common case that is much more efficient
+ | otherwise
+ = DE (plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2))
+ (d1 `plusDivergence` d2)
+
+-- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum'
+plusDmdEnvs :: [DmdEnv] -> DmdEnv
+plusDmdEnvs [] = nopDmdEnv
+plusDmdEnvs pdas = foldl1' plusDmdEnv pdas
multDmdEnv :: Card -> DmdEnv -> DmdEnv
-multDmdEnv C_11 env = env
-multDmdEnv C_00 _ = emptyDmdEnv
-multDmdEnv n env = mapVarEnv (multDmd n) env
+multDmdEnv C_11 env = env
+multDmdEnv C_00 _ = nopDmdEnv
+multDmdEnv n (DE fvs div) = DE (mapVarEnv (multDmd n) fvs) (multDivergence n div)
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
+lookupDmdEnv :: DmdEnv -> Id -> Demand
+-- See Note [Default demand on free variables and arguments]
+lookupDmdEnv (DE fv div) id = lookupVarEnv fv id `orElse` defaultFvDmd div
- 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
+delDmdEnv :: DmdEnv -> Id -> DmdEnv
+delDmdEnv (DE fv div) id = DE (fv `delVarEnv` id) div
-- | Characterises how an expression
--
--- * Evaluates its free variables ('dt_env')
+-- * Evaluates its free variables ('dt_env') including divergence info
-- * Evaluates its arguments ('dt_args')
--- * Diverges on every code path or not ('dt_div')
--
--- Equality is defined modulo 'defaultFvDmd's in 'dt_env'.
--- See Note [Demand type Equality].
data DmdType
= DmdType
- { dt_env :: !DmdEnv -- ^ Demand on explicitly-mentioned free variables
+ { dt_env :: !DmdEnv -- ^ Demands on free variables.
+ -- See Note [Demand type Divergence]
, dt_args :: ![Demand] -- ^ Demand on arguments
- , dt_div :: !Divergence -- ^ Whether evaluation diverges.
- -- See Note [Demand type Divergence]
}
--- | See Note [Demand type Equality].
+-- | See Note [Demand env Equality].
instance Eq DmdType where
- (==) (DmdType fv1 ds1 div1)
- (DmdType fv2 ds2 div2) = div1 == div2 && ds1 == ds2 -- cheap checks first
- && canonicalise div1 fv1 == canonicalise div2 fv2
- where
- canonicalise div fv = filterUFM (/= defaultFvDmd div) fv
+ DmdType env1 ds1 == DmdType env2 ds2
+ = ds1 == ds2 -- cheap checks first
+ && env1 == env2
-- | Compute the least upper bound of two 'DmdType's elicited /by the same
-- incoming demand/!
lubDmdType :: DmdType -> DmdType -> DmdType
-lubDmdType d1 d2
- = DmdType lub_fv lub_ds lub_div
+lubDmdType d1 d2 = DmdType lub_fv lub_ds
where
n = max (dmdTypeDepth d1) (dmdTypeDepth d2)
- (DmdType fv1 ds1 r1) = etaExpandDmdType n d1
- (DmdType fv2 ds2 r2) = etaExpandDmdType n d2
-
- -- See Note [Demand type Equality]
- lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2)
+ (DmdType fv1 ds1) = etaExpandDmdType n d1
+ (DmdType fv2 ds2) = etaExpandDmdType n d2
lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2
- lub_div = lubDivergence r1 r2
-
-type PlusDmdArg = (DmdEnv, Divergence)
+ lub_fv = lubDmdEnv fv1 fv2
-mkPlusDmdArg :: DmdEnv -> PlusDmdArg
-mkPlusDmdArg env = (env, topDiv)
+discardArgDmds :: DmdType -> DmdEnv
+discardArgDmds (DmdType fv _) = fv
-toPlusDmdArg :: DmdType -> PlusDmdArg
-toPlusDmdArg (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
- | otherwise
- = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))
- ds1
- (r1 `plusDivergence` t2)
+plusDmdType :: DmdType -> DmdEnv -> DmdType
+plusDmdType (DmdType fv ds) fv'
+ -- See Note [Asymmetry of plusDmdType]
+ -- 'DmdEnv' forms a (monoidal) action on 'DmdType' via this operation.
+ = DmdType (plusDmdEnv fv fv') ds
botDmdType :: DmdType
-botDmdType = DmdType emptyDmdEnv [] botDiv
+botDmdType = DmdType botDmdEnv []
-- | The demand type of doing nothing (lazy, absent, no Divergence
-- information). Note that it is ''not'' the top of the lattice (which would be
-- "may use everything"), so it is (no longer) called topDmdType.
nopDmdType :: DmdType
-nopDmdType = DmdType emptyDmdEnv [] topDiv
-
-isNopDmdType :: DmdType -> Bool
-isNopDmdType (DmdType env args div)
- = div == topDiv && null args && isEmptyVarEnv env
+nopDmdType = DmdType nopDmdEnv []
-- | The demand type of an unspecified expression that is guaranteed to
-- throw a (precise or imprecise) exception or diverge.
exnDmdType :: DmdType
-exnDmdType = DmdType emptyDmdEnv [] exnDiv
+exnDmdType = DmdType exnDmdEnv []
dmdTypeDepth :: DmdType -> Arity
dmdTypeDepth = length . dt_args
@@ -1851,7 +1866,7 @@ dmdTypeDepth = length . dt_args
-- expansion, where n must not be lower than the demand types depth.
-- It appends the argument list with the correct 'defaultArgDmd'.
etaExpandDmdType :: Arity -> DmdType -> DmdType
-etaExpandDmdType n d at DmdType{dt_args = ds, dt_div = div}
+etaExpandDmdType n d at DmdType{dt_args = ds, dt_env = env}
| n == depth = d
| n > depth = d{dt_args = inc_ds}
| otherwise = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d)
@@ -1863,7 +1878,7 @@ etaExpandDmdType n d at DmdType{dt_args = ds, dt_div = div}
-- * Divergence is still valid:
-- - A dead end after 2 arguments stays a dead end after 3 arguments
-- - The remaining case is Dunno, which is already topDiv
- inc_ds = take n (ds ++ repeat (defaultArgDmd div))
+ inc_ds = take n (ds ++ repeat (defaultArgDmd (de_div env)))
-- | A conservative approximation for a given 'DmdType' in case of an arity
-- decrease. Currently, it's just nopDmdType.
@@ -1875,30 +1890,27 @@ splitDmdTy :: DmdType -> (Demand, DmdType)
-- We already have a suitable demand on all
-- free vars, so no need to add more!
splitDmdTy ty at DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args})
-splitDmdTy ty at DmdType{dt_div=div} = (defaultArgDmd div, ty)
+splitDmdTy ty at DmdType{dt_env=env} = (defaultArgDmd (de_div env), ty)
multDmdType :: Card -> DmdType -> DmdType
-multDmdType n (DmdType fv args res_ty)
+multDmdType n (DmdType fv args)
= -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $
DmdType (multDmdEnv n fv)
(map (multDmd n) args)
- (multDivergence n res_ty)
peelFV :: DmdType -> Var -> (DmdType, Demand)
-peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
- (DmdType fv' ds res, dmd)
+peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)
+ (DmdType fv' ds, dmd)
where
-- Force these arguments so that old `Env` is not retained.
- !fv' = fv `delVarEnv` id
- -- See Note [Default demand on free variables and arguments]
- !dmd = lookupVarEnv fv id `orElse` defaultFvDmd res
+ !fv' = fv `delDmdEnv` id
+ !dmd = lookupDmdEnv fv id
addDemand :: Demand -> DmdType -> DmdType
-addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res
+addDemand dmd (DmdType fv ds) = DmdType fv (dmd:ds)
findIdDemand :: DmdType -> Var -> Demand
-findIdDemand (DmdType fv _ res) id
- = lookupVarEnv fv id `orElse` defaultFvDmd res
+findIdDemand (DmdType fv _) id = lookupDmdEnv fv id
-- | When e is evaluated after executing an IO action that may throw a precise
-- exception, we act as if there is an additional control flow path that is
@@ -1914,11 +1926,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]
@@ -1974,32 +1981,25 @@ on err via the App rule. In contrast to weaker head strictness, this demand is
strong enough to unleash err's signature and hence we see that the whole
expression diverges!
-Note [Demand type Equality]
+Note [Demand env Equality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What is the difference between the DmdType <L>{x->A} and <L>?
+What is the difference between the Demand env {x->A} and {}?
Answer: There is none! They have the exact same semantics, because any var that
-is not mentioned in 'dt_env' implicitly has demand 'defaultFvDmd', based on
-the divergence of the demand type 'dt_div'.
-Similarly, <B>b{x->B, y->A} is the same as <B>b{y->A}, because the default FV
-demand of BotDiv is B. But neither is equal to <B>b, because y has demand B in
+is not mentioned in 'de_fvs' implicitly has demand 'defaultFvDmd', based on
+the divergence of the demand env 'de_div'.
+Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV
+demand of BotDiv is B. But neither is equal to b{}, because y has demand B in
the latter, not A as before.
-NB: 'dt_env' technically can't stand for its own, because it doesn't tell us the
-demand on FVs that don't appear in the DmdEnv. Hence 'PlusDmdArg' carries along
-a 'Divergence', for example.
-
-The Eq instance of DmdType must reflect that, otherwise we can get into monotonicity
-issues during fixed-point iteration (<L>{x->A} /= <L> /= <L>{x->A} /= ...).
-It does so by filtering out any default FV demands prior to comparing 'dt_env'.
-An alternative would be to maintain an invariant that there are no default FV demands
-in 'dt_env' to begin with, but that seems more involved to maintain in the current
-implementation.
+The Eq instance of DmdEnv must reflect that, otherwise we can get into monotonicity
+issues during fixed-point iteration ({x->A} /= {} /= {x->A} /= ...).
+It does so by filtering out any default FV demands prior to comparing 'de_fvs'.
-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
+Note that 'lubDmdEnv' maintains this kind of equality by using 'plusVarEnv_CD',
+involving 'defaultFvDmd' for any entries present in one 'de_fvs' 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
@@ -2155,24 +2155,24 @@ newtype DmdSig
-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig'
-- unleashable at that arity. See Note [Understanding DmdType and DmdSig].
mkDmdSigForArity :: Arity -> DmdType -> DmdSig
-mkDmdSigForArity arity dmd_ty@(DmdType fvs args div)
- | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div
+mkDmdSigForArity arity dmd_ty@(DmdType fvs args)
+ | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args)
| otherwise = DmdSig (etaExpandDmdType arity dmd_ty)
mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig
-mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res)
+mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds)
mkVanillaDmdSig :: Arity -> Divergence -> DmdSig
mkVanillaDmdSig ar div = mkClosedDmdSig (replicate ar topDmd) div
splitDmdSig :: DmdSig -> ([Demand], Divergence)
-splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res)
+splitDmdSig (DmdSig (DmdType env dmds)) = (dmds, de_div env)
dmdSigDmdEnv :: DmdSig -> DmdEnv
-dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env
+dmdSigDmdEnv (DmdSig (DmdType env _)) = env
hasDemandEnvSig :: DmdSig -> Bool
-hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv
+hasDemandEnvSig = not . isEmptyVarEnv . de_fvs . dmdSigDmdEnv
botSig :: DmdSig
botSig = DmdSig botDmdType
@@ -2181,23 +2181,23 @@ nopSig :: DmdSig
nopSig = DmdSig nopDmdType
isNopSig :: DmdSig -> Bool
-isNopSig (DmdSig ty) = isNopDmdType ty
+isNopSig (DmdSig ty) = ty == nopDmdType
-- | True if the signature diverges or throws an exception in a saturated call.
-- See Note [Dead ends].
isDeadEndSig :: DmdSig -> Bool
-isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res
+isDeadEndSig (DmdSig (DmdType env _)) = isDeadEndDiv (de_div env)
-- | True if the signature diverges or throws an imprecise exception in a saturated call.
-- NB: In constrast to 'isDeadEndSig' this returns False for 'exnDiv'.
-- See Note [Dead ends]
-- and Note [Precise vs imprecise exceptions].
isBottomingSig :: DmdSig -> Bool
-isBottomingSig (DmdSig (DmdType _ _ res)) = res == botDiv
+isBottomingSig (DmdSig (DmdType env _)) = de_div env == botDiv
-- | True when the signature indicates all arguments are boxed
onlyBoxedArguments :: DmdSig -> Bool
-onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds
+onlyBoxedArguments (DmdSig (DmdType _ dmds)) = all demandIsBoxed dmds
where
demandIsBoxed BotDmd = True
demandIsBoxed AbsDmd = True
@@ -2217,12 +2217,15 @@ onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds
-- Hence this function conservatively returns False in that case.
-- See Note [Dead ends].
isDeadEndAppSig :: DmdSig -> Int -> Bool
-isDeadEndAppSig (DmdSig (DmdType _ ds res)) n
- = isDeadEndDiv res && not (lengthExceeds ds n)
+isDeadEndAppSig (DmdSig (DmdType env ds)) n
+ = isDeadEndDiv (de_div env) && not (lengthExceeds ds n)
+
+trimBoxityDmdEnv :: DmdEnv -> DmdEnv
+trimBoxityDmdEnv (DE fvs div) = DE (mapVarEnv trimBoxity fvs) div
trimBoxityDmdType :: DmdType -> DmdType
-trimBoxityDmdType (DmdType fvs ds res) =
- DmdType (mapVarEnv trimBoxity fvs) (map trimBoxity ds) res
+trimBoxityDmdType (DmdType env ds) =
+ DmdType (trimBoxityDmdEnv env) (map trimBoxity ds)
trimBoxityDmdSig :: DmdSig -> DmdSig
trimBoxityDmdSig = coerce trimBoxityDmdType
@@ -2247,12 +2250,11 @@ transferBoxity from to = go_dmd from to
_ -> trimBoxity to_dmd
transferArgBoxityDmdType :: DmdType -> DmdType -> DmdType
-transferArgBoxityDmdType _from@(DmdType _ from_ds _) to@(DmdType to_fvs to_ds to_res)
+transferArgBoxityDmdType _from@(DmdType _ from_ds) to@(DmdType to_env to_ds)
| equalLength from_ds to_ds
= -- pprTraceWith "transfer" (\r -> ppr _from $$ ppr to $$ ppr r) $
- DmdType to_fvs -- Only arg boxity! See Note [Don't change boxity without worker/wrapper]
+ DmdType to_env -- Only arg boxity! See Note [Don't change boxity without worker/wrapper]
(zipWith transferBoxity from_ds to_ds)
- to_res
| otherwise
= trimBoxityDmdType to
@@ -2263,10 +2265,10 @@ prependArgsDmdSig :: Int -> DmdSig -> DmdSig
-- ^ Add extra ('topDmd') arguments to a strictness signature.
-- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument
-- demands. This is used by FloatOut.
-prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res))
- | new_args == 0 = sig
- | isNopDmdType dmd_ty = sig
- | otherwise = DmdSig (DmdType env dmds' res)
+prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds))
+ | new_args == 0 = sig
+ | dmd_ty == nopDmdType = sig
+ | otherwise = DmdSig (DmdType env dmds')
where
dmds' = assertPpr (new_args > 0) (ppr new_args) $
replicate new_args topDmd ++ dmds
@@ -2308,7 +2310,7 @@ type DmdTransformer = SubDemand -> DmdType
-- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context,
-- return how the function evaluates its free variables and arguments.
dmdTransformSig :: DmdSig -> DmdTransformer
-dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd
+dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd
= multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty
-- see Note [Demands from unsaturated function calls]
-- and Note [What are demand signatures?]
@@ -2323,7 +2325,7 @@ dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of
where
arity = length str_marks
(n, body_sd) = peelManyCalls arity sd
- mk_body_ty n dmds = DmdType emptyDmdEnv (zipWith (bump n) str_marks dmds) topDiv
+ mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds)
bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd)
| otherwise = multDmd n dmd
str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness]
@@ -2334,11 +2336,11 @@ dmdTransformDataConSig str_marks sd = case viewProd arity body_sd of
dmdTransformDictSelSig :: DmdSig -> DmdTransformer
-- NB: This currently doesn't handle newtype dictionaries.
-- It should simply apply call_sd directly to the dictionary, I suppose.
-dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod] _)) call_sd
+dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod])) call_sd
| (n, sd') <- peelCallDmd call_sd
, Prod _ sig_ds <- prod
= multDmdType n $
- DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv
+ DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)]
| otherwise
= nopDmdType -- See Note [Demand transformer for a dictionary selector]
where
@@ -2460,9 +2462,12 @@ This is weird, so I'm not worried about whether this optimises brilliantly; but
it should not fall over.
-}
+zapDmdEnv :: DmdEnv -> DmdEnv
+zapDmdEnv (DE _ div) = mkEmptyDmdEnv div
+
-- | Remove the demand environment from the signature.
zapDmdEnvSig :: DmdSig -> DmdSig
-zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r
+zapDmdEnvSig (DmdSig (DmdType env ds)) = DmdSig (DmdType (zapDmdEnv env) ds)
zapUsageDemand :: Demand -> Demand
-- Remove the usage info, but not the strictness info, from the demand
@@ -2483,8 +2488,8 @@ zapUsedOnceDemand = kill_usage $ KillFlags
-- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness
-- signature
zapUsedOnceSig :: DmdSig -> DmdSig
-zapUsedOnceSig (DmdSig (DmdType env ds r))
- = DmdSig (DmdType env (map zapUsedOnceDemand ds) r)
+zapUsedOnceSig (DmdSig (DmdType env ds))
+ = DmdSig (DmdType env (map zapUsedOnceDemand ds))
data KillFlags = KillFlags
{ kf_abs :: Bool
@@ -2569,11 +2574,11 @@ seqDemandList :: [Demand] -> ()
seqDemandList = foldr (seq . seqDemand) ()
seqDmdType :: DmdType -> ()
-seqDmdType (DmdType env ds res) =
- seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()
+seqDmdType (DmdType env ds) =
+ seqDmdEnv env `seq` seqDemandList ds `seq` ()
seqDmdEnv :: DmdEnv -> ()
-seqDmdEnv env = seqEltsUFM seqDemand env
+seqDmdEnv (DE fvs _) = seqEltsUFM seqDemand fvs
seqDmdSig :: DmdSig -> ()
seqDmdSig (DmdSig ty) = seqDmdType ty
@@ -2682,17 +2687,20 @@ instance Outputable Divergence where
ppr ExnOrDiv = char 'x' -- for e(x)ception
ppr Dunno = empty
-instance Outputable DmdType where
- ppr (DmdType fv ds res)
- = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res,
- if null fv_elts then empty
- else braces (fsep (map pp_elt fv_elts))]
+instance Outputable DmdEnv where
+ ppr (DE fvs div)
+ = ppr div <> if null fv_elts then empty
+ else braces (fsep (map pp_elt fv_elts))
where
pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd
- fv_elts = nonDetUFMToList fv
+ fv_elts = nonDetUFMToList fvs
-- It's OK to use nonDetUFMToList here because we only do it for
-- pretty printing
+instance Outputable DmdType where
+ ppr (DmdType fv ds)
+ = hcat (map (angleBrackets . ppr) ds) <> ppr fv
+
instance Outputable DmdSig where
ppr (DmdSig ty) = ppr ty
@@ -2741,15 +2749,6 @@ instance Binary SubDemand where
2 -> Prod <$> get bh <*> get bh
_ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int))
-instance Binary DmdSig where
- put_ bh (DmdSig aa) = put_ bh aa
- get bh = DmdSig <$> get bh
-
-instance Binary DmdType where
- -- Ignore DmdEnv when spitting out the DmdType
- put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr
- get bh = DmdType emptyDmdEnv <$> get bh <*> get bh
-
instance Binary Divergence where
put_ bh Dunno = putByte bh 0
put_ bh ExnOrDiv = putByte bh 1
@@ -2761,3 +2760,16 @@ instance Binary Divergence where
1 -> return ExnOrDiv
2 -> return Diverges
_ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int))
+
+instance Binary DmdEnv where
+ -- Ignore VarEnv when spitting out the DmdType
+ put_ bh (DE _ d) = put_ bh d
+ get bh = DE emptyVarEnv <$> get bh
+
+instance Binary DmdType where
+ put_ bh (DmdType fv ds) = put_ bh fv *> put_ bh ds
+ get bh = DmdType <$> get bh <*> get bh
+
+instance Binary DmdSig where
+ put_ bh (DmdSig aa) = put_ bh aa
+ get bh = DmdSig <$> get bh
=====================================
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/5c30b235f23a23d06374c5b7d647ad8979edc3ad
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c30b235f23a23d06374c5b7d647ad8979edc3ad
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/20230424/d64db183/attachment-0001.html>
More information about the ghc-commits
mailing list