diff options
| author | Sebastian Graf <sebastian.graf@kit.edu> | 2020-10-30 17:20:37 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-11-20 02:09:51 -0500 |
| commit | 0aec78b6c97cee58ba20bfcb959f1369b80c4e4c (patch) | |
| tree | 3e48861640dbeb7a9d7784f0f02c2bc564af50ec | |
| parent | 321d1bd8a79ab39c3c9e8697fffb0107c43f83cf (diff) | |
| download | haskell-0aec78b6c97cee58ba20bfcb959f1369b80c4e4c.tar.gz | |
Demand: Interleave usage and strictness demands (#18903)
As outlined in #18903, interleaving usage and strictness demands not
only means a more compact demand representation, but also allows us to
express demands that we weren't easily able to express before.
Call demands are *relative* in the sense that a call demand `Cn(cd)`
on `g` says "`g` is called `n` times. *Whenever `g` is called*, the
result is used according to `cd`". Example from #18903:
```hs
h :: Int -> Int
h m =
let g :: Int -> (Int,Int)
g 1 = (m, 0)
g n = (2 * n, 2 `div` n)
{-# NOINLINE g #-}
in case m of
1 -> 0
2 -> snd (g m)
_ -> uncurry (+) (g m)
```
Without the interleaved representation, we would just get `L` for the
strictness demand on `g`. Now we are able to express that whenever
`g` is called, its second component is used strictly in denoting `g`
by `1C1(P(1P(U),SP(U)))`. This would allow Nested CPR to unbox the
division, for example.
Fixes #18903.
While fixing regressions, I also discovered and fixed #18957.
Metric Decrease:
T13253-spj
70 files changed, 1812 insertions, 1822 deletions
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index 74abca2927..ecc71baa69 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -2283,7 +2283,7 @@ section "Exceptions" -- DEFAULT -> case ma of MVar a -> ... -- 0# -> maskAsyncExceptions# (\st -> case ma of MVar a -> ...) -- The outer case just decides whether to mask exceptions, but we don't want --- thereby to hide the strictness in 'ma'! Hence the use of strictApply1Dmd +-- thereby to hide the strictness in 'ma'! Hence the use of strictOnceApply1Dmd -- in mask and unmask. But catch really is lazy in its first argument, see -- #11555. So for IO actions 'ma' we often use a wrapper around it that is -- head-strict in 'ma': GHC.IO.catchException. @@ -2329,7 +2329,7 @@ primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv } + strictness = { \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2338,7 +2338,7 @@ primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv } + strictness = { \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv } out_of_line = True has_side_effects = True @@ -2346,7 +2346,7 @@ primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv } + strictness = { \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True @@ -2367,7 +2367,7 @@ primop AtomicallyOp "atomically#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #) ) -> State# RealWorld -> (# State# RealWorld, a #) with - strictness = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv } + strictness = { \ _arity -> mkClosedStrictSig [strictManyApply1Dmd,topDmd] topDiv } -- See Note [Strictness for mask/unmask/catch] out_of_line = True has_side_effects = True diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index b45ecc1bc5..cab2f3b701 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -319,7 +319,7 @@ cprAnalBind top_lvl env id rhs -- See Note [CPR for thunks] stays_thunk = is_thunk && not_strict is_thunk = not (exprIsHNF rhs) && not (isJoinId id) - not_strict = not (isStrictDmd (idDemandInfo id)) + not_strict = not (isStrUsedDmd (idDemandInfo id)) -- See Note [CPR for sum types] (_, ret_ty) = splitPiTys (idType id) not_a_prod = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty) diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index c8776d8788..4869fb1fa9 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -44,6 +44,8 @@ import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set +-- import GHC.Driver.Ppr + {- ************************************************************************ * * @@ -76,12 +78,12 @@ dmdAnalTopBind env (NonRec id rhs) = ( extendAnalEnv TopLevel env id sig , NonRec (setIdStrictness id sig) rhs') where - ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs + ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env topSubDmd id rhs dmdAnalTopBind env (Rec pairs) = (env', Rec pairs') where - (env', _, pairs') = dmdFix TopLevel env cleanEvalDmd pairs + (env', _, pairs') = dmdFix TopLevel env topSubDmd pairs -- We get two iterations automatically -- c.f. the NonRec case above @@ -143,21 +145,20 @@ dmdTransformThunkDmd e dmdAnalStar :: AnalEnv -> Demand -- This one takes a *Demand* -> CoreExpr -- Should obey the let/app invariant - -> (BothDmdArg, CoreExpr) -dmdAnalStar env dmd e - | (dmd_shell, cd) <- toCleanDmd dmd - , (dmd_ty, e') <- dmdAnal env cd e + -> (PlusDmdArg, CoreExpr) +dmdAnalStar env (n :* cd) e + | (dmd_ty, e') <- dmdAnal env cd e = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e ) -- The argument 'e' should satisfy the let/app invariant -- See Note [Analysing with absent demand] in GHC.Types.Demand - (postProcessDmdType dmd_shell dmd_ty, e') + (toPlusDmdArg $ multDmdType n dmd_ty, e') -- Main Demand Analsysis machinery dmdAnal, dmdAnal' :: AnalEnv - -> CleanDemand -- The main one takes a *CleanDemand* + -> SubDemand -- The main one takes a *SubDemand* -> CoreExpr -> (DmdType, CoreExpr) --- The CleanDemand is always strict and not absent +-- The SubDemand is always strict and not absent -- See Note [Ensure demand is strict] dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ @@ -172,7 +173,7 @@ dmdAnal' env dmd (Var var) = (dmdTransform env var dmd, Var var) dmdAnal' env dmd (Cast e co) - = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co) + = (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co), Cast e' co) where (dmd_ty, e') = dmdAnal env dmd e @@ -206,7 +207,7 @@ dmdAnal' env dmd (App fun arg) -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ]) - (res_ty `bothDmdType` arg_ty, App fun' arg') + (res_ty `plusDmdType` arg_ty, App fun' arg') dmdAnal' env dmd (Lam var body) | isTyVar var @@ -216,23 +217,35 @@ dmdAnal' env dmd (Lam var body) (body_ty, Lam var body') | otherwise - = let (body_dmd, defer_and_use) = peelCallDmd dmd + = let (n, body_dmd) = peelCallDmd dmd -- body_dmd: a demand to analyze the body (body_ty, body') = dmdAnal env body_dmd body (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var in - (postProcessUnsat defer_and_use lam_ty, Lam var' body') + (multDmdType n lam_ty, Lam var' body') -dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) - -- Only one alternative with a product constructor - | let tycon = dataConTyCon dc - , isJust (isDataProductTyCon_maybe tycon) +dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)]) + -- Only one alternative. + -- If it's a DataAlt, it should be a product constructor. + | is_non_sum_alt alt = let (rhs_ty, rhs') = dmdAnal env dmd rhs (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr - id_dmds = addCaseBndrDmd case_bndr_dmd dmds + -- Evaluation cardinality on the case binder is irrelevant and a no-op. + -- What matters is its nested sub-demand! + (_ :* case_bndr_sd) = case_bndr_dmd + -- Compute demand on the scrutinee + (bndrs', scrut_sd) + | DataAlt _ <- alt + , id_dmds <- addCaseBndrDmd case_bndr_sd dmds + -- See Note [Demand on scrutinee of a product case] + = (setBndrsDemandInfo bndrs id_dmds, mkProd id_dmds) + | otherwise + -- __DEFAULT and literal alts. Simply add demands and discard the + -- evaluation cardinality, as we evaluate the scrutinee exactly once. + = ASSERT( null bndrs ) (bndrs, case_bndr_sd) fam_envs = ae_fam_envs env alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" @@ -241,28 +254,26 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)]) | otherwise = alt_ty2 - -- Compute demand on the scrutinee - -- See Note [Demand on scrutinee of a product case] - scrut_dmd = mkProdDmd id_dmds - (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut - res_ty = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty + (scrut_ty, scrut') = dmdAnal env scrut_sd scrut + res_ty = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd - bndrs' = setBndrsDemandInfo bndrs id_dmds in -- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd -- , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr') --- , text "id_dmds" <+> ppr id_dmds --- , text "scrut_dmd" <+> ppr scrut_dmd +-- , text "scrut_sd" <+> ppr scrut_sd -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $ - (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')]) + (res_ty, Case scrut' case_bndr' ty [(alt, bndrs', rhs')]) + where + is_non_sum_alt (DataAlt dc) = isJust $ isDataProductTyCon_maybe $ dataConTyCon dc + is_non_sum_alt _ = True dmdAnal' env dmd (Case scrut case_bndr ty alts) = let -- Case expression with multiple alternatives - (alt_tys, alts') = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts - (scrut_ty, scrut') = dmdAnal env cleanEvalDmd scrut + (alt_tys, alts') = mapAndUnzip (dmdAnalSumAlt env dmd case_bndr) alts + (scrut_ty, scrut') = dmdAnal env topSubDmd scrut (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr -- NB: Base case is botDmdType, for empty case alternatives -- This is a unit for lubDmdType, and the right result @@ -274,7 +285,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts) = deferAfterPreciseException alt_ty | otherwise = alt_ty - res_ty = alt_ty2 `bothDmdType` toBothDmdArg scrut_ty + res_ty = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty in -- pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut @@ -304,7 +315,7 @@ dmdAnal' env dmd (Let (NonRec id rhs) body) id' = setIdDemandInfo id id_dmd (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs - final_ty = body_ty' `bothDmdType` rhs_ty + final_ty = body_ty' `plusDmdType` rhs_ty dmdAnal' env dmd (Let (NonRec id rhs) body) = (body_ty2, Let (NonRec id2 rhs') body') @@ -373,21 +384,77 @@ forcesRealWorld fam_envs ty | otherwise = False -dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var) -dmdAnalAlt env dmd case_bndr (con,bndrs,rhs) - | null bndrs -- Literals, DEFAULT, and nullary constructors - , (rhs_ty, rhs') <- dmdAnal env dmd rhs - = (rhs_ty, (con, [], rhs')) - - | otherwise -- Non-nullary data constructors - , (rhs_ty, rhs') <- dmdAnal env dmd rhs +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var) +dmdAnalSumAlt env dmd case_bndr (con,bndrs,rhs) + | (rhs_ty, rhs') <- dmdAnal env dmd rhs , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs - , let case_bndr_dmd = findIdDemand alt_ty case_bndr - id_dmds = addCaseBndrDmd case_bndr_dmd dmds + , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr + -- See Note [Demand on scrutinee of a product case] + id_dmds = addCaseBndrDmd case_bndr_sd dmds = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs')) -{- Note [Which scrutinees may throw precise exceptions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand A. The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by multDmdType. + +* In a previous incarnation of GHC we needed to be extra careful in the + case of an *unlifted type*, because unlifted values are evaluated + even if they are not used. Example (see #9254): + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- <CS(S(A,SU))> + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here f's strictness signature says (correctly) that it calls its + argument function and ignores the first component of its result. + This is correct in the sense that it'd be fine to (say) modify the + function so that always returned 0# in the first component. + + But in function g, we *will* evaluate the 'case y of ...', because + it has type Int#. So 'y' will be evaluated. So we must record this + usage of 'y', else 'g' will say 'y' is absent, and will w/w so that + 'y' is bound to an aBSENT_ERROR thunk. + + However, the argument of toSubDmd always satisfies the let/app + invariant; so if it is unlifted it is also okForSpeculation, and so + can be evaluated in a short finite time -- and that rules out nasty + cases like the one above. (I'm not quite sure why this was a + problem in an earlier version of GHC, but it isn't now.) + +Note [Always analyse in virgin pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tricky point: make sure that we analyse in the 'virgin' pass. Consider + rec { f acc x True = f (...rec { g y = ...g... }...) + f acc x False = acc } +In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. +That might mean that we analyse the sub-expression containing the +E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* +E, but just returned botType. + +Then in the *next* (non-virgin) iteration for 'f', we might analyse E +in a weaker demand, and that will trigger doing a fixpoint iteration +for g. But *because it's not the virgin pass* we won't start g's +iteration at bottom. Disaster. (This happened in $sfibToList' of +nofib/spectral/fibheaps.) + +So in the virgin pass we make sure that we do analyse the expression +at least once, to initialise its signatures. + +Note [Which scrutinees may throw precise exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This is the specification of 'exprMayThrowPreciseExceptions', which is important for Scenario 2 of Note [Precise exceptions and strictness analysis] in GHC.Types.Demand. @@ -438,6 +505,9 @@ and that'll crash. Note [Aggregated demand for cardinality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +FIXME: This Note should be named [LetUp vs. LetDown] and probably predates +said separation. SG + We use different strategies for strictness and usage/cardinality to "unleash" demands captured on free variables by bindings. Let us consider the example: @@ -484,13 +554,14 @@ strict in |y|. ************************************************************************ -} -dmdTransform :: AnalEnv -- The strictness environment - -> Id -- The function - -> CleanDemand -- The demand on the function - -> DmdType -- The demand type of the function in this context - -- Returned DmdEnv includes the demand on - -- this function plus demand on its free variables +dmdTransform :: AnalEnv -- ^ The strictness environment + -> Id -- ^ The function + -> SubDemand -- ^ The demand on the function + -> DmdType -- ^ The demand type of the function in this context + -- Returned DmdEnv includes the demand on + -- this function plus demand on its free variables +-- See Note [What are demand signatures?] in "GHC.Types.Demand" dmdTransform env var dmd -- Data constructors | isDataConWorkId var @@ -499,7 +570,8 @@ dmdTransform env var dmd -- Used to be controlled by a flag. -- See #18429 for some perf measurements. | Just _ <- isClassOpId_maybe var - = dmdTransformDictSelSig (idStrictness var) dmd + = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $ + dmdTransformDictSelSig (idStrictness var) dmd -- Imported functions | isGlobalId var , let res = dmdTransformSig (idStrictness var) dmd @@ -512,14 +584,14 @@ dmdTransform env var dmd = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $ if isTopLevel top_lvl then fn_ty -- Don't record demand on top-level things - else addVarDmd fn_ty var (mkOnceUsedDmd dmd) + else addVarDmd fn_ty var (C_11 :* dmd) -- Everything else: -- * Local let binders for which we use LetUp (cf. 'useLetUp') -- * Lambda binders -- * Case and constructor field binders | otherwise = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $ - unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd)) + unitDmdType (unitVarEnv var (C_11 :* dmd)) {- ********************************************************************* * * @@ -541,14 +613,15 @@ dmdTransform env var dmd -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”. dmdAnalRhsLetDown :: Maybe [Id] -- Just bs <=> recursive, Nothing <=> non-recursive - -> AnalEnv -> CleanDemand + -> AnalEnv -> SubDemand -> Id -> CoreExpr -> (DmdEnv, StrictSig, 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] dmdAnalRhsLetDown rec_flag env let_dmd id rhs - = (lazy_fv, sig, rhs') + = -- pprTrace "dmdAnalRhsLetDown" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $ + (lazy_fv, sig, rhs') where rhs_arity = idArity id rhs_dmd -- See Note [Demand analysis for join points] @@ -567,32 +640,41 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) -- See Note [Aggregated demand for cardinality] + -- FIXME: That Note doesn't explain the following lines at all. The reason + -- is really much different: When we have a recursive function, we'd + -- have to also consider the free vars of the strictness signature + -- when checking whether we found a fixed-point. That is expensive; + -- we only want to check whether argument demands of the sig changed. + -- reuseEnv makes it so that the FV results are stable as long as the + -- last argument demands were. Strictness won't change. But used-once + -- might turn into used-many even if the signature was stable and + -- we'd have to do an additional iteration. reuseEnv makes sure that + -- we never get used-once info for FVs of recursive functions. rhs_fv1 = case rec_flag of Just bs -> reuseEnv (delVarEnvList rhs_fv bs) Nothing -> rhs_fv rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs - - -- See Note [Lazy and unleashable free variables] - (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 - -- Find the RHS free vars of the unfoldings and RULES -- See Note [Absence analysis for stable unfoldings and RULES] extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $ idCoreRules id + -- See Note [Lazy and unleashable free variables] + (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 + unf = realIdUnfolding id unf_fvs | isStableUnfolding unf , Just unf_body <- maybeUnfoldingTemplate unf = exprFreeIds unf_body | otherwise = emptyVarSet --- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for +-- | @mkRhsDmd env rhs_arity rhs@ creates a 'SubDemand' for -- unleashing on the given function's @rhs@, by creating -- a call demand of @rhs_arity@ -- See Historical Note [Product demands for function body] -mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand -mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd +mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> SubDemand +mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity topSubDmd -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs @@ -694,12 +776,14 @@ behavior for when we have a call site with at least that many arguments. idArity is /at least/ the number of manifest lambdas, but might be higher for PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]). -Because idArity of a function varies independently of its cardinality properties -(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode -the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth' -(cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand). It is unsound to -unleash a demand signature when the incoming number of arguments is less than -that. See Note [What are demand signatures?] for more details on soundness. +Because idArity of a function varies independently of its cardinality +properties (cf. Note [idArity varies independently of dmdTypeDepth]), we +implicitly encode the arity for when a demand signature is sound to unleash +in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and StrictSig] in +GHC.Types.Demand). It is unsound to unleash a demand signature when the +incoming number of arguments is less than that. +See Note [What are demand signatures?] in GHC.Types.Demand for more details +on soundness. Why idArity arguments? Because that's a conservative estimate of how many arguments we must feed a function before it does anything interesting with them. @@ -759,57 +843,6 @@ coercion into the binding, leading to an arity decrease: With the CoreLint check, we would have to zap `go`'s perfectly viable strictness signature. -Note [What are demand signatures?] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Demand analysis interprets expressions in the abstract domain of demand -transformers. Given an incoming demand we put an expression under, its abstract -transformer gives us back a demand type denoting how other things (like -arguments and free vars) were used when the expression was evaluated. -Here's an example: - - f x y = - if x + expensive - then \z -> z + y * ... - else \z -> z * ... - -The abstract transformer (let's call it F_e) of the if expression (let's call it -e) would transform an incoming head demand <S,HU> into a demand type like -{x-><S,1*U>,y-><L,U>}<L,U>. In pictures: - - Demand ---F_e---> DmdType - <S,HU> {x-><S,1*U>,y-><L,U>}<L,U> - -Let's assume that the demand transformers we compute for an expression are -correct wrt. to some concrete semantics for Core. How do demand signatures fit -in? They are strange beasts, given that they come with strict rules when to -it's sound to unleash them. - -Fortunately, we can formalise the rules with Galois connections. Consider -f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of -the actual abstract transformer of f's RHS for arity 2. So, what happens is that -we abstract *once more* from the abstract domain we already are in, replacing -the incoming Demand by a simple lattice with two elements denoting incoming -arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom -element). Here's the diagram: - - A_2 -----f_f----> DmdType - ^ | - | α γ | - | v - Demand ---F_f---> DmdType - -With - α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness - α(_) = <2 - γ(ty) = ty -and F_f being the abstract transformer of f's RHS and f_f being the abstracted -abstract transformer computable from our demand signature simply by - - f_f(>=2) = {}<S,1*U><L,U> - f_f(<2) = postProcessUnsat {}<S,1*U><L,U> - -where postProcessUnsat makes a proper top element out of the given demand type. - Note [Demand analysis for trivial right-hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -899,7 +932,7 @@ deleted the special case. -- Recursive bindings dmdFix :: TopLevelFlag -> AnalEnv -- Does not include bindings for this binding - -> CleanDemand + -> SubDemand -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info @@ -954,10 +987,11 @@ dmdFix top_lvl env let_dmd orig_pairs -- so this can significantly reduce the number of iterations needed my_downRhs (env, lazy_fv) (id,rhs) - = ((env', lazy_fv'), (id', rhs')) + = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $ + ((env', lazy_fv'), (id', rhs')) where (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs - lazy_fv' = plusVarEnv_C bothDmd lazy_fv lazy_fv1 + lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1 env' = extendAnalEnv top_lvl env id sig id' = setIdStrictness id sig @@ -1043,11 +1077,11 @@ coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co) addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd (DmdType fv ds res) var dmd - = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res + = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res addLazyFVs :: DmdType -> DmdEnv -> DmdType addLazyFVs dmd_ty lazy_fvs - = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs + = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs -- Using bothDmdType (rather than just both'ing the envs) -- is vital. Consider -- let f = \x -> (x,y) @@ -1109,13 +1143,13 @@ annotateLamIdBndr env arg_of_dfun dmd_ty id -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) - -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $ + -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $ (final_ty, setIdDemandInfo id dmd) where -- Watch out! See note [Lambda-bound unfoldings] final_ty = case maybeUnfoldingTemplate (idUnfolding id) of Nothing -> main_ty - Just unf -> main_ty `bothDmdType` unf_ty + Just unf -> main_ty `plusDmdType` unf_ty where (unf_ty, _) = dmdAnalStar env dmd unf @@ -1314,7 +1348,8 @@ findBndrsDmds env dmd_ty bndrs findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) -- See Note [Trimming a demand to a type] findBndrDmd env arg_of_dfun dmd_ty id - = (dmd_ty', dmd') + = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $ + (dmd_ty', dmd') where dmd' = strictify $ trimToType starting_dmd (findTypeShape fam_envs id_ty) diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index f393255b54..a090bdfe62 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -67,7 +67,6 @@ import GHC.Types.Id.Info import GHC.Types.Basic import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Types.Demand import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import GHC.Types.Unique.FM import GHC.Types.Name.Ppr @@ -1096,6 +1095,6 @@ dmdAnal dflags fam_envs binds = do } binds_plus_dmds = dmdAnalProgram opts fam_envs binds Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ - dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds + dumpIdInfoOfProgram (ppr . strictnessInfo) binds_plus_dmds -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_dmds `seq` return binds_plus_dmds diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 0a4d4541f4..00d38f40cd 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -103,7 +103,7 @@ import GHC.Types.Unique.Set ( nonDetStrictFoldUniqSet ) import GHC.Types.Unique.DSet ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal ( litIsTrivial ) -import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, prependArgsStrictSig ) +import GHC.Types.Demand ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, prependArgsStrictSig ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Name ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) @@ -469,7 +469,7 @@ lvlApp env orig_expr ((_,AnnVar fn), args) lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr) lvl_arg strs arg | (str1 : strs') <- strs , is_val_arg arg - = do { arg' <- lvlMFE env (isStrictDmd str1) arg + = do { arg' <- lvlMFE env (isStrUsedDmd str1) arg ; return (strs', arg') } | otherwise = do { arg' <- lvlMFE env False arg diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index d72455c742..22d0bb47c0 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -41,7 +41,7 @@ import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) ) import GHC.Core import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey ) -import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd +import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrUsedDmd , mkClosedStrictSig, topDmd, seqDmd, isDeadEndDiv ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Core.Ppr ( pprCoreExpr ) @@ -2481,7 +2481,7 @@ There have been various earlier versions of this patch: scrut_is_demanded_var :: CoreExpr -> Bool scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s - scrut_is_demanded_var (Var _) = isStrictDmd (idDemandInfo case_bndr) + scrut_is_demanded_var (Var _) = isStrUsedDmd (idDemandInfo case_bndr) scrut_is_demanded_var _ = False This only fired if the scrutinee was a /variable/, which seems @@ -2709,7 +2709,7 @@ doCaseToLet scrut case_bndr | otherwise -- Scrut has a lifted type = exprIsHNF scrut - || isStrictDmd (idDemandInfo case_bndr) + || isStrUsedDmd (idDemandInfo case_bndr) -- See Note [Case-to-let for strictly-used binders] -------------------------------------------------- diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 6497abc091..8c25d7e171 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -329,7 +329,7 @@ addCastTo ai co = ai { ai_args = CastBy co : ai_args ai } isStrictArgInfo :: ArgInfo -> Bool -- True if the function is strict in the next argument isStrictArgInfo (ArgInfo { ai_dmds = dmds }) - | dmd:_ <- dmds = isStrictDmd dmd + | dmd:_ <- dmds = isStrUsedDmd dmd | otherwise = False argInfoAppArgs :: [ArgSpec] -> [OutExpr] @@ -582,7 +582,7 @@ mkArgInfo env fun rules n_val_args call_cont | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info , dmd : rest_dmds <- dmds , let dmd' = case isLiftedType_maybe arg_ty of - Just False -> strictenDmd dmd + Just False -> strictifyDmd dmd _ -> dmd = dmd' : add_type_strictness fun_ty' rest_dmds -- If the type is levity-polymorphic, we can't know whether it's diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index 4601407723..1abe9f7ab3 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1724,11 +1724,12 @@ calcSpecStrictness fn qvars pats go env _ _ = env go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv - go_one env d (Var v) = extendVarEnv_C bothDmd env v d - go_one env d e - | Just ds <- splitProdDmd_maybe d -- NB: d does not have to be strict - , (Var _, args) <- collectArgs e = go env ds args - go_one env _ _ = env + 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 + , Just ds <- viewProd (length args) cd + = go env ds args + go_one env _ _ = env {- Note [spec_usg includes rhs_usg] diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 99f3147ba1..70c99485de 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -610,7 +610,7 @@ wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataCon wantToUnbox fam_envs has_inlineable_prag ty dmd = case deepSplitProductType_maybe fam_envs ty of Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys } - | isStrictDmd dmd + | isStrUsedDmd dmd -- See Note [Unpacking arguments with product and polymorphic demands] , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys) -- See Note [Do not unpack class dictionaries] @@ -621,12 +621,11 @@ wantToUnbox fam_envs has_inlineable_prag ty dmd = _ -> Nothing where split_prod_dmd_arity dmd arty - -- For seqDmd, splitProdDmd_maybe will return Nothing (because how would - -- it know the arity?), but it should behave like <S, U(AAAA)>, for some + -- For seqDmd, it should behave like <S(AAAA)>, for some -- suitable arity - | isSeqDmd dmd = Just (replicate arty absDmd) - -- Otherwise splitProdDmd_maybe does the job - | otherwise = splitProdDmd_maybe dmd + | isSeqDmd dmd = Just (replicate arty absDmd) + | _ :* Prod ds <- dmd = Just ds + | otherwise = Nothing unbox_one :: DynFlags -> FamInstEnvs -> Var -> [Demand] diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index e0c7ef2521..ea59a84602 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -46,7 +46,7 @@ import GHC.Driver.Session import GHC.Platform.Ways import GHC.Driver.Ppr import GHC.Types.ForeignCall -import GHC.Types.Demand ( isUsedOnce ) +import GHC.Types.Demand ( isUsedOnceDmd ) import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import GHC.Builtin.Names ( unsafeEqualityProofName ) @@ -714,8 +714,8 @@ mkTopStgRhs dflags this_mod ccs bndr rhs where unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs - upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable + upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry + | otherwise = Updatable -- CAF cost centres generated for -fcaf-all caf_cc = mkAutoCC bndr modl @@ -756,8 +756,8 @@ mkStgRhs bndr rhs where unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs - upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable + upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry + | otherwise = Updatable {- SDM: disabled. Eval/Apply can't handle functions with arity zero very diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index f290ca9545..460f8ad9ea 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -1359,7 +1359,7 @@ mkFloat dmd is_unlifted bndr rhs -- See Note [Pin demand info on floats] where is_hnf = exprIsHNF rhs - is_strict = isStrictDmd dmd + is_strict = isStrUsedDmd dmd emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL @@ -1446,7 +1446,7 @@ canFloat (Floats ok_to_spec fs) rhs wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec dmd is_unlifted floats rhs = isEmptyFloats floats - || isStrictDmd dmd + || isStrUsedDmd dmd || is_unlifted || (allLazyNested is_rec floats && exprIsHNF rhs) -- Why the test for allLazyNested? diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index 27d64c88e5..b90c049c02 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -1465,7 +1465,7 @@ instance Outputable IfaceInfoItem where <> colon <+> ppr unf ppr (HsInline prag) = text "Inline:" <+> ppr prag ppr (HsArity arity) = text "Arity:" <+> int arity - ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str + ppr (HsStrictness str) = text "Strictness:" <+> ppr str ppr (HsCpr cpr) = text "CPR:" <+> ppr cpr ppr HsNoCafRefs = text "HasNoCafRefs" ppr HsLevity = text "Never levity-polymorphic" diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 645616fde6..def06c6102 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -95,7 +95,7 @@ import Data.Maybe ( mapMaybe ) -- -- * 'ClosureSk', representing closure allocation. -- * 'RhsSk', representing a RHS of a binding and how many times it's called --- by an appropriate 'DmdShell'. +-- by an appropriate 'Card'. -- * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element. -- -- This abstraction is mostly so that the main analysis function 'closureGrowth' @@ -124,7 +124,7 @@ freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs -- closures, multi-shot lambdas and case expressions. data Skeleton = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton - | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton + | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton | AltSk !Skeleton !Skeleton | BothSk !Skeleton !Skeleton | NilSk @@ -139,7 +139,7 @@ altSk NilSk b = b altSk a NilSk = a altSk a b = AltSk a b -rhsSk :: DmdShell -> Skeleton -> Skeleton +rhsSk :: Card -> Skeleton -> Skeleton rhsSk _ NilSk = NilSk rhsSk body_dmd skel = RhsSk body_dmd skel @@ -172,22 +172,12 @@ instance Outputable Skeleton where ] ppr (BothSk l r) = ppr l $$ ppr r ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body) - ppr (RhsSk body_dmd body) = hcat - [ text "λ[" - , ppr str - , text ", " - , ppr use - , text "]. " + ppr (RhsSk card body) = hcat + [ lambda + , ppr card + , dot , ppr body ] - where - str - | isStrictDmd body_dmd = '1' - | otherwise = '0' - use - | isAbsDmd body_dmd = '0' - | isUsedOnce body_dmd = '1' - | otherwise = 'ω' instance Outputable BinderInfo where ppr = ppr . binderInfoBndr @@ -333,19 +323,19 @@ tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body) where bndrs' = map BoringBinder bndrs (body_skel, body_arg_occs, body') = tagSkeletonExpr body - rhs_skel = rhsSk (rhsDmdShell bndr) body_skel + rhs_skel = rhsSk (rhsCard bndr) body_skel -- | How many times will the lambda body of the RHS bound to the given -- identifier be evaluated, relative to its defining context? This function --- computes the answer in form of a 'DmdShell'. -rhsDmdShell :: Id -> DmdShell -rhsDmdShell bndr - | is_thunk = oneifyDmd ds +-- computes the answer in form of a 'Card'. +rhsCard :: Id -> Card +rhsCard bndr + | is_thunk = oneifyCard n | otherwise = peelManyCalls (idArity bndr) cd where is_thunk = idArity bndr == 0 -- Let's pray idDemandInfo is still OK after unarise... - (ds, cd) = toCleanDmd (idDemandInfo bndr) + n :* cd = idDemandInfo bndr tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt) tagSkeletonAlt (con, bndrs, rhs) @@ -550,7 +540,7 @@ closureGrowth expander sizer group abs_ids = go -- Lifting @f@ removes @f@ from the closure but adds all @newbies@ cost = nonDetStrictFoldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs -- Using a non-deterministic fold is OK here because addition is commutative. - go (RhsSk body_dmd body) + go (RhsSk n body) -- The conservative assumption would be that -- 1. Every RHS with positive growth would be called multiple times, -- modulo thunks. @@ -561,11 +551,11 @@ closureGrowth expander sizer group abs_ids = go -- considering information from the demand analyser, which provides us -- with conservative estimates on minimum and maximum evaluation -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of - -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body + -- 'rhsCard' and accurately captures the cardinality of the RHSs body -- relative to its defining context. - | isAbsDmd body_dmd = 0 - | cg <= 0 = if isStrictDmd body_dmd then cg else 0 - | isUsedOnce body_dmd = cg - | otherwise = infinity + | isAbs n = 0 + | cg <= 0 = if isStrict n then cg else 0 + | isUsedOnce n = cg + | otherwise = infinity where cg = go body diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index f84e3c0bc2..2ebc2222b4 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -1,61 +1,80 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[Demand]{@Demand@: A decoupled implementation of a demand domain} -} +-- | A language to express the evaluation context of an expression as a +-- 'Demand' and track how an expression evaluates free variables and arguments +-- in turn as a 'DmdType'. +-- +-- Lays out the abstract domain for "GHC.Core.Opt.DmdAnal". module GHC.Types.Demand ( - StrDmd, UseDmd(..), Count, - - Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd, - mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, - toCleanDmd, - absDmd, topDmd, botDmd, seqDmd, - lubDmd, bothDmd, - lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, - isTopDmd, isAbsDmd, isSeqDmd, - peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, - addCaseBndrDmd, - - DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, - BothDmdArg, mkBothDmdArg, toBothDmdArg, - nopDmdType, botDmdType, addDemand, - - DmdEnv, emptyDmdEnv, keepAliveDmdEnv, - peelFV, findIdDemand, - - Divergence(..), lubDivergence, isDeadEndDiv, - topDiv, botDiv, exnDiv, - appIsDeadEnd, isDeadEndSig, pprIfaceStrictSig, - StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, - nopSig, botSig, - isTopSig, hasDemandEnvSig, - splitStrictSig, strictSigDmdEnv, - prependArgsStrictSig, etaConvertStrictSig, - - seqDemand, seqDemandList, seqDmdType, seqStrictSig, - - evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, - splitDmdTy, isWeakDmd, deferAfterPreciseException, - postProcessUnsat, postProcessDmdType, - - splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, - mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, - dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, - TypeShape(..), trimToType, - - useCount, isUsedOnce, reuseEnv, - zapUsageDemand, zapUsageEnvSig, - zapUsedOnceDemand, zapUsedOnceSig, - strictifyDictDmd, strictifyDmd - - ) where + -- * Demands + Card(..), Demand(..), SubDemand(Prod), mkProd, viewProd, + -- ** Algebra + absDmd, topDmd, botDmd, seqDmd, topSubDmd, + -- *** Least upper bound + lubCard, lubDmd, lubSubDmd, + -- *** Plus + plusCard, plusDmd, plusSubDmd, + -- *** Multiply + multCard, multDmd, multSubDmd, + -- ** Predicates on @Card@inalities and @Demand@s + isAbs, isUsedOnce, isStrict, + isAbsDmd, isUsedOnceDmd, isStrUsedDmd, + isTopDmd, isSeqDmd, isWeakDmd, + -- ** Special demands + evalDmd, + -- *** Demands used in PrimOp signatures + lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd, + -- ** Other @Demand@ operations + oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand, + peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds, + addCaseBndrDmd, + -- ** Extracting one-shot information + argOneShots, argsOneShots, saturatedByOneShots, + + -- * Demand environments + DmdEnv, emptyDmdEnv, + keepAliveDmdEnv, reuseEnv, + + -- * Divergence + Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv, + + -- * Demand types + DmdType(..), dmdTypeDepth, + -- ** Algebra + nopDmdType, botDmdType, + lubDmdType, plusDmdType, multDmdType, + -- *** PlusDmdArg + PlusDmdArg, mkPlusDmdArg, toPlusDmdArg, + -- ** Other operations + peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException, + + -- * Demand signatures + StrictSig(..), mkStrictSigForArity, mkClosedStrictSig, + splitStrictSig, strictSigDmdEnv, hasDemandEnvSig, + nopSig, botSig, isTopSig, isDeadEndSig, appIsDeadEnd, + -- ** Handling arity adjustments + prependArgsStrictSig, etaConvertStrictSig, + + -- * Demand transformers from demand signatures + DmdTransformer, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig, + + -- * Trim to a type shape + TypeShape(..), trimToType, + + -- * @seq@ing stuff + seqDemand, seqDemandList, seqDmdType, seqStrictSig, + + -- * Zapping usage information + zapUsageDemand, zapUsageEnvSig, zapUsedOnceDemand, zapUsedOnceSig + ) where #include "HsVersions.h" @@ -78,417 +97,550 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Driver.Ppr - {- ************************************************************************ * * - Joint domain for Strictness and Absence + Card: Combining Strictness and Usage * * ************************************************************************ -} -data JointDmd s u = JD { sd :: s, ud :: u } - deriving ( Eq, Show ) - -getStrDmd :: JointDmd s u -> s -getStrDmd = sd - -getUseDmd :: JointDmd s u -> u -getUseDmd = ud - --- Pretty-printing -instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where - ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) - --- Well-formedness preserving constructors for the joint domain -mkJointDmd :: s -> u -> JointDmd s u -mkJointDmd s u = JD { sd = s, ud = u } - -mkJointDmds :: [s] -> [u] -> [JointDmd s u] -mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as - +-- | Describes an interval of /evaluation cardinalities/. +-- @C_lu@ means "evaluated /at least/ @l@ and /at most/ @u@ times". +-- The lower bound corresponds to /strictness/ (hence @l@ is either @0@ or @1@), +-- the upper bound corresponds to /usage/ (@u@ is one of @0@, @1@, @n@). +-- +-- Intervals describe sets, so the underlying lattice is the powerset lattice. +data Card + = C_00 -- ^ {0} Absent. + | C_01 -- ^ {0,1} Used at most once. + | C_0N -- ^ {0,1,n} Every possible cardinality; the top element. + | C_11 -- ^ {1} Strict and used once. + | C_1N -- ^ {1,n} Strict and used (possibly) many times. + | C_10 -- ^ {} The empty interval; the bottom element of the lattice. + deriving Eq + +_botCard, topCard :: Card +_botCard = C_10 +topCard = C_0N + +-- | True <=> lower bound is 1. +isStrict :: Card -> Bool +isStrict C_10 = True +isStrict C_11 = True +isStrict C_1N = True +isStrict _ = False + +-- | True <=> upper bound is 0. +isAbs :: Card -> Bool +isAbs C_00 = True +isAbs C_10 = True -- Bottom cardinality is also absent +isAbs _ = False + +-- | True <=> upper bound is 1. +isUsedOnce :: Card -> Bool +isUsedOnce C_0N = False +isUsedOnce C_1N = False +isUsedOnce _ = True + +-- | Intersect with [0,1]. +oneifyCard :: Card -> Card +oneifyCard C_0N = C_01 +oneifyCard C_1N = C_11 +oneifyCard c = c + +-- | Denotes '∪' on 'Card'. +lubCard :: Card -> Card -> Card +-- Handle C_10 (bot) +lubCard C_10 n = n -- bot +lubCard n C_10 = n -- bot +-- Handle C_0N (top) +lubCard C_0N _ = C_0N -- top +lubCard _ C_0N = C_0N -- top +-- Handle C_11 +lubCard C_00 C_11 = C_01 -- {0} ∪ {1} = {0,1} +lubCard C_11 C_00 = C_01 -- {0} ∪ {1} = {0,1} +lubCard C_11 n = n -- {1} is a subset of all other intervals +lubCard n C_11 = n -- {1} is a subset of all other intervals +-- Handle C_1N +lubCard C_1N C_1N = C_1N -- reflexivity +lubCard _ C_1N = C_0N -- {0} ∪ {1,n} = top +lubCard C_1N _ = C_0N -- {0} ∪ {1,n} = top +-- Handle C_01 +lubCard C_01 _ = C_01 -- {0} ∪ {0,1} = {0,1} +lubCard _ C_01 = C_01 -- {0} ∪ {0,1} = {0,1} +-- Handle C_00 +lubCard C_00 C_00 = C_00 -- reflexivity + +-- | Denotes '+' on 'Card'. +plusCard :: Card -> Card -> Card +-- Handle C_00 +plusCard C_00 n = n -- {0}+n = n +plusCard n C_00 = n -- {0}+n = n +-- Handle C_10 +plusCard C_10 C_01 = C_11 -- These follow by applying + to lower and upper +plusCard C_10 C_0N = C_1N -- bounds individually +plusCard C_10 n = n +plusCard C_01 C_10 = C_11 +plusCard C_0N C_10 = C_1N +plusCard n C_10 = n +-- Handle the rest (C_01, C_0N, C_11, C_1N) +plusCard C_01 C_01 = C_0N -- The upper bound is at least 1, so upper bound of +plusCard C_01 C_0N = C_0N -- the result must be 1+1 ~= N. +plusCard C_0N C_01 = C_0N -- But for the lower bound we have 4 cases where +plusCard C_0N C_0N = C_0N -- 0+0 ~= 0 (as opposed to 1), so we match on these. +plusCard _ _ = C_1N -- Otherwise we return {1,n} + +-- | Denotes '*' on 'Card'. +multCard :: Card -> Card -> Card +-- Handle C_11 (neutral element) +multCard C_11 c = c +multCard c C_11 = c +-- Handle C_00 (annihilating element) +multCard C_00 _ = C_00 +multCard _ C_00 = C_00 +-- Handle C_10 +multCard C_10 c = if isStrict c then C_10 else C_00 +multCard c C_10 = if isStrict c then C_10 else C_00 +-- Handle reflexive C_1N, C_01 +multCard C_1N C_1N = C_1N +multCard C_01 C_01 = C_01 +-- Handle C_0N and the rest (C_01, C_1N): +multCard _ _ = C_0N {- ************************************************************************ * * - Strictness domain + Demand: Evaluation contexts * * ************************************************************************ +-} - Lazy - | - HeadStr - / \ - SCall SProd - \ / - HyperStr +-- | A demand describes a /scaled evaluation context/, e.g. how many times +-- and how deep the denoted thing is evaluated. +-- +-- The "how many" component is represented by a 'Card'inality. +-- The "how deep" component is represented by a 'SubDemand'. +-- Examples (using Note [Demand notation]): +-- +-- * 'seq' puts demand @SA@ on its argument: It evaluates the argument +-- strictly (@S@), but not any deeper (@A@). +-- * 'fst' puts demand @SP(SU,A)@ on its argument: It evaluates the argument +-- pair strictly and the first component strictly, but no nested info +-- beyond that (@U@). Its second argument is not used at all. +-- * '$' puts demand @SCS(U)@ on its first argument: It calls (@C@) the +-- argument function with one argument, exactly once (@S@). No info +-- on how the result of that call is evaluated (@U@). +-- * 'maybe' puts demand @1C1(U)@ on its second argument: It evaluates +-- the argument function lazily and calls it once when it is evaluated. +-- * @fst p + fst p@ puts demand @MP(MU,A)@ on @p@: It's @SP(SU,A)@ +-- multiplied by two, so we get @M@ (used at least once, possibly multiple +-- times). +-- +-- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled +-- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of +-- which could be used to infer uniqueness types. +data Demand + = !Card :* !SubDemand + deriving Eq + +-- | A sub-demand describes an /evaluation context/, e.g. how deep the +-- denoted thing is evaluated. See 'Demand' for examples. +-- +-- The nested 'SubDemand' @d@ of a 'Call' @Cn(d)@ is /relative/ to a single such call. +-- E.g. The expression @f 1 2 + f 3 4@ puts call demand @MCM(CS(U))@ on @f@: +-- @f@ is called exactly twice (@M@), each time exactly once (@S@) with an +-- additional argument. +-- +-- The nested 'Demand's @dn@ of a 'Prod' @P(d1,d2,...)@ apply /absolutely/: +-- If @dn@ is a used once demand (cf. 'isUsedOnce'), then that means that +-- the denoted sub-expression is used once in the entire evaluation context +-- described by the surrounding 'Demand'. E.g., @UP(1U)@ means that the +-- field of the denoted expression is used at most once, although the +-- entire expression might be used many times. +-- +-- See Note [Call demands are relative] +-- and Note [Demand notation]. +data SubDemand + = Poly !Card + -- ^ Polymorphic demand, the denoted thing is evaluated arbitrarily deep, + -- with the specified cardinality at every level. + -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'. + -- + -- @Poly n@ is semantically equivalent to @nP(n,n,...)@ or @Cn(Cn(..Cn(n)))@. + -- So @U === UP(U,U,...)@ and @U === CU(CU(..CU(U)))@, + -- @S === SP(S,S,...)@ and @S === CS(CS(..CS(S)))@, and so on. + -- + -- We only really use 'Poly' with 'C_10' (bottom), 'C_00' (absent), + -- 'C_0N' (top) and sometimes 'C_1N', but it's simpler to treat it uniformly + -- than to have a special constructor for each of the three cases. + | Call !Card !SubDemand + -- ^ @Call n sd@ describes the evaluation context of @n@ function + -- applications, where every individual result is evaluated according to @sd@. + -- @sd@ is /relative/ to a single call, cf. Note [Call demands are relative]. + -- Used only for values of function type. + | Prod ![Demand] + -- ^ @Prod ds@ describes the evaluation context of a case scrutinisation + -- on an expression of product type, where the product components are + -- evaluated according to @ds@. + deriving Eq + +poly00, poly01, poly0N, poly11, poly1N, poly10 :: SubDemand +topSubDmd, botSubDmd, seqSubDmd :: SubDemand +poly00 = Poly C_00 +poly01 = Poly C_01 +poly0N = Poly C_0N +poly11 = Poly C_11 +poly1N = Poly C_1N +poly10 = Poly C_10 +topSubDmd = poly0N +botSubDmd = poly10 +seqSubDmd = poly00 + +polyDmd :: Card -> Demand +polyDmd C_00 = C_00 :* poly00 +polyDmd C_01 = C_01 :* poly01 +polyDmd C_0N = C_0N :* poly0N +polyDmd C_11 = C_11 :* poly11 +polyDmd C_1N = C_1N :* poly1N +polyDmd C_10 = C_10 :* poly10 + +-- | A smart constructor for 'Prod', applying rewrite rules along the semantic +-- equalities @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly' +-- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a +-- polymorphic demand will never unbox. +mkProd :: [Demand] -> SubDemand +mkProd [] = seqSubDmd +mkProd ds@(n:*sd : _) + | want_to_simplify n, all (== polyDmd n) ds = sd + | otherwise = Prod ds + where + -- We only want to simplify absent and bottom demands and unbox the others. + -- See also Note [U should win] and Note [Don't optimise UP(U,U,...) to U]. + want_to_simplify C_00 = True + want_to_simplify C_10 = True + want_to_simplify _ = False + +-- | @viewProd n sd@ interprets @sd@ as a 'Prod' of arity @n@, expanding 'Poly' +-- demands as necessary. +viewProd :: Arity -> SubDemand -> Maybe [Demand] +-- It's quite important that this function is optimised well; +-- it is used by lubSubDmd and plusSubDmd. Note the strict +-- application to 'polyDmd': +viewProd n (Prod ds) | ds `lengthIs` n = Just ds +-- Note the strict application to replicate: This makes sure we don't allocate +-- a thunk for it, inlines it and lets case-of-case fire at call sites. +viewProd n (Poly card) = Just (replicate n $! polyDmd card) +viewProd _ _ = Nothing +{-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation + -- for Arity. Otherwise, #18304 bites us. + +-- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' demands as +-- necessary. +viewCall :: SubDemand -> Maybe (Card, SubDemand) +viewCall (Call n sd) = Just (n, sd) +viewCall sd@(Poly card) = Just (card, sd) +viewCall _ = Nothing + +topDmd, absDmd, botDmd, seqDmd :: Demand +topDmd = polyDmd C_0N +absDmd = polyDmd C_00 +botDmd = polyDmd C_10 +seqDmd = C_11 :* seqSubDmd + +-- | Denotes '∪' on 'SubDemand'. +lubSubDmd :: SubDemand -> SubDemand -> SubDemand +-- Handle Prod +lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) = + Prod $ zipWith lubDmd ds2 ds1 -- try to fuse with ds2 +-- Handle Call +lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2)) + -- See Note [Call demands are relative] + | isAbs n2 = Call (lubCard n1 n2) (lubSubDmd d1 botSubDmd) + | otherwise = Call (lubCard n1 n2) (lubSubDmd d1 d2) +-- Handle Poly +lubSubDmd (Poly n1) (Poly n2) = Poly (lubCard n1 n2) +-- Make use of reflexivity (so we'll match the Prod or Call cases again). +lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 +-- Otherwise (Call `lub` Prod) return Top +lubSubDmd _ _ = topSubDmd + +-- | Denotes '∪' on 'Demand'. +lubDmd :: Demand -> Demand -> Demand +lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1 n2 :* lubSubDmd sd1 sd2 + +-- | Denotes '+' on 'SubDemand'. +plusSubDmd :: SubDemand -> SubDemand -> SubDemand +-- Handle Prod +plusSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) = + Prod $ zipWith plusDmd ds2 ds1 -- try to fuse with ds2 +-- Handle Call +plusSubDmd (Call n1 d1) (viewCall -> Just (n2, d2)) + -- See Note [Call demands are relative] + | isAbs n2 = Call (plusCard n1 n2) (lubSubDmd d1 botSubDmd) + | otherwise = Call (plusCard n1 n2) (lubSubDmd d1 d2) +-- Handle Poly +plusSubDmd (Poly n1) (Poly n2) = Poly (plusCard n1 n2) +-- Make use of reflexivity (so we'll match the Prod or Call cases again). +plusSubDmd sd1@Poly{} sd2 = plusSubDmd sd2 sd1 +-- Otherwise (Call `lub` Prod) return Top +plusSubDmd _ _ = topSubDmd + +-- | Denotes '+' on 'Demand'. +plusDmd :: Demand -> Demand -> Demand +plusDmd (n1 :* sd1) (n2 :* sd2) = plusCard n1 n2 :* plusSubDmd sd1 sd2 + +-- | The trivial cases of the @mult*@ functions. +-- If @multTrivial n abs a = ma@, we have the following outcomes +-- depending on @n@: +-- +-- * 'C_11' => multiply by one, @ma = Just a@ +-- * 'C_00', 'C_10' (e.g. @'isAbs' n@) => return the absent thing, +-- @ma = Just abs@ +-- * Otherwise ('C_01', 'C_*N') it's not a trivial case, @ma = Nothing@. +multTrivial :: Card -> a -> a -> Maybe a +multTrivial C_11 _ a = Just a +multTrivial n abs _ | isAbs n = Just abs +multTrivial _ _ _ = Nothing + +multSubDmd :: Card -> SubDemand -> SubDemand +multSubDmd n sd + | Just sd' <- multTrivial n seqSubDmd sd = sd' +multSubDmd n (Poly n') = Poly (multCard n n') +multSubDmd n (Call n' sd) = Call (multCard n n') sd -- See Note [Call demands are relative] +multSubDmd n (Prod ds) = Prod (map (multDmd n) ds) + +multDmd :: Card -> Demand -> Demand +multDmd n dmd + | Just dmd' <- multTrivial n absDmd dmd = dmd' +multDmd n (m :* dmd) = multCard n m :* multSubDmd n dmd + +-- | Used to suppress pretty-printing of an uninformative demand +isTopDmd :: Demand -> Bool +isTopDmd dmd = dmd == topDmd -Note [Exceptions and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to smart about catching exceptions, but we aren't anymore. -See #14998 for the way it's resolved at the moment. +isAbsDmd :: Demand -> Bool +isAbsDmd (n :* _) = isAbs n -Here's a historic breakdown: +-- | Not absent and used strictly. See Note [Strict demands] +isStrUsedDmd :: Demand -> Bool +isStrUsedDmd (n :* _) = isStrict n && not (isAbs n) -Apparently, exception handling prim-ops didn't use to have any special -strictness signatures, thus defaulting to nopSig, which assumes they use their -arguments lazily. Joachim was the first to realise that we could provide richer -information. Thus, in 0558911f91c (Dec 13), he added signatures to -primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call -their argument, which is useful information for usage analysis. Still with a -'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. +isSeqDmd :: Demand -> Bool +isSeqDmd (C_11 :* sd) = sd == seqSubDmd +isSeqDmd (C_1N :* sd) = sd == seqSubDmd -- I wonder if we need this case. +isSeqDmd _ = False -In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a -'strictApply1Dmd' leads to substantial performance gains. That was at the cost -of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in -28638dfe79e (Dec 15). +-- | Is the value used at most once? +isUsedOnceDmd :: Demand -> Bool +isUsedOnceDmd (n :* _) = isUsedOnce n -Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, -Ben opened #11222. Simon made the demand analyser "understand catch" in -9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call -its argument strictly, but also swallow any thrown exceptions in -'postProcessDivergence'. This was realized by extending the 'Str' constructor of -'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and -adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element -between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, -so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). - -This left the other variants like 'catchRetry#' having 'catchArgDmd', which is -where #14998 picked up. Item 1 was concerned with measuring the impact of also -making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that -there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 -(Apr 18). There was a lot of dead code resulting from that change, that we -removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and -removed any code that was dealing with the peculiarities. +-- | We try to avoid tracking weak free variable demands in strictness +-- signatures for analysis performance reasons. +-- See Note [Lazy and unleashable free variables] in "GHC.Core.Opt.DmdAnal". +isWeakDmd :: Demand -> Bool +isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd + where + -- @is_plus_idem_* thing@ checks whether @thing `plus` thing = thing@, + -- e.g. if @thing@ is idempotent wrt. to @plus@. + is_plus_idem_card c = plusCard c c == c + -- is_plus_idem_dmd dmd = plusDmd dmd dmd == dmd + is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd + -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd + is_plus_idem_sub_dmd (Poly n) = is_plus_idem_card n + is_plus_idem_sub_dmd (Prod ds) = all is_plus_idem_dmd ds + is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative] -Where did the speed-ups vanish to? In #14998, item 3 established that -turning 'catch#' strict in its first argument didn't bring back any of the -alleged performance benefits. Item 2 of that ticket finally found out that it -was entirely due to 'catchException's new (since #11555) definition, which -was simply +evalDmd :: Demand +evalDmd = C_1N :* topSubDmd - catchException !io handler = catch io handler +-- | First argument of 'GHC.Exts.maskAsyncExceptions#': @SCS(U)@. +-- Called exactly once. +strictOnceApply1Dmd :: Demand +strictOnceApply1Dmd = C_11 :* Call C_11 topSubDmd -While 'catchException' is arguably the saner semantics for 'catch', it is an -internal helper function in "GHC.IO". Its use in -"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: -Remove the bang and you find the regressions we originally wanted to avoid with -'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". +-- | First argument of 'GHC.Exts.atomically#': @MCM(U)@. +-- Called at least once, possibly many times. +strictManyApply1Dmd :: Demand +strictManyApply1Dmd = C_1N :* Call C_1N topSubDmd -So history keeps telling us that the only possibly correct strictness annotation -for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really -is not strict in its argument: Just try this in GHCi +-- | First argument of catch#: @1C1(U)@. +-- Evaluates its arg lazily, but then applies it exactly once to one argument. +lazyApply1Dmd :: Demand +lazyApply1Dmd = C_01 :* Call C_01 topSubDmd - :set -XScopedTypeVariables - import Control.Exception - catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") +-- | Second argument of catch#: @1C1(CS(U))@. +-- Calls its arg lazily, but then applies it exactly once to an additional argument. +lazyApply2Dmd :: Demand +lazyApply2Dmd = C_01 :* Call C_01 (Call C_11 topSubDmd) -Any analysis that assumes otherwise will be broken in some way or another -(beyond `-fno-pendantic-bottoms`). +-- | Make a 'Demand' evaluated at-most-once. +oneifyDmd :: Demand -> Demand +oneifyDmd (n :* sd) = oneifyCard n :* sd -But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a -subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is -only used by `raiseIO#` in order to preserve precise exceptions by strictness -analysis, while not impacting the ability to eliminate dead code. -See Note [Precise exceptions and strictness analysis]. +-- | Make a 'Demand' evaluated at-least-once (e.g. strict). +strictifyDmd :: Demand -> Demand +strictifyDmd (n :* sd) = plusCard C_10 n :* sd --} +-- | If the argument is a used non-newtype dictionary, give it strict demand. +-- Also split the product type & demand and recur in order to similarly +-- strictify the argument's contained used non-newtype superclass dictionaries. +-- We use the demand as our recursive measure to guarantee termination. +strictifyDictDmd :: Type -> Demand -> Demand +strictifyDictDmd ty (n :* Prod ds) + | not (isAbs n) + , Just field_tys <- as_non_newtype_dict ty + = C_1N :* -- main idea: ensure it's strict + if all (not . isAbsDmd) ds + then topSubDmd -- abstract to strict w/ arbitrary component use, + -- since this smells like reboxing; results in CBV + -- boxed + -- + -- TODO revisit this if we ever do boxity analysis + else Prod (zipWith strictifyDictDmd field_tys ds) + where + -- | Return a TyCon and a list of field types if the given + -- type is a non-newtype dictionary type + as_non_newtype_dict ty + | Just (tycon, _arg_tys, _data_con, map scaledThing -> inst_con_arg_tys) + <- splitDataProductType_maybe ty + , not (isNewTyCon tycon) + , isClassTyCon tycon + = Just inst_con_arg_tys + | otherwise + = Nothing +strictifyDictDmd _ dmd = dmd + +-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @CS(d)@. +mkCallDmd :: SubDemand -> SubDemand +mkCallDmd sd = Call C_11 sd + +-- | @mkCallDmds n d@ returns @CS(CS...(CS d))@ where there are @n@ @CS@'s. +mkCallDmds :: Arity -> SubDemand -> SubDemand +mkCallDmds arity sd = iterate mkCallDmd sd !! arity + +-- | Peels one call level from the sub-demand, and also returns how many +-- times we entered the lambda body. +peelCallDmd :: SubDemand -> (Card, SubDemand) +peelCallDmd sd = viewCall sd `orElse` (topCard, topSubDmd) + +-- Peels multiple nestings of 'Call' sub-demands and also returns +-- whether it was unsaturated in the form of a 'Card'inality, denoting +-- how many times the lambda body was entered. +-- See Note [Demands from unsaturated function calls]. +peelManyCalls :: Int -> SubDemand -> Card +peelManyCalls 0 _ = C_11 +-- See Note [Call demands are relative] +peelManyCalls n (viewCall -> Just (m, sd)) = m `multCard` peelManyCalls (n-1) sd +peelManyCalls _ _ = C_0N --- | Vanilla strictness domain -data StrDmd - = HyperStr -- ^ Hyper-strict (bottom of the lattice). - -- See Note [HyperStr and Use demands] - - | SCall StrDmd -- ^ Call demand - -- Used only for values of function type - - | SProd [ArgStr] -- ^ Product - -- Used only for values of product type - -- Invariant: not all components are HyperStr (use HyperStr) - -- not all components are Lazy (use HeadStr) - - | HeadStr -- ^ Head-Strict - -- A polymorphic demand: used for values of all types, - -- including a type variable - - deriving ( Eq, Show ) - --- | Strictness of a function argument. -type ArgStr = Str StrDmd - --- | Strictness demand. -data Str s = Lazy -- ^ Lazy (top of the lattice) - | Str s -- ^ Strict - deriving ( Eq, Show ) - --- Well-formedness preserving constructors for the Strictness domain -strBot, strTop :: ArgStr -strBot = Str HyperStr -strTop = Lazy - -mkSCall :: StrDmd -> StrDmd -mkSCall HyperStr = HyperStr -mkSCall s = SCall s - -mkSProd :: [ArgStr] -> StrDmd -mkSProd sx - | any isHyperStr sx = HyperStr - | all isLazy sx = HeadStr - | otherwise = SProd sx - -isLazy :: ArgStr -> Bool -isLazy Lazy = True -isLazy (Str {}) = False - -isHyperStr :: ArgStr -> Bool -isHyperStr (Str HyperStr) = True -isHyperStr _ = False - --- Pretty-printing -instance Outputable StrDmd where - ppr HyperStr = char 'B' - ppr (SCall s) = char 'C' <> parens (ppr s) - ppr HeadStr = char 'S' - ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) - -instance Outputable ArgStr where - ppr (Str s) = ppr s - ppr Lazy = char 'L' - -lubArgStr :: ArgStr -> ArgStr -> ArgStr -lubArgStr Lazy _ = Lazy -lubArgStr _ Lazy = Lazy -lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) - -lubStr :: StrDmd -> StrDmd -> StrDmd -lubStr HyperStr s = s -lubStr (SCall s1) HyperStr = SCall s1 -lubStr (SCall _) HeadStr = HeadStr -lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) -lubStr (SCall _) (SProd _) = HeadStr -lubStr (SProd sx) HyperStr = SProd sx -lubStr (SProd _) HeadStr = HeadStr -lubStr (SProd s1) (SProd s2) - | s1 `equalLength` s2 = mkSProd (zipWith lubArgStr s1 s2) - | otherwise = HeadStr -lubStr (SProd _) (SCall _) = HeadStr -lubStr HeadStr _ = HeadStr - -bothArgStr :: ArgStr -> ArgStr -> ArgStr -bothArgStr Lazy s = s -bothArgStr s Lazy = s -bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) - -bothStr :: StrDmd -> StrDmd -> StrDmd -bothStr HyperStr _ = HyperStr -bothStr HeadStr s = s -bothStr (SCall _) HyperStr = HyperStr -bothStr (SCall s1) HeadStr = SCall s1 -bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) -bothStr (SCall _) (SProd _) = HyperStr -- Weird - -bothStr (SProd _) HyperStr = HyperStr -bothStr (SProd s1) HeadStr = SProd s1 -bothStr (SProd s1) (SProd s2) - | s1 `equalLength` s2 = mkSProd (zipWith bothArgStr s1 s2) - | otherwise = HyperStr -- Weird -bothStr (SProd _) (SCall _) = HyperStr - --- utility functions to deal with memory leaks -seqStrDmd :: StrDmd -> () -seqStrDmd (SProd ds) = seqStrDmdList ds -seqStrDmd (SCall s) = seqStrDmd s -seqStrDmd _ = () - -seqStrDmdList :: [ArgStr] -> () -seqStrDmdList [] = () -seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds - -seqArgStr :: ArgStr -> () -seqArgStr Lazy = () -seqArgStr (Str s) = seqStrDmd s - --- Splitting polymorphic demands -splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] -splitArgStrProdDmd n Lazy = Just (replicate n Lazy) -splitArgStrProdDmd n (Str s) = splitStrProdDmd n s - -splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] -splitStrProdDmd n HyperStr = Just (replicate n strBot) -splitStrProdDmd n HeadStr = Just (replicate n strTop) -splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), - text "splitStrProdDmd" $$ ppr n $$ ppr ds ) - Just ds -splitStrProdDmd _ (SCall {}) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (#9208) +-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap +mkWorkerDemand :: Int -> Demand +mkWorkerDemand n = C_01 :* go n + where go 0 = topSubDmd + go n = Call C_01 $ go (n-1) -{- -************************************************************************ -* * - Absence domain -* * -************************************************************************ +addCaseBndrDmd :: SubDemand -- On the case binder + -> [Demand] -- On the components of the constructor + -> [Demand] -- Final demands for the components of the constructor +addCaseBndrDmd (Poly n) alt_dmds + | isAbs n = alt_dmds +-- See Note [Demand on case-alternative binders] +addCaseBndrDmd sd alt_dmds = zipWith plusDmd ds alt_dmds -- fuse ds! + where + Just ds = viewProd (length alt_dmds) sd -- Guaranteed not to be a call - Used - / \ - UCall UProd - \ / - UHead - | - Count x - - | - Abs --} +argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] +-- ^ See Note [Computing one-shot info] +argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args + | unsaturated_call = [] + | otherwise = go arg_ds + where + unsaturated_call = arg_ds `lengthExceeds` n_val_args --- | Domain for genuine usage -data UseDmd - = UCall Count UseDmd -- ^ Call demand for absence. - -- Used only for values of function type + go [] = [] + go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds - | UProd [ArgUse] -- ^ Product. - -- Used only for values of product type - -- See Note [Don't optimise UProd(Used) to Used] - -- - -- Invariant: Not all components are Abs - -- (in that case, use UHead) + -- Avoid list tail like [ [], [], [] ] + cons [] [] = [] + cons a as = a:as - | UHead -- ^ May be used but its sub-components are - -- definitely *not* used. For product types, UHead - -- is equivalent to U(AAA); see mkUProd. - -- - -- UHead is needed only to express the demand - -- of 'seq' and 'case' which are polymorphic; - -- i.e. the scrutinised value is of type 'a' - -- rather than a product type. That's why we - -- can't use UProd [A,A,A] - -- - -- Since (UCall _ Abs) is ill-typed, UHead doesn't - -- make sense for lambdas - - | Used -- ^ May be used and its sub-components may be used. - -- (top of the lattice) - deriving ( Eq, Show ) - --- Extended usage demand for absence and counting -type ArgUse = Use UseDmd - -data Use u - = Abs -- Definitely unused - -- Bottom of the lattice - - | Use Count u -- May be used with some cardinality - deriving ( Eq, Show ) - --- | Abstract counting of usages -data Count = One | Many - deriving ( Eq, Show ) - --- Pretty-printing -instance Outputable ArgUse where - ppr Abs = char 'A' - ppr (Use Many a) = ppr a - ppr (Use One a) = char '1' <> char '*' <> ppr a - -instance Outputable UseDmd where - ppr Used = char 'U' - ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) - ppr UHead = char 'H' - ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) - -instance Outputable Count where - ppr One = char '1' - ppr Many = text "" - -useBot, useTop :: ArgUse -useBot = Abs -useTop = Use Many Used - -mkUCall :: Count -> UseDmd -> UseDmd ---mkUCall c Used = Used c -mkUCall c a = UCall c a - -mkUProd :: [ArgUse] -> UseDmd -mkUProd ux - | all (== Abs) ux = UHead - | otherwise = UProd ux - -lubCount :: Count -> Count -> Count -lubCount _ Many = Many -lubCount Many _ = Many -lubCount x _ = x - -lubArgUse :: ArgUse -> ArgUse -> ArgUse -lubArgUse Abs x = x -lubArgUse x Abs = x -lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) - -lubUse :: UseDmd -> UseDmd -> UseDmd -lubUse UHead u = u -lubUse (UCall c u) UHead = UCall c u -lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) -lubUse (UCall _ _) _ = Used -lubUse (UProd ux) UHead = UProd ux -lubUse (UProd ux1) (UProd ux2) - | ux1 `equalLength` ux2 = UProd $ zipWith lubArgUse ux1 ux2 - | otherwise = Used -lubUse (UProd {}) (UCall {}) = Used --- lubUse (UProd {}) Used = Used -lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) -lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) -lubUse Used _ = Used -- Note [Used should win] - --- `both` is different from `lub` in its treatment of counting; if --- `both` is computed for two used, the result always has --- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). --- Also, x `bothUse` x /= x (for anything but Abs). - -bothArgUse :: ArgUse -> ArgUse -> ArgUse -bothArgUse Abs x = x -bothArgUse x Abs = x -bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) - - -bothUse :: UseDmd -> UseDmd -> UseDmd -bothUse UHead u = u -bothUse (UCall c u) UHead = UCall c u - --- Exciting special treatment of inner demand for call demands: --- use `lubUse` instead of `bothUse`! -bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) - -bothUse (UCall {}) _ = Used -bothUse (UProd ux) UHead = UProd ux -bothUse (UProd ux1) (UProd ux2) - | ux1 `equalLength` ux2 = UProd $ zipWith bothArgUse ux1 ux2 - | otherwise = Used -bothUse (UProd {}) (UCall {}) = Used --- bothUse (UProd {}) Used = Used -- Note [Used should win] -bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) -bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) -bothUse Used _ = Used -- Note [Used should win] - -peelUseCall :: UseDmd -> Maybe (Count, UseDmd) -peelUseCall (UCall c u) = Just (c,u) -peelUseCall _ = Nothing - -addCaseBndrDmd :: Demand -- On the case binder - -> [Demand] -- On the components of the constructor - -> [Demand] -- Final demands for the components of the constructor --- See Note [Demand on case-alternative binders] -addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds - = case mu of - Abs -> alt_dmds - Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) - where - Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call - Just us = splitUseProdDmd arity u -- Ditto +argOneShots :: Demand -- ^ depending on saturation + -> [OneShotInfo] +-- ^ See Note [Computing one-shot info] +argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative] where - arity = length alt_dmds + go (Call n sd) + | isUsedOnce n = OneShotLam : go sd + | otherwise = NoOneShotInfo : go sd + go _ = [] + +-- | +-- @saturatedByOneShots n C1(C1(...)) = True@ +-- <=> +-- There are at least n nested C1(..) calls. +-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap +saturatedByOneShots :: Int -> Demand -> Bool +saturatedByOneShots n (_ :* sd) = isUsedOnce (peelManyCalls n sd) + +{- Note [Strict demands] +~~~~~~~~~~~~~~~~~~~~~~~~ +'isStrUsedDmd' returns true only of demands that are + both strict + and used +In particular, it is False for <B>, which can and does +arise in, say (#7319) + f x = raise# <some exception> +Then 'x' is not used, so f gets strictness <B> -> . +Now the w/w generates + fx = let x <B> = absentError "unused" + in raise <some exception> +At this point we really don't want to convert to + fx = case absentError "unused" of x -> raise <some exception> +Since the program is going to diverge, this swaps one error for another, +but it's really a bad idea to *ever* evaluate an absent argument. +In #7319 we get + T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] -{- Note [Demand on case-alternative binders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Call demands are relative] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expression @if b then 0 else f 1 2 + f 3 4@ uses @f@ according to the demand +@UCU(CS(P(U)))@, meaning + + "f is called multiple times or not at all (CU), but each time it + is called, it's called with *exactly one* (CS) more argument. + Whenever it is called with two arguments, we have no info on how often + the field of the product result is used (U)." + +So the 'SubDemand' nested in a 'Call' demand is relative to exactly one call. +And that extends to the information we have how its results are used in each +call site. Consider (#18903) + + h :: Int -> Int + h m = + let g :: Int -> (Int,Int) + g 1 = (m, 0) + g n = (2 * n, 2 `div` n) + {-# NOINLINE g #-} + in case m of + 1 -> 0 + 2 -> snd (g m) + _ -> uncurry (+) (g m) + +We want to give @g@ the demand @1C1(P(1P(U),SP(U)))@, so we see that in each call +site of @g@, we are strict in the second component of the returned pair. + +This relative cardinality leads to an otherwise unexpected call to 'lubSubDmd' +in 'plusSubDmd', but if you do the math it's just the right thing. + +There's one more subtlety: Since the nested demand is relative to exactly one +call, in the case where we have *at most zero calls* (e.g. CA(...)), the premise +is hurt and we can assume that the nested demand is 'botSubDmd'. That ensures +that @g@ above actually gets the @SP(U)@ demand on its second pair component, +rather than the lazy @1P(U)@ if we 'lub'bed with an absent demand. + +Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The demand on a binder in a case alternative comes (a) From the demand on the binder itself (b) From the demand on the case binder @@ -501,9 +653,9 @@ Example. Source code: foo (p,q) = foo (q,p) After strictness analysis: - f = \ (x_an1 [Dmd=<S(SL),1*U(U,1*U)>] :: (Bool, Bool)) -> + f = \ (x_an1 [Dmd=<SP(SL),1*UP(U,1*U)>] :: (Bool, Bool)) -> case x_an1 - of wild_X7 [Dmd=<L,1*U(1*U,1*U)>] + of wild_X7 [Dmd=<L,1*UP(1*U,1*U)>] { (p_an2 [Dmd=<S,1*U>], ds_dnz [Dmd=<L,A>]) -> case p_an2 of _ { False -> GHC.Types.True; @@ -516,36 +668,31 @@ consequences play out. This is needed even for non-product types, in case the case-binder is used but the components of the case alternative are not. -Note [Don't optimise UProd(Used) to Used] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -These two UseDmds: - UProd [Used, Used] and Used +Note [Don't optimise UP(U,U,...) to U] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These two SubDemands: + UP(U,U) (@Prod [topDmd, topDmd]@) and U (@topSubDmd@) are semantically equivalent, but we do not turn the former into -the latter, for a regrettable-subtle reason. Suppose we did. -then - f (x,y) = (y,x) -would get - StrDmd = Str = SProd [Lazy, Lazy] - UseDmd = Used = UProd [Used, Used] -But with the joint demand of <Str, Used> doesn't convey any clue -that there is a product involved, and so the worthSplittingFun -will not fire. (We'd need to use the type as well to make it fire.) -Moreover, consider - g h p@(_,_) = h p -This too would get <Str, Used>, but this time there really isn't any -point in w/w since the components of the pair are not used at all. - -So the solution is: don't aggressively collapse UProd [Used,Used] to -Used; instead leave it as-is. In effect we are using the UseDmd to do a +the latter, for a regrettable-subtle reason. Consider + f p1@(x,y) = (y,x) + g h p2@(_,_) = h p +We want to unbox @p1@ of @f@, but not @p2@ of @g@, because @g@ only uses +@p2@ boxed and we'd have to rebox. So we give @p1@ demand UP(U,U) and @p2@ +demand @U@ to inform 'GHC.Core.Opt.WorkWrap.Utils.wantToUnbox', which will +say "unbox" for @p1@ and "don't unbox" for @p2@. + +So the solution is: don't aggressively collapse @Prod [topDmd, topDmd]@ to +@topSubDmd@; instead leave it as-is. In effect we are using the UseDmd to do a little bit of boxity analysis. Not very nice. -Note [Used should win] -~~~~~~~~~~~~~~~~~~~~~~ -Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. -Why? Because Used carries the implication the whole thing is used, -box and all, so we don't want to w/w it. If we use it both boxed and -unboxed, then we are definitely using the box, and so we are quite -likely to pay a reboxing cost. So we make Used win here. +Note [U should win] +~~~~~~~~~~~~~~~~~~~ +Both in 'lubSubDmd' and 'plusSubDmd' we want @U `plusSubDmd` UP(..)) to be @U@. +Why? Because U carries the implication the whole thing is used, box and all, +so we don't want to w/w it, cf. Note [Don't optimise UP(U,U,...) to U]. +If we use it both boxed and unboxed, then we are definitely using the box, +and so we are quite likely to pay a reboxing cost. So we make U win here. +TODO: Investigate why since 2013, we don't. Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer @@ -557,335 +704,39 @@ Compare with: (B) making Used win for lub and both Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% Baseline: (B) Making Used win for both lub and both -Compare with: (C) making Used win for both, but UProd win for lub +Compare with: (C) making Used win for plus, but UProd win for lub Min -0.1% -0.3% -7.9% -8.0% -6.5% Max +0.1% +1.0% +21.0% +21.0% +0.5% Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% --} - --- If a demand is used multiple times (i.e. reused), than any use-once --- mentioned there, that is not protected by a UCall, can happen many times. -markReusedDmd :: ArgUse -> ArgUse -markReusedDmd Abs = Abs -markReusedDmd (Use _ a) = Use Many (markReused a) - -markReused :: UseDmd -> UseDmd -markReused (UCall _ u) = UCall Many u -- No need to recurse here -markReused (UProd ux) = UProd (map markReusedDmd ux) -markReused u = u - -isUsedMU :: ArgUse -> Bool --- True <=> markReusedDmd d = d -isUsedMU Abs = True -isUsedMU (Use One _) = False -isUsedMU (Use Many u) = isUsedU u - -isUsedU :: UseDmd -> Bool --- True <=> markReused d = d -isUsedU Used = True -isUsedU UHead = True -isUsedU (UProd us) = all isUsedMU us -isUsedU (UCall One _) = False -isUsedU (UCall Many _) = True -- No need to recurse - --- Squashing usage demand demands -seqUseDmd :: UseDmd -> () -seqUseDmd (UProd ds) = seqArgUseList ds -seqUseDmd (UCall c d) = c `seq` seqUseDmd d -seqUseDmd _ = () - -seqArgUseList :: [ArgUse] -> () -seqArgUseList [] = () -seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds - -seqArgUse :: ArgUse -> () -seqArgUse (Use c u) = c `seq` seqUseDmd u -seqArgUse _ = () - --- Splitting polymorphic Maybe-Used demands -splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] -splitUseProdDmd n Used = Just (replicate n useTop) -splitUseProdDmd n UHead = Just (replicate n Abs) -splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), - text "splitUseProdDmd" $$ ppr n - $$ ppr ds ) - Just ds -splitUseProdDmd _ (UCall _ _) = Nothing - -- This can happen when the programmer uses unsafeCoerce, - -- and we don't then want to crash the compiler (#9208) - -useCount :: Use u -> Count -useCount Abs = One -useCount (Use One _) = One -useCount _ = Many - - -{- -************************************************************************ -* * - Clean demand for Strictness and Usage -* * -************************************************************************ - -This domain differst from JointDemand in the sense that pure absence -is taken away, i.e., we deal *only* with non-absent demands. - -Note [Strict demands] -~~~~~~~~~~~~~~~~~~~~~ -isStrictDmd returns true only of demands that are - both strict - and used -In particular, it is False for <HyperStr, Abs>, which can and does -arise in, say (#7319) - f x = raise# <some exception> -Then 'x' is not used, so f gets strictness <HyperStr,Abs> -> . -Now the w/w generates - fx = let x <HyperStr,Abs> = absentError "unused" - in raise <some exception> -At this point we really don't want to convert to - fx = case absentError "unused" of x -> raise <some exception> -Since the program is going to diverge, this swaps one error for another, -but it's really a bad idea to *ever* evaluate an absent argument. -In #7319 we get - T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] - -Note [Dealing with call demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Call demands are constructed and deconstructed coherently for -strictness and absence. For instance, the strictness signature for the -following function - -f :: (Int -> (Int, Int)) -> (Int, Bool) -f g = (snd (g 3), True) - -should be: <L,C(U(AU))>m --} - -type CleanDemand = JointDmd StrDmd UseDmd - -- A demand that is at least head-strict - -bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand -bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) - = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } - -mkHeadStrict :: CleanDemand -> CleanDemand -mkHeadStrict cd = cd { sd = HeadStr } - -mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand -mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a } -mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a } - -evalDmd :: Demand --- Evaluated strictly, and used arbitrarily deeply -evalDmd = JD { sd = Str HeadStr, ud = useTop } - -mkProdDmd :: [Demand] -> CleanDemand -mkProdDmd dx - = JD { sd = mkSProd $ map getStrDmd dx - , ud = mkUProd $ map getUseDmd dx } - --- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@. -mkCallDmd :: CleanDemand -> CleanDemand -mkCallDmd (JD {sd = d, ud = u}) - = JD { sd = mkSCall d, ud = mkUCall One u } - --- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s. -mkCallDmds :: Arity -> CleanDemand -> CleanDemand -mkCallDmds arity cd = iterate mkCallDmd cd !! arity - --- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap -mkWorkerDemand :: Int -> Demand -mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } - where go 0 = Used - go n = mkUCall One $ go (n-1) -cleanEvalDmd :: CleanDemand -cleanEvalDmd = JD { sd = HeadStr, ud = Used } - -cleanEvalProdDmd :: Arity -> CleanDemand -cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } - - -{- -************************************************************************ -* * - Demand: Combining Strictness and Usage -* * -************************************************************************ +Note [Computing one-shot info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a call + f (\pqr. e1) (\xyz. e2) e3 +where f has usage signature + C1(C(C1(U))) C1(U) U +Then argsOneShots returns a [[OneShotInfo]] of + [[OneShot,NoOneShotInfo,OneShot], [OneShot]] +The occurrence analyser propagates this one-shot infor to the +binders \pqr and \xyz; +see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal". -} -type Demand = JointDmd ArgStr ArgUse - -lubDmd :: Demand -> Demand -> Demand -lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `lubArgStr` s2 - , ud = a1 `lubArgUse` a2 } - -bothDmd :: Demand -> Demand -> Demand -bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) - = JD { sd = s1 `bothArgStr` s2 - , ud = a1 `bothArgUse` a2 } - -lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand - -strictApply1Dmd = JD { sd = Str (SCall HeadStr) - , ud = Use Many (UCall One Used) } - -lazyApply1Dmd = JD { sd = Lazy - , ud = Use One (UCall One Used) } - --- Second argument of catch#: --- uses its arg at most once, applies it once --- but is lazy (might not be called at all) -lazyApply2Dmd = JD { sd = Lazy - , ud = Use One (UCall One (UCall One Used)) } - -absDmd :: Demand -absDmd = JD { sd = Lazy, ud = Abs } - -topDmd :: Demand -topDmd = JD { sd = Lazy, ud = useTop } - -botDmd :: Demand -botDmd = JD { sd = strBot, ud = useBot } - -seqDmd :: Demand -seqDmd = JD { sd = Str HeadStr, ud = Use One UHead } - -oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u) -oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } -oneifyDmd jd = jd - -isTopDmd :: Demand -> Bool --- Used to suppress pretty-printing of an uninformative demand -isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True -isTopDmd _ = False - -isAbsDmd :: JointDmd (Str s) (Use u) -> Bool -isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr -isAbsDmd _ = False -- for a bottom demand - -isSeqDmd :: Demand -> Bool -isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True -isSeqDmd _ = False - -isUsedOnce :: JointDmd (Str s) (Use u) -> Bool -isUsedOnce (JD { ud = a }) = case useCount a of - One -> True - Many -> False - --- More utility functions for strictness -seqDemand :: Demand -> () -seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u - -seqDemandList :: [Demand] -> () -seqDemandList [] = () -seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds - -isStrictDmd :: JointDmd (Str s) (Use u) -> Bool --- See Note [Strict demands] -isStrictDmd (JD {ud = Abs}) = False -isStrictDmd (JD {sd = Lazy}) = False -isStrictDmd _ = True - -isWeakDmd :: Demand -> Bool -isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a - -cleanUseDmd_maybe :: Demand -> Maybe UseDmd -cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u -cleanUseDmd_maybe _ = Nothing - -keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv --- (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 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 - -splitProdDmd_maybe :: Demand -> Maybe [Demand] --- Split a product into its components, iff there is any --- useful information to be extracted thereby --- The demand is not necessarily strict! -splitProdDmd_maybe (JD { sd = s, ud = u }) - = case (s,u) of - (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u - -> Just (mkJointDmds sx ux) - (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s - -> Just (mkJointDmds sx ux) - (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) - _ -> Nothing - -{- ********************************************************************* -* * - TypeShape and demand trimming -* * -********************************************************************* -} - - -data TypeShape -- See Note [Trimming a demand to a type] - -- in GHC.Core.Opt.DmdAnal - = TsFun TypeShape - | TsProd [TypeShape] - | TsUnk - -trimToType :: Demand -> TypeShape -> Demand --- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal -trimToType (JD { sd = ms, ud = mu }) ts - = JD (go_ms ms ts) (go_mu mu ts) - where - go_ms :: ArgStr -> TypeShape -> ArgStr - go_ms Lazy _ = Lazy - go_ms (Str s) ts = Str (go_s s ts) - - go_s :: StrDmd -> TypeShape -> StrDmd - go_s HyperStr _ = HyperStr - go_s (SCall s) (TsFun ts) = SCall (go_s s ts) - go_s (SProd mss) (TsProd tss) - | equalLength mss tss = SProd (zipWith go_ms mss tss) - go_s _ _ = HeadStr - - go_mu :: ArgUse -> TypeShape -> ArgUse - go_mu Abs _ = Abs - go_mu (Use c u) ts = Use c (go_u u ts) - - go_u :: UseDmd -> TypeShape -> UseDmd - go_u UHead _ = UHead - go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) - go_u (UProd mus) (TsProd tss) - | equalLength mus tss = UProd (zipWith go_mu mus tss) - go_u _ _ = Used - -instance Outputable TypeShape where - ppr TsUnk = text "TsUnk" - ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) - ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) - - - {- ********************************************************************* * * - Termination + Divergence: Whether evaluation surely diverges * * ********************************************************************* -} --- | Divergence lattice. Models a subset lattice of the following exhaustive --- set of divergence results: +-- | 'Divergence' characterises whether something surely diverges. +-- Models a subset lattice of the following exhaustive set of divergence +-- results: -- -- [n] nontermination (e.g. loops) -- [i] throws imprecise exception --- [p] throws precise exception --- [c] converges (reduces to WHNF) +-- [p] throws precise exceTtion +-- [c] converges (reduces to WHNF). -- -- The different lattice elements correspond to different subsets, indicated by -- juxtaposition of indicators (e.g. __nc__ definitely doesn't throw an @@ -908,7 +759,7 @@ data Divergence -- exception or diverges. Never converges, hence 'isDeadEndDiv'! -- See scenario 1 in Note [Precise exceptions and strictness analysis]. | Dunno -- ^ Might diverge, throw any kind of exception or converge. - deriving( Eq, Show ) + deriving Eq lubDivergence :: Divergence -> Divergence -> Divergence lubDivergence Diverges div = div @@ -919,23 +770,55 @@ lubDivergence _ _ = Dunno -- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 -- (See Note [Default demand on free variables and arguments] for why) -bothDivergence :: Divergence -> Divergence -> Divergence --- See Note [Asymmetry of 'both*'], which concludes that 'bothDivergence' needs --- to be symmetric. --- Strictly speaking, we should have @bothDivergence Dunno Diverges = ExnOrDiv@. +-- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence' +-- needs to be symmetric. +-- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@. -- But that regresses in too many places (every infinite loop, basically) to be -- worth it and is only relevant in higher-order scenarios -- (e.g. Divergence of @f (throwIO blah)@). --- So 'bothDivergence' currently is 'glbDivergence', really. -bothDivergence Dunno Dunno = Dunno -bothDivergence Diverges _ = Diverges -bothDivergence _ Diverges = Diverges -bothDivergence _ _ = ExnOrDiv +-- So 'plusDivergence' currently is 'glbDivergence', really. +plusDivergence :: Divergence -> Divergence -> Divergence +plusDivergence Dunno Dunno = Dunno +plusDivergence Diverges _ = Diverges +plusDivergence _ Diverges = Diverges +plusDivergence _ _ = ExnOrDiv + +-- | In a non-strict scenario, we might not force the Divergence, in which case +-- we might converge, hence Dunno. +multDivergence :: Card -> Divergence -> Divergence +multDivergence n _ | not (isStrict n) = Dunno +multDivergence _ d = d -instance Outputable Divergence where - ppr Diverges = char 'b' -- for (b)ottom - ppr ExnOrDiv = char 'x' -- for e(x)ception - ppr Dunno = empty +topDiv, exnDiv, botDiv :: Divergence +topDiv = Dunno +exnDiv = ExnOrDiv +botDiv = Diverges + +-- | True if the 'Divergence' indicates that evaluation will not return. +-- See Note [Dead ends]. +isDeadEndDiv :: Divergence -> Bool +isDeadEndDiv Diverges = True +isDeadEndDiv ExnOrDiv = True +isDeadEndDiv Dunno = False + +-- See Notes [Default demand on free variables and arguments] +-- and Scenario 1 in [Precise exceptions and strictness analysis] +defaultFvDmd :: Divergence -> Demand +defaultFvDmd Dunno = absDmd +defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv! +defaultFvDmd Diverges = botDmd -- Diverges + +defaultArgDmd :: Divergence -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes === (Bot -> BotRes) === ... +-- TopRes === (Top -> TopRes) === ... +-- This function makes that concrete +-- Also see Note [Default demand on free variables and arguments] +defaultArgDmd Dunno = topDmd +-- NB: not botDmd! We don't want to mask the precise exception by forcing the +-- argument. But it is still absent. +defaultArgDmd ExnOrDiv = absDmd +defaultArgDmd Diverges = botDmd {- Note [Precise vs imprecise exceptions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1036,50 +919,83 @@ a bad fit because The "hack" is probably not having to defer when we can prove that the expression may not throw a precise exception (increasing precision of the analysis), but that's just a favourable guess. --} ------------------------------------------------------------------------- --- Combined demand result -- ------------------------------------------------------------------------- +Note [Exceptions and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to smart about catching exceptions, but we aren't anymore. +See #14998 for the way it's resolved at the moment. -topDiv, exnDiv, botDiv :: Divergence -topDiv = Dunno -exnDiv = ExnOrDiv -botDiv = Diverges +Here's a historic breakdown: --- | True if the result indicates that evaluation will not return. --- See Note [Dead ends]. -isDeadEndDiv :: Divergence -> Bool -isDeadEndDiv Diverges = True -isDeadEndDiv ExnOrDiv = True -isDeadEndDiv Dunno = False +Apparently, exception handling prim-ops didn't use to have any special +strictness signatures, thus defaulting to nopSig, which assumes they use their +arguments lazily. Joachim was the first to realise that we could provide richer +information. Thus, in 0558911f91c (Dec 13), he added signatures to +primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call +their argument, which is useful information for usage analysis. Still with a +'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. --- See Notes [Default demand on free variables and arguments] --- and Scenario 1 in [Precise exceptions and strictness analysis] -defaultFvDmd :: Divergence -> Demand -defaultFvDmd Dunno = absDmd -defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv! -defaultFvDmd Diverges = botDmd -- Diverges +In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a +'strictApply1Dmd' leads to substantial performance gains. That was at the cost +of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in +28638dfe79e (Dec 15). -defaultArgDmd :: Divergence -> Demand --- TopRes and BotRes are polymorphic, so that --- BotRes === (Bot -> BotRes) === ... --- TopRes === (Top -> TopRes) === ... --- This function makes that concrete --- Also see Note [Default demand on free variables and arguments] -defaultArgDmd Dunno = topDmd --- NB: not botDmd! We don't want to mask the precise exception by forcing the --- argument. But it is still absent. -defaultArgDmd ExnOrDiv = absDmd -defaultArgDmd Diverges = botDmd +Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, +Ben opened #11222. Simon made the demand analyser "understand catch" in +9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call +its argument strictly, but also swallow any thrown exceptions in +'multDivergence'. This was realized by extending the 'Str' constructor of +'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and +adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element +between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, +so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). -{- Note [Default demand on free variables and arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This left the other variants like 'catchRetry#' having 'catchArgDmd', which is +where #14998 picked up. Item 1 was concerned with measuring the impact of also +making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that +there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 +(Apr 18). There was a lot of dead code resulting from that change, that we +removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and +removed any code that was dealing with the peculiarities. + +Where did the speed-ups vanish to? In #14998, item 3 established that +turning 'catch#' strict in its first argument didn't bring back any of the +alleged performance benefits. Item 2 of that ticket finally found out that it +was entirely due to 'catchException's new (since #11555) definition, which +was simply + + catchException !io handler = catch io handler + +While 'catchException' is arguably the saner semantics for 'catch', it is an +internal helper function in "GHC.IO". Its use in +"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: +Remove the bang and you find the regressions we originally wanted to avoid with +'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". + +So history keeps telling us that the only possibly correct strictness annotation +for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really +is not strict in its argument: Just try this in GHCi + + :set -XScopedTypeVariables + import Control.Exception + catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") + +Any analysis that assumes otherwise will be broken in some way or another +(beyond `-fno-pendantic-bottoms`). + +But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a +subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is +only used by `raiseIO#` in order to preserve precise exceptions by strictness +analysis, while not impacting the ability to eliminate dead code. +See Note [Precise exceptions and strictness analysis]. + +Note [Default demand on free variables and arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Free variables not mentioned in the environment of a 'DmdType' are demanded according to the demand type's Divergence: * In a Diverges (botDiv) context, that demand is botDmd - (HyperStr and Absent). - * In all other contexts, the demand is absDmd (Lazy and Absent). + (strict and absent). + * In all other contexts, the demand is absDmd (lazy and absent). This is recorded in 'defaultFvDmd'. Similarly, we can eta-expand demand types to get demands on excess arguments @@ -1090,7 +1006,7 @@ not accounted for in the type, by consulting 'defaultArgDmd': it (cf. Note [Precise exceptions and strictness analysis]). * In a Dunno context (topDiv), the demand is topDmd, because it's perfectly possible to enter the additional lambda and evaluate it - in unforeseen ways (so, not Absent). + in unforeseen ways (so, not absent). ************************************************************************ @@ -1100,68 +1016,49 @@ not accounted for in the type, by consulting 'defaultArgDmd': ************************************************************************ -} -type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables and arguments] - -data DmdType = DmdType - DmdEnv -- Demand on explicitly-mentioned - -- free variables - [Demand] -- Demand on arguments - Divergence -- See [Demand type Divergence] - -{- -Note [Demand type Divergence] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In contrast to StrictSigs, DmdTypes are elicited under a specific incoming demand. -This is described in detail in Note [Understanding DmdType and StrictSig]. -Here, we'll focus on what that means for a DmdType's Divergence in a higher-order -scenario. +-- Subject to Note [Default demand on free variables and arguments] +type DmdEnv = VarEnv Demand -Consider - err x y = x `seq` y `seq` error (show x) -this has a strictness signature of - <S><S>b -meaning that we don't know what happens when we call errin weaker contexts than -C(C(S)), like @err `seq` ()@ (S) and @err 1 `seq` ()@ (C(S)). We may not unleash -the botDiv, hence assume topDiv. Of course, in @err 1 2 `seq` ()@ the incoming -demand C(C(S)) is strong enough and we see that the expression diverges. +emptyDmdEnv :: VarEnv Demand +emptyDmdEnv = emptyVarEnv -Now consider a function - f g = g 1 2 -with signature <C(S)>, and the expression - f err `seq` () -now f puts a strictness demand of C(C(S)) onto its argument, which is unleashed -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! +multDmdEnv :: Card -> DmdEnv -> DmdEnv +multDmdEnv n env + | Just env' <- multTrivial n emptyDmdEnv env = env' + | otherwise = mapVarEnv (multDmd n) env -Note [Asymmetry of 'both*'] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -'both' for DmdTypes is *asymmetrical*, because there can only one -be one type contributing argument demands! For example, given (e1 e2), we get -a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do -(dt1 `bothType` dt2). Similarly with - case e of { p -> rhs } -we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then -compute (dt_rhs `bothType` dt_scrut). +reuseEnv :: DmdEnv -> DmdEnv +reuseEnv = multDmdEnv C_1N -We - 1. combine the information on the free variables, - 2. take the demand on arguments from the first argument - 3. combine the termination results, as in bothDivergence. +-- | @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 -Since we don't use argument demands of the second argument anyway, 'both's -second argument is just a 'BothDmdType'. + 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 -But note that the argument demand types are not guaranteed to be observed in -left to right order. For example, analysis of a case expression will pass the -demand type for the alts as the left argument and the type for the scrutinee as -the right argument. Also, it is not at all clear if there is such an order; -consider the LetUp case, where the RHS might be forced at any point while -evaluating the let body. -Therefore, it is crucial that 'bothDivergence' is symmetric! --} +-- | Characterises how an expression +-- * Evaluates its free variables ('dt_env') +-- * Evaluates its arguments ('dt_args') +-- * Diverges on every code path or not ('dt_div') +data DmdType + = DmdType + { dt_env :: DmdEnv -- ^ Demand on explicitly-mentioned free variables + , dt_args :: [Demand] -- ^ Demand on arguments + , dt_div :: Divergence -- ^ Whether evaluation diverges. + -- See Note [Demand type Divergence] + } --- Equality needed for fixpoints in GHC.Core.Opt.DmdAnal instance Eq DmdType where (==) (DmdType fv1 ds1 div1) (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 @@ -1184,36 +1081,22 @@ lubDmdType d1 d2 lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 lub_div = lubDivergence r1 r2 -type BothDmdArg = (DmdEnv, Divergence) +type PlusDmdArg = (DmdEnv, Divergence) -mkBothDmdArg :: DmdEnv -> BothDmdArg -mkBothDmdArg env = (env, topDiv) +mkPlusDmdArg :: DmdEnv -> PlusDmdArg +mkPlusDmdArg env = (env, topDiv) -toBothDmdArg :: DmdType -> BothDmdArg -toBothDmdArg (DmdType fv _ r) = (fv, r) +toPlusDmdArg :: DmdType -> PlusDmdArg +toPlusDmdArg (DmdType fv _ r) = (fv, r) -bothDmdType :: DmdType -> BothDmdArg -> DmdType -bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) - -- See Note [Asymmetry of 'both*'] - -- 'both' takes the argument/result info from its *first* arg, +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. - = DmdType (plusVarEnv_CD bothDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2)) + = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2)) ds1 - (r1 `bothDivergence` t2) - -instance Outputable DmdType where - ppr (DmdType fv ds res) - = hsep [hcat (map ppr ds) <> ppr res, - 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 - -- It's OK to use nonDetUFMToList here because we only do it for - -- pretty printing - -emptyDmdEnv :: VarEnv Demand -emptyDmdEnv = emptyVarEnv + (r1 `plusDivergence` t2) botDmdType :: DmdType botDmdType = DmdType emptyDmdEnv [] botDiv @@ -1221,7 +1104,6 @@ botDmdType = DmdType emptyDmdEnv [] botDiv -- | 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. --- (SG: I agree, but why is it still 'topDmd' then?) nopDmdType :: DmdType nopDmdType = DmdType emptyDmdEnv [] topDiv @@ -1235,18 +1117,17 @@ exnDmdType :: DmdType exnDmdType = DmdType emptyDmdEnv [] exnDiv dmdTypeDepth :: DmdType -> Arity -dmdTypeDepth (DmdType _ ds _) = length ds +dmdTypeDepth = length . dt_args -- | This makes sure we can use the demand type with n arguments after eta -- 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 +etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div} | n == depth = d - | n > depth = DmdType fv inc_ds div + | n > depth = d{dt_args = inc_ds} | otherwise = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d) - where depth = dmdTypeDepth d - DmdType fv ds div = d + where depth = length ds -- Arity increase: -- * Demands on FVs are still valid -- * Demands on args also valid, plus we can extend with defaultArgDmd @@ -1254,26 +1135,41 @@ etaExpandDmdType n d -- * 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 div)) -- | A conservative approximation for a given 'DmdType' in case of an arity -- decrease. Currently, it's just nopDmdType. decreaseArityDmdType :: DmdType -> DmdType decreaseArityDmdType _ = nopDmdType -seqDmdType :: DmdType -> () -seqDmdType (DmdType env ds res) = - seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () - -seqDmdEnv :: DmdEnv -> () -seqDmdEnv env = seqEltsUFM seqDemandList env - splitDmdTy :: DmdType -> (Demand, DmdType) -- Split off one function argument -- We already have a suitable demand on all -- free vars, so no need to add more! -splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) -splitDmdTy ty@(DmdType _ [] res_ty) = (defaultArgDmd res_ty, ty) +splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args}) +splitDmdTy ty@DmdType{dt_div=div} = (defaultArgDmd div, ty) + +multDmdType :: Card -> DmdType -> DmdType +multDmdType n (DmdType fv args res_ty) + = -- 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) + where + fv' = fv `delVarEnv` id + -- See Note [Default demand on free variables and arguments] + dmd = lookupVarEnv fv id `orElse` defaultFvDmd res + +addDemand :: Demand -> DmdType -> DmdType +addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res + +findIdDemand :: DmdType -> Var -> Demand +findIdDemand (DmdType fv _ res) id + = lookupVarEnv fv id `orElse` defaultFvDmd res -- | 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 @@ -1288,129 +1184,64 @@ splitDmdTy ty@(DmdType _ [] res_ty) = (defaultArgDmd res_ty, ty) deferAfterPreciseException :: DmdType -> DmdType deferAfterPreciseException = lubDmdType exnDmdType -strictenDmd :: Demand -> Demand -strictenDmd (JD { sd = s, ud = u}) - = JD { sd = poke_s s, ud = poke_u u } - where - poke_s Lazy = Str HeadStr - poke_s s = s - poke_u Abs = useTop - poke_u u = u - --- Deferring and peeling - -type DmdShell -- Describes the "outer shell" - -- of a Demand - = JointDmd (Str ()) (Use ()) - -toCleanDmd :: Demand -> (DmdShell, CleanDemand) --- Splits a Demand into its "shell" and the inner "clean demand" -toCleanDmd (JD { sd = s, ud = u }) - = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) - -- See Note [Analyzing with lazy demand and lambdas] - -- See Note [Analysing with absent demand] - where - (ss, s') = case s of - Str s' -> (Str (), s') - Lazy -> (Lazy, HeadStr) - - (us, u') = case u of - Use c u' -> (Use c (), u') - Abs -> (Abs, Used) - --- This is used in dmdAnalStar when post-processing --- a function's argument demand. So we only care about what --- does to free variables, and whether it terminates. --- see Note [Asymmetry of 'both*'] -postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg -postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) - = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty) - -postProcessDivergence :: Str () -> Divergence -> Divergence --- In a Lazy scenario, we might not force the Divergence, in which case we --- converge, hence Dunno. -postProcessDivergence Lazy _ = Dunno -postProcessDivergence _ d = d - -postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv -postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env - | Abs <- us = emptyDmdEnv - -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild - -- of the environment. Be careful, bad things will happen if this doesn't - -- match postProcessDmd (see #13977). - | Str _ <- ss - , Use One _ <- us = env - | otherwise = mapVarEnv (postProcessDmd ds) env - -- For the Absent case just discard all usage information - -- We only processed the thing at all to analyse the body - -- See Note [Always analyse in virgin pass] +{- +Note [Demand type Divergence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In contrast to StrictSigs, DmdTypes are elicited under a specific incoming demand. +This is described in detail in Note [Understanding DmdType and StrictSig]. +Here, we'll focus on what that means for a DmdType's Divergence in a higher-order +scenario. -reuseEnv :: DmdEnv -> DmdEnv -reuseEnv = mapVarEnv (postProcessDmd - (JD { sd = Str (), ud = Use Many () })) - -postProcessUnsat :: DmdShell -> DmdType -> DmdType -postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) - = DmdType (postProcessDmdEnv ds fv) - (map (postProcessDmd ds) args) - (postProcessDivergence ss res_ty) - -postProcessDmd :: DmdShell -> Demand -> Demand -postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) - = JD { sd = s', ud = a' } - where - s' = case ss of - Lazy -> Lazy - Str _ -> s - a' = case us of - Abs -> Abs - Use Many _ -> markReusedDmd a - Use One _ -> a - --- Peels one call level from the demand, and also returns --- whether it was unsaturated (separately for strictness and usage) -peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) --- Exploiting the fact that --- on the strictness side C(B) = B --- and on the usage side C(U) = U -peelCallDmd (JD {sd = s, ud = u}) - = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) - where - (s', ss) = case s of - SCall s' -> (s', Str ()) - HyperStr -> (HyperStr, Str ()) - _ -> (HeadStr, Lazy) - (u', us) = case u of - UCall c u' -> (u', Use c ()) - _ -> (Used, Use Many ()) - -- The _ cases for usage includes UHead which seems a bit wrong - -- because the body isn't used at all! - -- c.f. the Abs case in toCleanDmd - --- Peels that multiple nestings of calls clean demand and also returns --- whether it was unsaturated (separately for strictness and usage --- see Note [Demands from unsaturated function calls] -peelManyCalls :: Int -> CleanDemand -> DmdShell -peelManyCalls n (JD { sd = str, ud = abs }) - = JD { sd = go_str n str, ud = go_abs n abs } - where - go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer - go_str 0 _ = Str () - go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) - go_str n (SCall d') = go_str (n-1) d' - go_str _ _ = Lazy +Consider + err x y = x `seq` y `seq` error (show x) +this has a strictness signature of + <SU><SU>b +meaning that we don't know what happens when we call err in weaker contexts than +CS(CS(U)), like @err `seq` ()@ (SU) and @err 1 `seq` ()@ (CS(U)). We +may not unleash the botDiv, hence assume topDiv. Of course, in +@err 1 2 `seq` ()@ the incoming demand CS(CS(S)) is strong enough and we see +that the expression diverges. + +Now consider a function + f g = g 1 2 +with signature <CS(CS(U))>, and the expression + f err `seq` () +now f puts a strictness demand of CS(CS(U)) onto its argument, which is unleashed +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! - go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least - go_abs 0 _ = Use One () -- one UCall Many in the demand - go_abs n (UCall One d') = go_abs (n-1) d' - go_abs _ _ = Use Many () +Note [Asymmetry of 'plus*'] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'plus' for DmdTypes is *asymmetrical*, because there can only one +be one type contributing argument demands! For example, given (e1 e2), we get +a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do +(dt1 `plusType` dt2). Similarly with + case e of { p -> rhs } +we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then +compute (dt_rhs `plusType` dt_scrut). + +We + 1. combine the information on the free variables, + 2. take the demand on arguments from the first argument + 3. combine the termination results, as in plusDivergence. + +Since we don't use argument demands of the second argument anyway, 'plus's +second argument is just a 'PlusDmdType'. + +But note that the argument demand types are not guaranteed to be observed in +left to right order. For example, analysis of a case expression will pass the +demand type for the alts as the left argument and the type for the scrutinee as +the right argument. Also, it is not at all clear if there is such an order; +consider the LetUp case, where the RHS might be forced at any point while +evaluating the let body. +Therefore, it is crucial that 'plusDivergence' is symmetric! -{- Note [Demands from unsaturated function calls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a demand transformer d1 -> d2 -> r for f. If a sufficiently detailed demand is fed into this transformer, -e.g <C(C(S)), C1(C1(S))> arising from "f x1 x2" in a strict, use-once context, +e.g <CS(CS(U))> arising from "f x1 x2" in a strict, use-once context, then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for the free variable environment) and furthermore the result information r is the one we want to use. @@ -1418,138 +1249,39 @@ one we want to use. An anonymous lambda is also an unsaturated function all (needs one argument, none given), so this applies to that case as well. -But the demand fed into f might be less than <C(C(S)), C1(C1(S))>. There are a few cases: - * Not enough demand on the strictness side: - - In that case, we need to zap all strictness in the demand on arguments and - free variables. - - And finally Divergence information: If r says that f Diverges for sure, +But the demand fed into f might be less than CS(CS(U)). Then we have to +'multDmdType' the announced demand type. Examples: + * Not strict enough, e.g. C1(C1(U)): + - We have to multiply all argument and free variable demands with C_01, + zapping strictness. + - We have to multiply divergence with C_01. If r says that f Diverges for sure, then this holds when the demand guarantees that two arguments are going to be passed. If the demand is lower, we may just as well converge. If we were tracking definite convegence, than that would still hold under a weaker demand than expected by the demand transformer. - * Not enough demand from the usage side: The missing usage can be expanded - using UCall Many, therefore this is subsumed by the third case: - * At least one of the uses has a cardinality of Many. - - Even if f puts a One demand on any of its argument or free variables, if - we call f multiple times, we may evaluate this argument or free variable - multiple times. So forget about any occurrence of "One" in the demand. + * Used more than once, e.g. CM(CS(U)): + - Multiply with C_1N. Even if f puts a used-once demand on any of its argument + or free variables, if we call f multiple times, we may evaluate this + argument or free variable multiple times. -In dmdTransformSig, we call peelManyCalls to find out if we are in any of these -cases, and then call postProcessUnsat to reduce the demand appropriately. +In dmdTransformSig, we call peelManyCalls to find out the 'Card'inality with +which we have to multiply and then call multDmdType with that. Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use peelCallDmd, which peels only one level, but also returns the demand put on the body of the function. -} -peelFV :: DmdType -> Var -> (DmdType, Demand) -peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) - (DmdType fv' ds res, dmd) - where - fv' = fv `delVarEnv` id - -- See Note [Default demand on free variables and arguments] - dmd = lookupVarEnv fv id `orElse` defaultFvDmd res - -addDemand :: Demand -> DmdType -> DmdType -addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res - -findIdDemand :: DmdType -> Var -> Demand -findIdDemand (DmdType fv _ res) id - = lookupVarEnv fv id `orElse` defaultFvDmd res {- -Note [Always analyse in virgin pass] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tricky point: make sure that we analyse in the 'virgin' pass. Consider - rec { f acc x True = f (...rec { g y = ...g... }...) - f acc x False = acc } -In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. -That might mean that we analyse the sub-expression containing the -E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* -E, but just returned botType. - -Then in the *next* (non-virgin) iteration for 'f', we might analyse E -in a weaker demand, and that will trigger doing a fixpoint iteration -for g. But *because it's not the virgin pass* we won't start g's -iteration at bottom. Disaster. (This happened in $sfibToList' of -nofib/spectral/fibheaps.) - -So in the virgin pass we make sure that we do analyse the expression -at least once, to initialise its signatures. - -Note [Analyzing with lazy demand and lambdas] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The insight for analyzing lambdas follows from the fact that for -strictness S = C(L). This polymorphic expansion is critical for -cardinality analysis of the following example: - -{-# NOINLINE build #-} -build g = (g (:) [], g (:) []) - -h c z = build (\x -> - let z1 = z ++ z - in if c - then \y -> x (y ++ z1) - else \y -> x (z1 ++ y)) - -One can see that `build` assigns to `g` demand <L,C(C1(U))>. -Therefore, when analyzing the lambda `(\x -> ...)`, we -expect each lambda \y -> ... to be annotated as "one-shot" -one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a -demand <C(C(..), C(C1(U))>. - -This is achieved by, first, converting the lazy demand L into the -strict S by the second clause of the analysis. - -Note [Analysing with absent demand] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose we analyse an expression with demand <L,A>. The "A" means -"absent", so this expression will never be needed. What should happen? -There are several wrinkles: - -* We *do* want to analyse the expression regardless. - Reason: Note [Always analyse in virgin pass] - - But we can post-process the results to ignore all the usage - demands coming back. This is done by postProcessDmdType. - -* In a previous incarnation of GHC we needed to be extra careful in the - case of an *unlifted type*, because unlifted values are evaluated - even if they are not used. Example (see #9254): - f :: (() -> (# Int#, () #)) -> () - -- Strictness signature is - -- <C(S(LS)), 1*C1(U(A,1*U()))> - -- I.e. calls k, but discards first component of result - f k = case k () of (# _, r #) -> r - - g :: Int -> () - g y = f (\n -> (# case y of I# y2 -> y2, n #)) - - Here f's strictness signature says (correctly) that it calls its - argument function and ignores the first component of its result. - This is correct in the sense that it'd be fine to (say) modify the - function so that always returned 0# in the first component. - - But in function g, we *will* evaluate the 'case y of ...', because - it has type Int#. So 'y' will be evaluated. So we must record this - usage of 'y', else 'g' will say 'y' is absent, and will w/w so that - 'y' is bound to an aBSENT_ERROR thunk. - - However, the argument of toCleanDmd always satisfies the let/app - invariant; so if it is unlifted it is also okForSpeculation, and so - can be evaluated in a short finite time -- and that rules out nasty - cases like the one above. (I'm not quite sure why this was a - problem in an earlier version of GHC, but it isn't now.) --} - -{- ********************************************************************* +************************************************************************ * * Demand signatures * * ************************************************************************ -In a let-bound Id we record its strictness info. -In principle, this strictness info is a demand transformer, mapping +In a let-bound Id we record its demand signature. +In principle, this demand signature is a demand transformer, mapping a demand on the Id into a DmdType, which gives a) the free vars of the Id's value b) the Id's arguments @@ -1574,13 +1306,13 @@ demand on all arguments. Otherwise, the demand is specified by Id's signature. For example, the demand transformer described by the demand signature - StrictSig (DmdType {x -> <S,1*U>} <L,A><L,U(U,U)>m) + StrictSig (DmdType {x -> <S,1*U>} <L,A><C_,(U,U)>m) says that when the function is applied to two arguments, it unleashes demand <S,1*U> on the free var x, <L,A> on the first arg, -and <L,U(U,U)> on the second, then returning a constructor. +and <C_,(U,U)> on the second, then returning a constructor. If this same function is applied to one arg, all we can say is that it -uses x with <L,U>, and its arg with demand <L,U>. +uses x with <C_,>, and its arg with demand <C_,>. Note [Understanding DmdType and StrictSig] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1594,11 +1326,11 @@ Here is a table with demand types resulting from different incoming demands we put that expression under. Note the monotonicity; a stronger incoming demand yields a more precise demand type: - incoming demand | demand type - ---------------------------------------------------- - <S ,HU > | <L,U><L,U>{} - <C(C(S )),C1(C1(U ))> | <S,U><L,U>{} - <C(C(S(S,L))),C1(C1(U(1*U,A)))> | <S,1*HU><L,A>{} + incoming demand | demand type + -------------------------------- + SA | <U><U>{} + CS(CS(U)) | <SP(U)><U>{} + CS(CS(SP(SP(U),A))) | <SP(A)><A>{} Note that in the first example, the depth of the demand type was *higher* than the arity of the incoming call demand due to the anonymous lambda. @@ -1622,22 +1354,15 @@ Here comes the subtle part: The threshold is encoded in the wrapped demand type's depth! So in mkStrictSigForArity we make sure to trim the list of argument demands to the given threshold arity. Call sites will make sure that this corresponds to the arity of the call demand that elicited the wrapped -demand type. See also Note [What are demand signatures?] in GHC.Core.Opt.DmdAnal. +demand type. See also Note [What are demand signatures?]. -} -- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe -- to unleash. Better construct this through 'mkStrictSigForArity'. -- See Note [Understanding DmdType and StrictSig] -newtype StrictSig = StrictSig DmdType - deriving( Eq ) - -instance Outputable StrictSig where - ppr (StrictSig ty) = ppr ty - --- Used for printing top-level strictness pragmas in interface files -pprIfaceStrictSig :: StrictSig -> SDoc -pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) - = hcat (map ppr dmds) <> ppr res +newtype StrictSig + = StrictSig DmdType + deriving Eq -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig' -- unleashable at that arity. See Note [Understanding DmdType and StrictSig] @@ -1652,6 +1377,37 @@ mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv splitStrictSig :: StrictSig -> ([Demand], Divergence) splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) +strictSigDmdEnv :: StrictSig -> DmdEnv +strictSigDmdEnv (StrictSig (DmdType env _ _)) = env + +hasDemandEnvSig :: StrictSig -> Bool +hasDemandEnvSig = not . isEmptyVarEnv . strictSigDmdEnv + +botSig :: StrictSig +botSig = StrictSig botDmdType + +nopSig :: StrictSig +nopSig = StrictSig nopDmdType + +isTopSig :: StrictSig -> Bool +isTopSig (StrictSig ty) = isTopDmdType ty + +-- | True if the signature diverges or throws an exception in a saturated call. +-- See Note [Dead ends]. +isDeadEndSig :: StrictSig -> Bool +isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res + +-- | Returns true if an application to n args would diverge or throw an +-- exception. +-- +-- If a function having 'botDiv' is applied to a less number of arguments than +-- its syntactic arity, we cannot say for sure that it is going to diverge. +-- Hence this function conservatively returns False in that case. +-- See Note [Dead ends]. +appIsDeadEnd :: StrictSig -> Int -> Bool +appIsDeadEnd (StrictSig (DmdType _ ds res)) n + = isDeadEndDiv res && not (lengthExceeds ds n) + prependArgsStrictSig :: Int -> StrictSig -> StrictSig -- ^ Add extra ('topDmd') arguments to a strictness signature. -- In contrast to 'etaConvertStrictSig', this /prepends/ additional argument @@ -1680,87 +1436,127 @@ etaConvertStrictSig arity (StrictSig dmd_ty) | arity < dmdTypeDepth dmd_ty = StrictSig $ decreaseArityDmdType dmd_ty | otherwise = StrictSig $ etaExpandDmdType arity dmd_ty -isTopSig :: StrictSig -> Bool -isTopSig (StrictSig ty) = isTopDmdType ty - -hasDemandEnvSig :: StrictSig -> Bool -hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) - -strictSigDmdEnv :: StrictSig -> DmdEnv -strictSigDmdEnv (StrictSig (DmdType env _ _)) = env - --- | True if the signature diverges or throws an exception in a saturated call. --- See Note [Dead ends]. -isDeadEndSig :: StrictSig -> Bool -isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res - -botSig :: StrictSig -botSig = StrictSig botDmdType - -nopSig :: StrictSig -nopSig = StrictSig nopDmdType +{- +************************************************************************ +* * + Demand transformers +* * +************************************************************************ +-} -seqStrictSig :: StrictSig -> () -seqStrictSig (StrictSig ty) = seqDmdType ty +-- | A /demand transformer/ is a monotone function from an incoming evaluation +-- context ('SubDemand') to a 'DmdType', describing how the denoted thing +-- (i.e. expression, function) uses its arguments and free variables, and +-- whether it diverges. +-- +-- See Note [Understanding DmdType and StrictSig] +-- and Note [What are demand signatures?]. +type DmdTransformer = SubDemand -> DmdType -dmdTransformSig :: StrictSig -> CleanDemand -> DmdType --- (dmdTransformSig fun_sig dmd) considers a call to a function whose --- signature is fun_sig, with demand dmd. We return the demand --- that the function places on its context (eg its args) -dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd - = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty +-- | Extrapolate a demand signature ('StrictSig') into a 'DmdTransformer'. +-- +-- Given a function's 'StrictSig' and a 'SubDemand' for the evaluation context, +-- return how the function evaluates its free variables and arguments. +dmdTransformSig :: StrictSig -> DmdTransformer +dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) sd + = multDmdType (peelManyCalls (length arg_ds) sd) dmd_ty -- see Note [Demands from unsaturated function calls] - -dmdTransformDataConSig :: Arity -> CleanDemand -> DmdType --- Same as dmdTransformSig but for a data constructor (worker), --- which has a special kind of demand transformer. --- If the constructor is saturated, we feed the demand on --- the result into the constructor arguments. -dmdTransformDataConSig arity (JD { sd = str, ud = abs }) - | Just str_dmds <- go_str arity str - , Just abs_dmds <- go_abs arity abs - = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) topDiv - - | otherwise -- Not saturated - = nopDmdType + -- and Note [What are demand signatures?] + +-- | A special 'DmdTransformer' for data constructors that feeds product +-- demands into the constructor arguments. +dmdTransformDataConSig :: Arity -> DmdTransformer +dmdTransformDataConSig arity sd = case go arity sd of + Just dmds -> DmdType emptyDmdEnv dmds topDiv + Nothing -> nopDmdType -- Not saturated where - go_str 0 dmd = splitStrProdDmd arity dmd - go_str n (SCall s') = go_str (n-1) s' - go_str n HyperStr = go_str (n-1) HyperStr - go_str _ _ = Nothing - - go_abs 0 dmd = splitUseProdDmd arity dmd - go_abs n (UCall One u') = go_abs (n-1) u' - go_abs _ _ = Nothing - -dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType --- Like dmdTransformDataConSig, we have a special demand transformer --- for dictionary selectors. If the selector is saturated (ie has one --- argument: the dictionary), we feed the demand on the result into --- the indicated dictionary component. -dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd - | (cd',defer_use) <- peelCallDmd cd - , Just jds <- splitProdDmd_maybe dict_dmd - = postProcessUnsat defer_use $ - DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv + go 0 sd = viewProd arity sd + go n (viewCall -> Just (C_11, sd)) = go (n-1) sd -- strict calls only! + go _ _ = Nothing + +-- | A special 'DmdTransformer' for dictionary selectors that feeds the demand +-- on the result into the indicated dictionary component (if saturated). +dmdTransformDictSelSig :: StrictSig -> DmdTransformer +-- NB: This currently doesn't handle newtype dictionaries and it's unclear how +-- it could without additional parameters. +dmdTransformDictSelSig (StrictSig (DmdType _ [(_ :* sig_sd)] _)) call_sd + | (n, sd') <- peelCallDmd call_sd + , Prod sig_ds <- sig_sd + = multDmdType n $ + DmdType emptyDmdEnv [C_11 :* Prod (map (enhance sd') sig_ds)] topDiv | otherwise = nopDmdType -- See Note [Demand transformer for a dictionary selector] where - enhance cd old | isAbsDmd old = old - | otherwise = mkOnceUsedDmd cd -- This is the one! + enhance sd old | isAbsDmd old = old + | otherwise = C_11 :* sd -- This is the one! -dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" +dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd) {- +Note [What are demand signatures?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Demand analysis interprets expressions in the abstract domain of demand +transformers. Given a (sub-)demand that denotes the evaluation context, the +abstract transformer of an expression gives us back a demand type denoting +how other things (like arguments and free vars) were used when the expression +was evaluated. Here's an example: + + f x y = + if x + expensive + then \z -> z + y * ... + else \z -> z * ... + +The abstract transformer (let's call it F_e) of the if expression (let's +call it e) would transform an incoming (undersaturated!) head demand SA into +a demand type like {x-><SU>,y-><U>}<U>. In pictures: + + Demand ---F_e---> DmdType + <SA> {x-><SU>,y-><U>}<U> + +Let's assume that the demand transformers we compute for an expression are +correct wrt. to some concrete semantics for Core. How do demand signatures fit +in? They are strange beasts, given that they come with strict rules when to +it's sound to unleash them. + +Fortunately, we can formalise the rules with Galois connections. Consider +f's strictness signature, {}<SU><U>. It's a single-point approximation of +the actual abstract transformer of f's RHS for arity 2. So, what happens is that +we abstract *once more* from the abstract domain we already are in, replacing +the incoming Demand by a simple lattice with two elements denoting incoming +arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom +element). Here's the diagram: + + A_2 -----f_f----> DmdType + ^ | + | α γ | + | v + SubDemand --F_f----> DmdType + +With + α(CS(CS(_))) = >=2 + α(_) = <2 + γ(ty) = ty +and F_f being the abstract transformer of f's RHS and f_f being the abstracted +abstract transformer computable from our demand signature simply by + + f_f(>=2) = {}<S,1*U><L,U> + f_f(<2) = multDmdType C_0N {}<S,1*U><L,U> + +where multDmdType makes a proper top element out of the given demand type. + +In practice, the A_n domain is not just a simple Bool, but a Card, which is +exactly the Card with which we have to multDmdType. The Card for arity n +is computed by calling @peelManyCalls n@, which corresponds to α above. + Note [Demand transformer for a dictionary selector] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' into the appropriate field of the dictionary. What *is* the appropriate field? We just look at the strictness signature of the class op, which will be -something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. +something like: UP(AAASAAAAA). Then replace the 'S' by the demand 'd'. For single-method classes, which are represented by newtypes the signature -of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. +of 'op' won't look like UP(...), so matching on Prod will fail. That's fine: if we are doing strictness analysis we are also doing inlining, so we'll have inlined 'op' into a cast. So we can bale out in a conservative way, returning nopDmdType. @@ -1775,75 +1571,6 @@ This is weird, so I'm not worried about whether this optimises brilliantly; but it should not fall over. -} -argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] --- See Note [Computing one-shot info] -argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args - | unsaturated_call = [] - | otherwise = go arg_ds - where - unsaturated_call = arg_ds `lengthExceeds` n_val_args - - go [] = [] - go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds - - -- Avoid list tail like [ [], [], [] ] - cons [] [] = [] - cons a as = a:as - --- saturatedByOneShots n C1(C1(...)) = True, --- <=> --- there are at least n nested C1(..) calls --- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap -saturatedByOneShots :: Int -> Demand -> Bool -saturatedByOneShots n (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go n arg_usg - _ -> False - where - go 0 _ = True - go n (UCall One u) = go (n-1) u - go _ _ = False - -argOneShots :: Demand -- depending on saturation - -> [OneShotInfo] -argOneShots (JD { ud = usg }) - = case usg of - Use _ arg_usg -> go arg_usg - _ -> [] - where - go (UCall One u) = OneShotLam : go u - go (UCall Many u) = NoOneShotInfo : go u - go _ = [] - -{- Note [Computing one-shot info] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider a call - f (\pqr. e1) (\xyz. e2) e3 -where f has usage signature - C1(C(C1(U))) C1(U) U -Then argsOneShots returns a [[OneShotInfo]] of - [[OneShot,NoOneShotInfo,OneShot], [OneShot]] -The occurrence analyser propagates this one-shot infor to the -binders \pqr and \xyz; see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal". --} - --- | Returns true if an application to n args would diverge or throw an --- exception. See Note [Unsaturated applications] and Note [Dead ends]. -appIsDeadEnd :: StrictSig -> Int -> Bool -appIsDeadEnd (StrictSig (DmdType _ ds res)) n - = isDeadEndDiv res && not (lengthExceeds ds n) - -{- -Note [Unsaturated applications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -If a function having bottom as its demand result is applied to a less -number of arguments than its syntactic arity, we cannot say for sure -that it is going to diverge. This is the reason why we use the -function appIsDeadEnd, which, given a strictness signature and a number -of arguments, says conservatively if the function is never going to return. -See Note [Dead ends]. --} - zapUsageEnvSig :: StrictSig -> StrictSig -- Remove the usage environment from the demand zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r @@ -1876,182 +1603,228 @@ data KillFlags = KillFlags , kf_called_once :: Bool } +kill_usage_card :: KillFlags -> Card -> Card +kill_usage_card kfs C_00 | kf_abs kfs = C_0N +kill_usage_card kfs C_10 | kf_abs kfs = C_1N +kill_usage_card kfs C_01 | kf_used_once kfs = C_0N +kill_usage_card kfs C_11 | kf_used_once kfs = C_1N +kill_usage_card _ n = n + kill_usage :: KillFlags -> Demand -> Demand -kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} - -zap_musg :: KillFlags -> ArgUse -> ArgUse -zap_musg kfs Abs - | kf_abs kfs = useTop - | otherwise = Abs -zap_musg kfs (Use c u) - | kf_used_once kfs = Use Many (zap_usg kfs u) - | otherwise = Use c (zap_usg kfs u) - -zap_usg :: KillFlags -> UseDmd -> UseDmd -zap_usg kfs (UCall c u) - | kf_called_once kfs = UCall Many (zap_usg kfs u) - | otherwise = UCall c (zap_usg kfs u) -zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) -zap_usg _ u = u - --- If the argument is a used non-newtype dictionary, give it strict --- demand. Also split the product type & demand and recur in order to --- similarly strictify the argument's contained used non-newtype --- superclass dictionaries. We use the demand as our recursive measure --- to guarantee termination. -strictifyDictDmd :: Type -> Demand -> Demand -strictifyDictDmd ty dmd = case getUseDmd dmd of - Use n _ | - Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) - <- splitDataProductType_maybe ty, - not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary - -> seqDmd `bothDmd` -- main idea: ensure it's strict - case splitProdDmd_maybe dmd of - -- superclass cycles should not be a problem, since the demand we are - -- consuming would also have to be infinite in order for us to diverge - Nothing -> dmd -- no components have interesting demand, so stop - -- looking for superclass dicts - Just dmds - | all (not . isAbsDmd) dmds -> evalDmd - -- abstract to strict w/ arbitrary component use, since this - -- smells like reboxing; results in CBV boxed - -- - -- TODO revisit this if we ever do boxity analysis - | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd (map scaledThing inst_con_arg_tys) dmds of - JD {sd = s,ud = a} -> JD (Str s) (Use n a) - -- TODO could optimize with an aborting variant of zipWith since - -- the superclass dicts are always a prefix - _ -> dmd -- unused or not a dictionary +kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd -strictifyDmd :: Demand -> Demand -strictifyDmd dmd@(JD { sd = str }) - = dmd { sd = str `bothArgStr` Str HeadStr } +kill_usage_sd :: KillFlags -> SubDemand -> SubDemand +kill_usage_sd kfs (Call n sd) + | kf_called_once kfs = Call (lubCard C_1N n) (kill_usage_sd kfs sd) + | otherwise = Call n (kill_usage_sd kfs sd) +kill_usage_sd kfs (Prod ds) = Prod (map (kill_usage kfs) ds) +kill_usage_sd _ sd = sd + +{- ********************************************************************* +* * + TypeShape and demand trimming +* * +********************************************************************* -} + + +data TypeShape -- See Note [Trimming a demand to a type] + -- in GHC.Core.Opt.DmdAnal + = TsFun TypeShape + | TsProd [TypeShape] + | TsUnk + +trimToType :: Demand -> TypeShape -> Demand +-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal +trimToType (n :* sd) ts + = n :* go sd ts + where + go (Prod ds) (TsProd tss) + | equalLength ds tss = Prod (zipWith trimToType ds tss) + go (Call n sd) (TsFun ts) = Call n (go sd ts) + go sd@Poly{} _ = sd + go _ _ = topSubDmd {- -Note [HyperStr and Use demands] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +************************************************************************ +* * + 'seq'ing demands +* * +************************************************************************ +-} + +seqDemand :: Demand -> () +seqDemand (_ :* sd) = seqSubDemand sd -The information "HyperStr" needs to be in the strictness signature, and not in -the demand signature, because we still want to know about the demand on things. Consider +seqSubDemand :: SubDemand -> () +seqSubDemand (Prod ds) = seqDemandList ds +seqSubDemand (Call _ sd) = seqSubDemand sd +seqSubDemand (Poly _) = () - f (x,y) True = error (show x) - f (x,y) False = x+1 +seqDemandList :: [Demand] -> () +seqDemandList = foldr (seq . seqDemand) () -The signature of f should be <S(SL),1*U(1*U(U),A)><S,1*U>m. If we were not -distinguishing the uses on x and y in the True case, we could either not figure -out how deeply we can unpack x, or that we do not have to pass y. +seqDmdType :: DmdType -> () +seqDmdType (DmdType env ds res) = + seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () + +seqDmdEnv :: DmdEnv -> () +seqDmdEnv env = seqEltsUFM seqDemandList env +seqStrictSig :: StrictSig -> () +seqStrictSig (StrictSig ty) = seqDmdType ty +{- ************************************************************************ * * - Serialisation + Outputable and Binary instances * * ************************************************************************ -} -instance Binary StrDmd where - put_ bh HyperStr = putByte bh 0 - put_ bh HeadStr = putByte bh 1 - put_ bh (SCall s) = do putByte bh 2 - put_ bh s - put_ bh (SProd sx) = do putByte bh 3 - put_ bh sx +{- Note [Demand notation] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note should be kept up to date with the documentation of `-fstrictness` +in the user's guide. + +For pretty-printing demands, we use quite a compact notation with some +abbreviations. Here's the BNF: + + card ::= B | A | 1 | U | S | M {}, {0}, {0,1}, {0,1,n}, {1}, {1,n} + + d ::= card sd The :* constructor, just juxtaposition + | card abbreviation: Same as "card card", + in code @polyDmd card@ + + sd ::= card @Poly card@ + | P(d,d,..) @Prod [d1,d2,..]@ + | Ccard(sd) @Call card sd@ + +So, U can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand', +but it's always clear from context which "overload" is meant. It's like +return-type inference of e.g. 'read'. + +Examples are in the haddock for 'Demand'. + +This is the syntax for demand signatures: + + div ::= <empty> topDiv + | x exnDiv + | b botDiv + + sig ::= {x->dx,y->dy,z->dz...}<d1><d2><d3>...<dn>div + ^ ^ ^ ^ ^ ^ + | | | | | | + | \---+---+------/ | + | | | + demand on free demand on divergence + variables arguments information + (omitted if empty) (omitted if + no information) + + +-} + +-- | See Note [Demand notation] +instance Outputable Card where + ppr C_00 = char 'A' + ppr C_01 = char '1' + ppr C_0N = char 'U' + ppr C_11 = char 'S' + ppr C_1N = char 'M' + ppr C_10 = char 'B' + +-- | See Note [Demand notation] +instance Outputable Demand where + ppr dmd@(n :* sd) + | isAbs n = ppr n -- If absent, sd is arbitrary + | dmd == polyDmd n = ppr n -- Print UU as just U + | otherwise = ppr n <> ppr sd + +-- | See Note [Demand notation] +instance Outputable SubDemand where + ppr (Poly sd) = ppr sd + ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd) + ppr (Prod ds) = char 'P' <> parens (fields ds) + where + fields [] = empty + fields [x] = ppr x + fields (x:xs) = ppr x <> char ',' <> fields xs + +instance Outputable Divergence where + ppr Diverges = char 'b' -- for (b)ottom + 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))] + where + pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + fv_elts = nonDetUFMToList fv + -- It's OK to use nonDetUFMToList here because we only do it for + -- pretty printing + +instance Outputable StrictSig where + ppr (StrictSig ty) = ppr ty + +instance Outputable TypeShape where + ppr TsUnk = text "TsUnk" + ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) + ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) + +instance Binary Card where + put_ bh C_00 = putByte bh 0 + put_ bh C_01 = putByte bh 1 + put_ bh C_0N = putByte bh 2 + put_ bh C_11 = putByte bh 3 + put_ bh C_1N = putByte bh 4 + put_ bh C_10 = putByte bh 5 + get bh = do + h <- getByte bh + case h of + 0 -> return C_00 + 1 -> return C_01 + 2 -> return C_0N + 3 -> return C_11 + 4 -> return C_1N + 5 -> return C_10 + _ -> pprPanic "Binary:Card" (ppr (fromIntegral h :: Int)) + +instance Binary Demand where + put_ bh (n :* sd) = put_ bh n *> put_ bh sd + get bh = (:*) <$> get bh <*> get bh + +instance Binary SubDemand where + put_ bh (Poly sd) = putByte bh 0 *> put_ bh sd + put_ bh (Call n sd) = putByte bh 1 *> put_ bh n *> put_ bh sd + put_ bh (Prod ds) = putByte bh 2 *> put_ bh ds get bh = do - h <- getByte bh - case h of - 0 -> return HyperStr - 1 -> return HeadStr - 2 -> do s <- get bh - return (SCall s) - _ -> do sx <- get bh - return (SProd sx) - -instance Binary ArgStr where - put_ bh Lazy = - putByte bh 0 - put_ bh (Str s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh - case h of - 0 -> return Lazy - _ -> do s <- get bh - return $ Str s - -instance Binary Count where - put_ bh One = putByte bh 0 - put_ bh Many = putByte bh 1 - - get bh = do h <- getByte bh - case h of - 0 -> return One - _ -> return Many - -instance Binary ArgUse where - put_ bh Abs = - putByte bh 0 - put_ bh (Use c u) = do - putByte bh 1 - put_ bh c - put_ bh u - - get bh = do - h <- getByte bh - case h of - 0 -> return Abs - _ -> Use <$> get bh <*> get bh - -instance Binary UseDmd where - put_ bh Used = - putByte bh 0 - put_ bh UHead = - putByte bh 1 - put_ bh (UCall c u) = do - putByte bh 2 - put_ bh c - put_ bh u - put_ bh (UProd ux) = do - putByte bh 3 - put_ bh ux - - get bh = do - h <- getByte bh - case h of - 0 -> return $ Used - 1 -> return $ UHead - 2 -> do c <- get bh - u <- get bh - return (UCall c u) - _ -> do ux <- get bh - return (UProd ux) - -instance (Binary s, Binary u) => Binary (JointDmd s u) where - put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y - get bh = JD <$> get bh <*> get bh + h <- getByte bh + case h of + 0 -> Poly <$> get bh + 1 -> Call <$> get bh <*> get bh + 2 -> Prod <$> get bh + _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) instance Binary StrictSig where - put_ bh (StrictSig aa) = put_ bh aa - get bh = StrictSig <$> get bh + put_ bh (StrictSig aa) = put_ bh aa + get bh = StrictSig <$> get bh instance Binary DmdType where -- Ignore DmdEnv when spitting out the DmdType - put_ bh (DmdType _ ds dr) - = do put_ bh ds - put_ bh dr - get bh - = do ds <- get bh - dr <- get bh - return (DmdType emptyDmdEnv ds dr) + 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 put_ bh Diverges = putByte bh 2 - - get bh = do { h <- getByte bh - ; case h of - 0 -> return Dunno - 1 -> return ExnOrDiv - _ -> return Diverges } + get bh = do + h <- getByte bh + case h of + 0 -> return Dunno + 1 -> return ExnOrDiv + 2 -> return Diverges + _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int)) diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs index 4727ce443d..b0c83ce8b2 100644 --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -704,7 +704,7 @@ isStrictId id not (isJoinId id) && ( (isStrictType (idType id)) || -- Take the best of both strictnesses - old and new - (isStrictDmd (idDemandInfo id)) + (isStrUsedDmd (idDemandInfo id)) ) --------------------------------- diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index 028a277a42..6620e23cad 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -636,7 +636,7 @@ zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) -> occ { occ_tail = NoTailCallInfo } _other -> occ - is_safe_dmd dmd = not (isStrictDmd dmd) + is_safe_dmd dmd = not (isStrUsedDmd dmd) -- | Remove all demand info on the 'IdInfo' zapDemandInfo :: IdInfo -> Maybe IdInfo diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 7a0990ee48..9aa91e3017 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -515,9 +515,9 @@ mkDictSelId name clas strict_sig = mkClosedStrictSig [arg_dmd] topDiv arg_dmd | new_tycon = evalDmd - | otherwise = mkManyUsedDmd $ - mkProdDmd [ if name == sel_name then evalDmd else absDmd - | sel_name <- sel_names ] + | otherwise = C_1N :* + Prod [ if name == sel_name then evalDmd else absDmd + | sel_name <- sel_names ] mkDictSelRhs :: Class -> Int -- 0-indexed selector among (superclasses ++ methods) diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 16e66ce6d1..3698c5a4b2 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -35,6 +35,7 @@ module GHC.Utils.Outputable ( doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, vbar, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, + lambda, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, mulArrow, blankLine, forAllLit, bullet, (<>), (<+>), hcat, hsep, @@ -648,7 +649,7 @@ quotes d = sdocOption sdocCanUseUnicode $ \case | otherwise -> Pretty.quotes pp_d semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc -arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc +arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc blankLine = docToSDoc $ Pretty.text "" @@ -661,6 +662,7 @@ arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") +lambda = unicodeSyntax (char 'λ') (char '\\') semi = docToSDoc $ Pretty.semi comma = docToSDoc $ Pretty.comma colon = docToSDoc $ Pretty.colon diff --git a/testsuite/tests/arityanal/should_compile/Arity01.stderr b/testsuite/tests/arityanal/should_compile/Arity01.stderr index 318fc799e0..bdee9d75db 100644 --- a/testsuite/tests/arityanal/should_compile/Arity01.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity01.stderr @@ -10,7 +10,7 @@ F1.f2 = 1 Rec { -- RHS size: {terms: 18, types: 4, coercions: 0, joins: 0/0} F1.f1_h1 [Occ=LoopBreaker] :: Integer -> Integer -> Integer -> Integer -[GblId, Arity=3, Str=<S,U><S,U><S,U>, Unf=OtherCon []] +[GblId, Arity=3, Str=<MU><MU><MU>, Unf=OtherCon []] F1.f1_h1 = \ (n :: Integer) (x :: Integer) (eta :: Integer) -> case GHC.Num.Integer.integerCompare x n of { @@ -33,7 +33,7 @@ f1 = F1.f1_h1 F1.f3 F1.f2 F1.f3 g :: Integer -> Integer -> Integer -> Integer -> Integer -> Integer [GblId, Arity=5, - Str=<S,1*U><S,U><S,U><S,U><S,U>, + Str=<SU><MU><MU><MU><MU>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=5,unsat_ok=True,boring_ok=False) Tmpl= \ (x1 [Occ=Once1] :: Integer) (x2 [Occ=Once1] :: Integer) (x3 [Occ=Once1] :: Integer) (x4 [Occ=Once1] :: Integer) (x5 [Occ=Once1] :: Integer) -> GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd x1 x2) x3) x4) x5}] g = \ (x1 :: Integer) (x2 :: Integer) (x3 :: Integer) (x4 :: Integer) (x5 :: Integer) -> GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd (GHC.Num.Integer.integerAdd x1 x2) x3) x4) x5 @@ -47,7 +47,7 @@ F1.s1 = 3 s :: forall {t1} {t2}. Num t1 => (t1 -> t2) -> t2 [GblId, Arity=2, - Str=<L,1*U(A,A,A,A,A,A,1*C1(U))><C(S),1*C1(U)>, + Str=<1P(A,A,A,A,A,A,1C1(U))><SCS(U)>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) Tmpl= \ (@t) (@t1) ($dNum [Occ=Once1] :: Num t) (f [Occ=Once1!] :: t -> t1) -> f (fromInteger @t $dNum F1.s1)}] s = \ (@t) (@t1) ($dNum :: Num t) (f :: t -> t1) -> f (fromInteger @t $dNum F1.s1) @@ -61,7 +61,7 @@ F1.h1 = 24 h :: Integer -> Integer [GblId, Arity=1, - Str=<S,U>, + Str=<MU>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (x5 [Occ=Once1] :: Integer) -> GHC.Num.Integer.integerAdd F1.h1 x5}] h = \ (x5 :: Integer) -> GHC.Num.Integer.integerAdd F1.h1 x5 diff --git a/testsuite/tests/arityanal/should_compile/Arity02.stderr b/testsuite/tests/arityanal/should_compile/Arity02.stderr index 3bcac9aacc..47754d5944 100644 --- a/testsuite/tests/arityanal/should_compile/Arity02.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity02.stderr @@ -11,7 +11,7 @@ F2.f1 = 0 f2f :: forall {t1} {t2}. (t1 -> Integer -> t2) -> t1 -> t2 [GblId, Arity=2, - Str=<C(C(S)),1*C1(C1(U))><L,U>, + Str=<SCS(CS(U))><U>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True) Tmpl= \ (@t) (@t1) (h [Occ=Once1!] :: t -> Integer -> t1) (x [Occ=Once1] :: t) -> h x F2.f1}] f2f = \ (@t) (@t1) (h :: t -> Integer -> t1) (x :: t) -> h x F2.f1 @@ -24,7 +24,7 @@ lvl = 1 Rec { -- RHS size: {terms: 16, types: 3, coercions: 0, joins: 0/0} F2.f2_g [Occ=LoopBreaker] :: Integer -> Integer -> Integer -[GblId, Arity=2, Str=<S,U><S,U>, Unf=OtherCon []] +[GblId, Arity=2, Str=<MU><MU>, Unf=OtherCon []] F2.f2_g = \ (x :: Integer) (y :: Integer) -> case GHC.Num.Integer.integerCompare x F2.f1 of { diff --git a/testsuite/tests/arityanal/should_compile/Arity03.stderr b/testsuite/tests/arityanal/should_compile/Arity03.stderr index 29432b7307..fde8e3fa44 100644 --- a/testsuite/tests/arityanal/should_compile/Arity03.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity03.stderr @@ -4,8 +4,8 @@ Result size of Tidy Core = {terms: 29, types: 13, coercions: 0, joins: 0/0} Rec { -- RHS size: {terms: 15, types: 3, coercions: 0, joins: 0/0} -F3.$wfac [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=1, Str=<S,1*U>, Unf=OtherCon []] +F3.$wfac [InlPrag=[2], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# +[GblId, Arity=1, Str=<SU>, Unf=OtherCon []] F3.$wfac = \ (ww :: GHC.Prim.Int#) -> case ww of wild { @@ -15,10 +15,10 @@ F3.$wfac end Rec } -- RHS size: {terms: 10, types: 4, coercions: 0, joins: 0/0} -fac [InlPrag=NOUSERINLINE[2]] :: Int -> Int +fac [InlPrag=[2]] :: Int -> Int [GblId, Arity=1, - Str=<S(S),1*U(1*U)>, + Str=<SP(SU)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once1!] :: Int) -> case w of { GHC.Types.I# ww1 [Occ=Once1] -> case F3.$wfac ww1 of ww2 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww2 } }}] @@ -28,7 +28,7 @@ fac = \ (w :: Int) -> case w of { GHC.Types.I# ww1 -> case F3.$wfac ww1 of ww2 { f3 :: Int -> Int [GblId, Arity=1, - Str=<S(S),1*U(1*U)>, + Str=<SP(SU)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True) Tmpl= fac}] diff --git a/testsuite/tests/arityanal/should_compile/Arity04.stderr b/testsuite/tests/arityanal/should_compile/Arity04.stderr index 5e05c7407d..dd67adb572 100644 --- a/testsuite/tests/arityanal/should_compile/Arity04.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity04.stderr @@ -6,7 +6,7 @@ Result size of Tidy Core = {terms: 39, types: 24, coercions: 0, joins: 0/0} f4g :: Int -> Int [GblId, Arity=1, - Str=<S,1*U(U)>, + Str=<SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (y [Occ=Once1!] :: Int) -> case y of { GHC.Types.I# x [Occ=Once1] -> GHC.Types.I# (GHC.Prim.+# x 1#) }}] @@ -19,8 +19,8 @@ lvl = GHC.Types.I# 0# Rec { -- RHS size: {terms: 13, types: 4, coercions: 0, joins: 0/0} -F4.$wf4h [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: (Int -> Int) -> GHC.Prim.Int# -> Int -[GblId, Arity=2, Str=<C(S),1*C1(U)><S,1*U>, Unf=OtherCon []] +F4.$wf4h [InlPrag=[2], Occ=LoopBreaker] :: (Int -> Int) -> GHC.Prim.Int# -> Int +[GblId, Arity=2, Str=<SCS(U)><SU>, Unf=OtherCon []] F4.$wf4h = \ (w :: Int -> Int) (ww :: GHC.Prim.Int#) -> case ww of wild { @@ -30,10 +30,10 @@ F4.$wf4h end Rec } -- RHS size: {terms: 8, types: 5, coercions: 0, joins: 0/0} -f4h [InlPrag=NOUSERINLINE[2]] :: (Int -> Int) -> Int -> Int +f4h [InlPrag=[2]] :: (Int -> Int) -> Int -> Int [GblId, Arity=2, - Str=<C(S),1*C1(U)><S(S),1*U(1*U)>, + Str=<SCS(U)><SP(SU)>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once1] :: Int -> Int) (w1 [Occ=Once1!] :: Int) -> case w1 of { GHC.Types.I# ww1 [Occ=Once1] -> F4.$wf4h w ww1 }}] f4h = \ (w :: Int -> Int) (w1 :: Int) -> case w1 of { GHC.Types.I# ww1 -> F4.$wf4h w ww1 } diff --git a/testsuite/tests/arityanal/should_compile/Arity05.stderr b/testsuite/tests/arityanal/should_compile/Arity05.stderr index ccdba513af..4a4ac74a9f 100644 --- a/testsuite/tests/arityanal/should_compile/Arity05.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity05.stderr @@ -11,21 +11,21 @@ F5.f5g1 = 1 f5g :: forall {a} {t}. Num a => (t -> a) -> t -> a [GblId, Arity=3, - Str=<S(C(C(S))LLLLLL),U(1*C1(C1(U)),A,A,A,A,A,1*C1(U))><L,1*C1(U)><L,U>, + Str=<MP(SCS(CS(U)),A,A,A,A,A,1C1(U))><1C1(U)><U>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False) Tmpl= \ (@a) (@t) ($dNum :: Num a) (h [Occ=Once1!] :: t -> a) (z [Occ=Once1] :: t) -> + @a $dNum (h z) (fromInteger @a $dNum F5.f5g1)}] f5g = \ (@a) (@t) ($dNum :: Num a) (h :: t -> a) (z :: t) -> + @a $dNum (h z) (fromInteger @a $dNum F5.f5g1) -- RHS size: {terms: 15, types: 14, coercions: 0, joins: 0/0} -F5.$wf5h [InlPrag=NOUSERINLINE[2]] :: forall {a} {t}. (a -> a -> a) -> (Integer -> a) -> (t -> a) -> t -> (t -> a) -> a -[GblId, Arity=5, Str=<C(C(S)),C(C1(U))><L,1*C1(U)><L,1*C1(U)><L,U><L,1*C1(U)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 60 60 0 60] 120 0}] +F5.$wf5h [InlPrag=[2]] :: forall {a} {t}. (a -> a -> a) -> (Integer -> a) -> (t -> a) -> t -> (t -> a) -> a +[GblId, Arity=5, Str=<MCM(CS(U))><1C1(U)><1C1(U)><U><1C1(U)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 60 60 0 60] 120 0}] F5.$wf5h = \ (@a) (@t) (ww :: a -> a -> a) (ww1 :: Integer -> a) (w :: t -> a) (w1 :: t) (w2 :: t -> a) -> ww (w w1) (ww (w2 w1) (ww1 F5.f5g1)) -- RHS size: {terms: 15, types: 32, coercions: 0, joins: 0/0} -f5h [InlPrag=NOUSERINLINE[2]] :: forall {a} {t}. Num a => (t -> a) -> t -> (t -> a) -> a +f5h [InlPrag=[2]] :: forall {a} {t}. Num a => (t -> a) -> t -> (t -> a) -> a [GblId, Arity=4, - Str=<S(C(C(S))LLLLLL),1*U(C(C1(U)),A,A,A,A,A,1*C1(U))><L,1*C1(U)><L,U><L,1*C1(U)>, + Str=<SP(MCM(CS(U)),A,A,A,A,A,1C1(U))><1C1(U)><U><1C1(U)>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False) Tmpl= \ (@a) (@t) (w [Occ=Once1!] :: Num a) (w1 [Occ=Once1] :: t -> a) (w2 [Occ=Once1] :: t) (w3 [Occ=Once1] :: t -> a) -> case w of { GHC.Num.C:Num ww1 [Occ=Once1] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] ww7 [Occ=Once1] -> F5.$wf5h @a @t ww1 ww7 w1 w2 w3 }}] f5h = \ (@a) (@t) (w :: Num a) (w1 :: t -> a) (w2 :: t) (w3 :: t -> a) -> case w of { GHC.Num.C:Num ww1 ww2 ww3 ww4 ww5 ww6 ww7 -> F5.$wf5h @a @t ww1 ww7 w1 w2 w3 } @@ -34,7 +34,7 @@ f5h = \ (@a) (@t) (w :: Num a) (w1 :: t -> a) (w2 :: t) (w3 :: t -> a) -> case w f5y :: Integer -> Integer [GblId, Arity=1, - Str=<S,1*U>, + Str=<SU>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (y [Occ=Once1] :: Integer) -> GHC.Num.Integer.integerAdd y F5.f5g1}] f5y = \ (y :: Integer) -> GHC.Num.Integer.integerAdd y F5.f5g1 diff --git a/testsuite/tests/arityanal/should_compile/Arity09.stderr b/testsuite/tests/arityanal/should_compile/Arity09.stderr index 580483309f..8075f7b17e 100644 --- a/testsuite/tests/arityanal/should_compile/Arity09.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity09.stderr @@ -20,7 +20,7 @@ F9.f1 = 10 Rec { -- RHS size: {terms: 15, types: 2, coercions: 0, joins: 0/0} F9.f91_f [Occ=LoopBreaker] :: Integer -> Integer -[GblId, Arity=1, Str=<S,U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<MU>, Unf=OtherCon []] F9.f91_f = \ (n :: Integer) -> case GHC.Num.Integer.integerCompare n lvl of { diff --git a/testsuite/tests/arityanal/should_compile/Arity11.stderr b/testsuite/tests/arityanal/should_compile/Arity11.stderr index 243632ea06..77c790ae7b 100644 --- a/testsuite/tests/arityanal/should_compile/Arity11.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity11.stderr @@ -20,7 +20,7 @@ F11.fib2 = 2 Rec { -- RHS size: {terms: 24, types: 3, coercions: 0, joins: 0/0} F11.f11_fib [Occ=LoopBreaker] :: Integer -> Integer -[GblId, Arity=1, Str=<S,U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<MU>, Unf=OtherCon []] F11.f11_fib = \ (ds :: Integer) -> case GHC.Num.Integer.integerEq# ds F11.fib1 of { @@ -34,8 +34,8 @@ F11.f11_fib end Rec } -- RHS size: {terms: 52, types: 28, coercions: 0, joins: 0/5} -F11.$wfib [InlPrag=NOUSERINLINE[2]] :: forall {a} {p}. (a -> a -> Bool) -> (Num a, Num p) => a -> p -[GblId, Arity=4, Str=<C(C(S)),C(C1(U))><L,U(A,C(C1(U)),A,A,A,A,C(U))><L,U(C(C1(U)),A,A,A,A,A,1*C1(U))><L,U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 460 0}] +F11.$wfib [InlPrag=[2]] :: forall {a} {p}. (a -> a -> Bool) -> (Num a, Num p) => a -> p +[GblId, Arity=4, Str=<MCM(CS(U))><UP(A,UCU(CS(U)),A,A,A,A,UCU(U))><UP(UCU(CS(U)),A,A,A,A,A,1C1(U))><U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 150 60 0] 460 0}] F11.$wfib = \ (@a) (@p) (ww :: a -> a -> Bool) (w :: Num a) (w1 :: Num p) (w2 :: a) -> let { @@ -56,7 +56,7 @@ F11.$wfib lvl3 = fromInteger @a w F11.fib1 } in letrec { fib4 [Occ=LoopBreaker] :: a -> p - [LclId, Arity=1, Str=<L,U>, Unf=OtherCon []] + [LclId, Arity=1, Str=<U>, Unf=OtherCon []] fib4 = \ (ds :: a) -> case ww ds lvl3 of { @@ -70,10 +70,10 @@ F11.$wfib fib4 w2 -- RHS size: {terms: 14, types: 21, coercions: 0, joins: 0/0} -fib [InlPrag=NOUSERINLINE[2]] :: forall {a} {p}. (Eq a, Num a, Num p) => a -> p +fib [InlPrag=[2]] :: forall {a} {p}. (Eq a, Num a, Num p) => a -> p [GblId, Arity=4, - Str=<S(C(C(S))L),1*U(C(C1(U)),A)><L,U(A,C(C1(U)),A,A,A,A,C(U))><L,U(C(C1(U)),A,A,A,A,A,C(U))><L,U>, + Str=<SP(MCM(CS(U)),A)><UP(A,UCU(CS(U)),A,A,A,A,UCU(U))><UP(UCU(CS(U)),A,A,A,A,A,UCU(U))><U>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False) Tmpl= \ (@a) (@p) (w [Occ=Once1!] :: Eq a) (w1 [Occ=Once1] :: Num a) (w2 [Occ=Once1] :: Num p) (w3 [Occ=Once1] :: a) -> case w of { GHC.Classes.C:Eq ww1 [Occ=Once1] _ [Occ=Dead] -> F11.$wfib @a @p ww1 w1 w2 w3 }}] fib = \ (@a) (@p) (w :: Eq a) (w1 :: Num a) (w2 :: Num p) (w3 :: a) -> case w of { GHC.Classes.C:Eq ww1 ww2 -> F11.$wfib @a @p ww1 w1 w2 w3 } @@ -92,7 +92,7 @@ F11.f11_x = F11.f11_fib F11.f3 F11.f11f1 :: Integer -> Integer [GblId, Arity=1, - Str=<S,U>, + Str=<MU>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (y [Occ=Once1] :: Integer) -> GHC.Num.Integer.integerAdd F11.f11_x y}] F11.f11f1 = \ (y :: Integer) -> GHC.Num.Integer.integerAdd F11.f11_x y @@ -101,7 +101,7 @@ F11.f11f1 = \ (y :: Integer) -> GHC.Num.Integer.integerAdd F11.f11_x y f11f :: forall {p}. p -> Integer -> Integer [GblId, Arity=2, - Str=<L,A><S,U>, + Str=<A><MU>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True) Tmpl= \ (@p) _ [Occ=Dead] (eta [Occ=Once1] :: Integer) -> F11.f11f1 eta}] f11f = \ (@p) _ [Occ=Dead] -> F11.f11f1 diff --git a/testsuite/tests/arityanal/should_compile/Arity14.stderr b/testsuite/tests/arityanal/should_compile/Arity14.stderr index 1d4ea800e6..1a5fdc38c3 100644 --- a/testsuite/tests/arityanal/should_compile/Arity14.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity14.stderr @@ -6,7 +6,7 @@ Result size of Tidy Core = {terms: 56, types: 87, coercions: 0, joins: 0/3} F14.f1 :: forall {t}. t -> t [GblId, Arity=1, - Str=<S,1*U>, + Str=<SU>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True) Tmpl= \ (@t) (y [Occ=Once1] :: t) -> y}] F14.f1 = \ (@t) (y :: t) -> y @@ -17,8 +17,8 @@ F14.f2 :: Integer F14.f2 = 1 -- RHS size: {terms: 35, types: 24, coercions: 0, joins: 0/3} -F14.$wf14 [InlPrag=NOUSERINLINE[2]] :: forall {t}. (t -> t -> Bool) -> Num t => t -> t -> t -> t -[GblId, Arity=4, Str=<C(C(S)),C(C1(U))><L,U(C(C1(U)),A,A,A,A,A,1*C1(U))><L,U><L,U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 90 0 0] 300 0}] +F14.$wf14 [InlPrag=[2]] :: forall {t}. (t -> t -> Bool) -> Num t => t -> t -> t -> t +[GblId, Arity=4, Str=<MCM(CS(U))><UP(UCU(CS(U)),A,A,A,A,A,1C1(U))><U><U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 90 0 0] 300 0}] F14.$wf14 = \ (@t) (ww :: t -> t -> Bool) (w :: Num t) (w1 :: t) (w2 :: t) -> let { @@ -27,14 +27,14 @@ F14.$wf14 lvl = fromInteger @t w F14.f2 } in letrec { f3 [Occ=LoopBreaker] :: t -> t -> t -> t - [LclId, Arity=2, Str=<L,U><L,U>, Unf=OtherCon []] + [LclId, Arity=2, Str=<U><U>, Unf=OtherCon []] f3 = \ (n :: t) (x :: t) -> case ww x n of { False -> F14.f1 @t; True -> let { - v [Dmd=<L,C(U)>] :: t -> t + v [Dmd=UCU(U)] :: t -> t [LclId] v = f3 n (+ @t w x lvl) } in \ (y :: t) -> v (+ @t w x y) @@ -42,10 +42,10 @@ F14.$wf14 f3 w1 w2 -- RHS size: {terms: 13, types: 34, coercions: 0, joins: 0/0} -f14 [InlPrag=NOUSERINLINE[2]] :: forall {t}. (Ord t, Num t) => t -> t -> t -> t +f14 [InlPrag=[2]] :: forall {t}. (Ord t, Num t) => t -> t -> t -> t [GblId, Arity=4, - Str=<S(LLC(C(S))LLLLL),1*U(A,A,C(C1(U)),A,A,A,A,A)><L,U(C(C1(U)),A,A,A,A,A,C(U))><L,U><L,U>, + Str=<SP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(UCU(CS(U)),A,A,A,A,A,UCU(U))><U><U>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False) Tmpl= \ (@t) (w [Occ=Once1!] :: Ord t) (w1 [Occ=Once1] :: Num t) (w2 [Occ=Once1] :: t) (w3 [Occ=Once1] :: t) -> case w of { GHC.Classes.C:Ord _ [Occ=Dead] _ [Occ=Dead] ww3 [Occ=Once1] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> F14.$wf14 @t ww3 w1 w2 w3 }}] f14 = \ (@t) (w :: Ord t) (w1 :: Num t) (w2 :: t) (w3 :: t) -> case w of { GHC.Classes.C:Ord ww1 ww2 ww3 ww4 ww5 ww6 ww7 ww8 -> F14.$wf14 @t ww3 w1 w2 w3 } diff --git a/testsuite/tests/arityanal/should_compile/Arity16.stderr b/testsuite/tests/arityanal/should_compile/Arity16.stderr index 6c9d7f61f8..3f5b3462c6 100644 --- a/testsuite/tests/arityanal/should_compile/Arity16.stderr +++ b/testsuite/tests/arityanal/should_compile/Arity16.stderr @@ -5,7 +5,7 @@ Result size of Tidy Core = {terms: 52, types: 87, coercions: 0, joins: 0/0} Rec { -- RHS size: {terms: 15, types: 17, coercions: 0, joins: 0/0} map2 [Occ=LoopBreaker] :: forall {t} {a}. (t -> a) -> [t] -> [a] -[GblId, Arity=2, Str=<L,C(U)><S,1*U>, Unf=OtherCon []] +[GblId, Arity=2, Str=<UCU(U)><SU>, Unf=OtherCon []] map2 = \ (@t) (@a) (f :: t -> a) (ds :: [t]) -> case ds of { @@ -27,7 +27,7 @@ lvl1 = \ (@a) -> Control.Exception.Base.patError @'GHC.Types.LiftedRep @[a] lvl Rec { -- RHS size: {terms: 29, types: 35, coercions: 0, joins: 0/0} zipWith2 [Occ=LoopBreaker] :: forall {t1} {t2} {a}. (t1 -> t2 -> a) -> [t1] -> [t2] -> [a] -[GblId, Arity=3, Str=<L,C(C1(U))><S,1*U><S,1*U>, Unf=OtherCon []] +[GblId, Arity=3, Str=<UCU(CS(U))><SU><SU>, Unf=OtherCon []] zipWith2 = \ (@t) (@t1) (@a) (f :: t -> t1 -> a) (ds :: [t]) (ds1 :: [t1]) -> case ds of { diff --git a/testsuite/tests/arityanal/should_compile/T18793.stderr b/testsuite/tests/arityanal/should_compile/T18793.stderr index 60b2fd784d..c0843f2edc 100644 --- a/testsuite/tests/arityanal/should_compile/T18793.stderr +++ b/testsuite/tests/arityanal/should_compile/T18793.stderr @@ -4,14 +4,14 @@ Result size of Tidy Core = {terms: 81, types: 74, coercions: 0, joins: 0/0} -- RHS size: {terms: 20, types: 13, coercions: 0, joins: 0/0} T18793.$wstuff [InlPrag=NOINLINE] :: Int -> (# Int, [Int] #) -[GblId, Arity=1, Str=<L,U(U)>, Unf=OtherCon []] +[GblId, Arity=1, Str=<UP(U)>, Unf=OtherCon []] T18793.$wstuff = \ (w :: Int) -> (# w, GHC.Types.: @Int (case w of { GHC.Types.I# x -> GHC.Types.I# (GHC.Prim.+# x 1#) }) (GHC.Types.: @Int (case w of { GHC.Types.I# x -> GHC.Types.I# (GHC.Prim.+# x 2#) }) (GHC.Types.[] @Int)) #) -- RHS size: {terms: 8, types: 11, coercions: 0, joins: 0/0} -stuff [InlPrag=NOUSERINLINE[final]] :: Int -> [Int] +stuff [InlPrag=[final]] :: Int -> [Int] [GblId, Arity=1, - Str=<L,U(U)>, + Str=<UP(U)>, Cpr=m2, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once1] :: Int) -> case T18793.$wstuff w of { (# ww1 [Occ=Once1], ww2 [Occ=Once1] #) -> GHC.Types.: @Int ww1 ww2 }}] @@ -19,8 +19,8 @@ stuff = \ (w :: Int) -> case T18793.$wstuff w of { (# ww1, ww2 #) -> GHC.Types.: Rec { -- RHS size: {terms: 23, types: 11, coercions: 0, joins: 0/0} -T18793.$wgo1 [InlPrag=NOUSERINLINE[2], Occ=LoopBreaker] :: [Int] -> GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=2, Str=<S,1*U><L,U>, Unf=OtherCon []] +T18793.$wgo1 [InlPrag=[2], Occ=LoopBreaker] :: [Int] -> GHC.Prim.Int# -> GHC.Prim.Int# +[GblId, Arity=2, Str=<SU><U>, Unf=OtherCon []] T18793.$wgo1 = \ (w :: [Int]) (ww :: GHC.Prim.Int#) -> case w of { @@ -36,10 +36,10 @@ T18793.$wgo1 end Rec } -- RHS size: {terms: 12, types: 6, coercions: 0, joins: 0/0} -T18793.f_go1 [InlPrag=NOUSERINLINE[2]] :: [Int] -> Int -> Int +T18793.f_go1 [InlPrag=[2]] :: [Int] -> Int -> Int [GblId, Arity=2, - Str=<S,1*U><S,1*U(U)>, + Str=<SU><SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once1] :: [Int]) (w1 [Occ=Once1!] :: Int) -> case w1 of { GHC.Types.I# ww1 [Occ=Once1] -> case T18793.$wgo1 w ww1 of ww2 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww2 } }}] @@ -59,7 +59,7 @@ T18793.f1 = case T18793.$wstuff T18793.f2 of { (# ww1, ww2 #) -> GHC.Types.: @In f :: Int -> Int [GblId, Arity=1, - Str=<S,1*U(U)>, + Str=<SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False) Tmpl= \ (eta [Occ=Once1] :: Int) -> T18793.f_go1 T18793.f1 eta}] diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index c44c342f05..86d74c2d35 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -17,7 +17,7 @@ T2431.$WRefl -- RHS size: {terms: 4, types: 8, coercions: 0, joins: 0/0} absurd :: forall a. (Int :~: Bool) -> a -[GblId, Arity=1, Str=<L,U>b, Cpr=b, Unf=OtherCon []] +[GblId, Arity=1, Str=<U>b, Cpr=b, Unf=OtherCon []] absurd = \ (@a) (x :: Int :~: Bool) -> case x of { } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/ghci/linking/T11531.stderr b/testsuite/tests/ghci/linking/T11531.stderr index b6527a3268..eb8c154598 100644 --- a/testsuite/tests/ghci/linking/T11531.stderr +++ b/testsuite/tests/ghci/linking/T11531.stderr @@ -1,5 +1,5 @@ -GHC.Linker.Runtime.dynLoadObjs: Loading temp shared object failed +GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed During interactive linking, GHCi couldn't find the following symbol: This may be due to you not asking GHCi to load extra object files, archives or DLLs needed by your current session. Restart GHCi, specifying diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout index 5001d5b3a4..d9287fcd32 100644 --- a/testsuite/tests/numeric/should_compile/T14465.stdout +++ b/testsuite/tests/numeric/should_compile/T14465.stdout @@ -78,7 +78,7 @@ twoTimesTwo = 4 plusOne :: Natural -> Natural [GblId, Arity=1, - Str=<S,1*U>, + Str=<SU>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout index 41995d9734..996d391b44 100644 --- a/testsuite/tests/numeric/should_compile/T7116.stdout +++ b/testsuite/tests/numeric/should_compile/T7116.stdout @@ -43,7 +43,7 @@ T7116.$trModule dr :: Double -> Double [GblId, Arity=1, - Str=<S,1*U(U)>, + Str=<SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -60,7 +60,7 @@ dr dl :: Double -> Double [GblId, Arity=1, - Str=<S,1*U(U)>, + Str=<SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -73,7 +73,7 @@ dl = dr fr :: Float -> Float [GblId, Arity=1, - Str=<S,1*U(U)>, + Str=<SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -92,7 +92,7 @@ fr fl :: Float -> Float [GblId, Arity=1, - Str=<S,1*U(U)>, + Str=<SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index a0440ca173..46222c723a 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -341,6 +341,7 @@ test('Naperian', test ('T9630', [ collect_compiler_residency(15), + collect_compiler_stats('bytes allocated', 2), extra_clean(['T9630a.hi', 'T9630a.o']), ], multimod_compile, diff --git a/testsuite/tests/simplCore/should_compile/EvalTest.stdout b/testsuite/tests/simplCore/should_compile/EvalTest.stdout index b536c541c0..fa65324317 100644 --- a/testsuite/tests/simplCore/should_compile/EvalTest.stdout +++ b/testsuite/tests/simplCore/should_compile/EvalTest.stdout @@ -1 +1 @@ -rght [Dmd=<S,U>] :: AList a +rght [Dmd=MU] :: AList a diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr index 73ac2fd1a8..44ab565425 100644 --- a/testsuite/tests/simplCore/should_compile/T13143.stderr +++ b/testsuite/tests/simplCore/should_compile/T13143.stderr @@ -7,7 +7,7 @@ Rec { -- RHS size: {terms: 4, types: 4, coercions: 0, joins: 0/0} T13143.$wf [InlPrag=NOINLINE, Occ=LoopBreaker] :: forall {a}. (# #) -> a -[GblId, Arity=1, Str=<B,A>b, Cpr=b, Unf=OtherCon []] +[GblId, Arity=1, Str=<B>b, Cpr=b, Unf=OtherCon []] T13143.$wf = \ (@a) _ [Occ=Dead] -> T13143.$wf @a GHC.Prim.(##) end Rec } @@ -15,7 +15,7 @@ end Rec } f [InlPrag=[final]] :: forall a. Int -> a [GblId, Arity=1, - Str=<B,A>b, + Str=<B>b, Cpr=b, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -68,7 +68,7 @@ Rec { -- RHS size: {terms: 28, types: 7, coercions: 0, joins: 0/0} T13143.$wg [InlPrag=[2], Occ=LoopBreaker] :: Bool -> Bool -> GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=3, Str=<S,1*U><S,1*U><L,U>, Unf=OtherCon []] +[GblId, Arity=3, Str=<SU><SU><U>, Unf=OtherCon []] T13143.$wg = \ (w :: Bool) (w1 :: Bool) (ww :: GHC.Prim.Int#) -> case w of { @@ -89,7 +89,7 @@ end Rec } g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int [GblId, Arity=3, - Str=<S,1*U><S,1*U><S,1*U(U)>, + Str=<SU><SU><SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/simplCore/should_compile/T13543.stderr b/testsuite/tests/simplCore/should_compile/T13543.stderr index d7df037ba4..ce5b23ff4a 100644 --- a/testsuite/tests/simplCore/should_compile/T13543.stderr +++ b/testsuite/tests/simplCore/should_compile/T13543.stderr @@ -1,8 +1,8 @@ ==================== Strictness signatures ==================== Foo.$trModule: -Foo.f: <S(S),1*U(1*U)><S,1*U(U)><S,1*U(U)> -Foo.g: <S(SS),1*U(1*U(U),1*U(U))> +Foo.f: <SP(SU)><SP(U)><SP(U)> +Foo.g: <SP(SP(U),SP(U))> @@ -15,7 +15,7 @@ Foo.g: m1 ==================== Strictness signatures ==================== Foo.$trModule: -Foo.f: <S(S),1*U(1*U)><S,1*U(U)><S,1*U(U)> -Foo.g: <S(SS),1*U(1*U(U),1*U(U))> +Foo.f: <SP(SU)><SP(U)><SP(U)> +Foo.g: <SP(SP(U),SP(U))> diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr index c141780f74..51e30a9f75 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.stderr +++ b/testsuite/tests/simplCore/should_compile/T18013.stderr @@ -136,7 +136,7 @@ mapMaybeRule :: forall a b. Rule IO a b -> Rule IO (Maybe a) (Maybe b) [GblId, Arity=1, - Str=<S,1*U>, + Str=<SU>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 150 10}] mapMaybeRule diff --git a/testsuite/tests/simplCore/should_compile/T18328.stderr b/testsuite/tests/simplCore/should_compile/T18328.stderr index ce366ea367..d32f553114 100644 --- a/testsuite/tests/simplCore/should_compile/T18328.stderr +++ b/testsuite/tests/simplCore/should_compile/T18328.stderr @@ -4,19 +4,18 @@ Result size of Tidy Core = {terms: 69, types: 61, coercions: 0, joins: 1/1} -- RHS size: {terms: 42, types: 28, coercions: 0, joins: 1/1} -T18328.$wf [InlPrag=NOUSERINLINE[2]] +T18328.$wf [InlPrag=[2]] :: forall {a}. GHC.Prim.Int# -> [a] -> [a] -> [a] [GblId, Arity=3, - Str=<S,U><S,U><L,1*U>, + Str=<SU><U><U>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [182 0 0] 312 0}] T18328.$wf = \ (@a) (ww :: GHC.Prim.Int#) (w :: [a]) (w1 :: [a]) -> join { - $wj [InlPrag=NOINLINE, Dmd=<L,1*C1(U)>] - :: forall {p}. GHC.Prim.Void# -> [a] - [LclId[JoinId(2)], Arity=1, Str=<L,A>, Unf=OtherCon []] + $wj [InlPrag=NOINLINE, Dmd=1C1(U)] :: forall {p}. (# #) -> [a] + [LclId[JoinId(2)], Arity=1, Str=<A>, Unf=OtherCon []] $wj (@p) _ [Occ=Dead, OS=OneShot] = case ww of { __DEFAULT -> ++ @a w (++ @a w (++ @a w w1)); @@ -24,24 +23,24 @@ T18328.$wf } } in case ww of { __DEFAULT -> ++ @a w w1; - 1# -> jump $wj @Integer GHC.Prim.void#; - 2# -> jump $wj @Integer GHC.Prim.void#; - 3# -> jump $wj @Integer GHC.Prim.void# + 1# -> jump $wj @Integer GHC.Prim.(##); + 2# -> jump $wj @Integer GHC.Prim.(##); + 3# -> jump $wj @Integer GHC.Prim.(##) } -- RHS size: {terms: 11, types: 10, coercions: 0, joins: 0/0} -f [InlPrag=NOUSERINLINE[2]] :: forall a. Int -> [a] -> [a] -> [a] +f [InlPrag=[2]] :: forall a. Int -> [a] -> [a] -> [a] [GblId, Arity=3, - Str=<S(S),1*U(U)><S,U><L,1*U>, + Str=<S(SU)><U><U>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False) Tmpl= \ (@a) - (w [Occ=Once!] :: Int) - (w1 [Occ=Once] :: [a]) - (w2 [Occ=Once] :: [a]) -> - case w of { GHC.Types.I# ww1 [Occ=Once] -> + (w [Occ=Once1!] :: Int) + (w1 [Occ=Once1] :: [a]) + (w2 [Occ=Once1] :: [a]) -> + case w of { GHC.Types.I# ww1 [Occ=Once1] -> T18328.$wf @a ww1 w1 w2 }}] f = \ (@a) (w :: Int) (w1 :: [a]) (w2 :: [a]) -> @@ -58,7 +57,7 @@ T18328.$trModule4 = "main"# T18328.$trModule3 :: GHC.Types.TrName [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T18328.$trModule3 = GHC.Types.TrNameS T18328.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} @@ -72,14 +71,14 @@ T18328.$trModule2 = "T18328"# T18328.$trModule1 :: GHC.Types.TrName [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T18328.$trModule1 = GHC.Types.TrNameS T18328.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T18328.$trModule :: GHC.Types.Module [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T18328.$trModule = GHC.Types.Module T18328.$trModule3 T18328.$trModule1 diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index 7ed4f14e60..f428cfc1fa 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -43,7 +43,7 @@ Rec { -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} T3717.$wfoo [InlPrag=[2], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=1, Str=<S,1*U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<SU>, Unf=OtherCon []] T3717.$wfoo = \ (ww :: GHC.Prim.Int#) -> case ww of ds { @@ -56,7 +56,7 @@ end Rec } foo [InlPrag=[2]] :: Int -> Int [GblId, Arity=1, - Str=<S(S),1*U(1*U)>, + Str=<SP(SU)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index b4c072db75..34947f5392 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -42,7 +42,7 @@ T3772.$trModule Rec { -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} $wxs :: GHC.Prim.Int# -> () -[GblId, Arity=1, Str=<S,1*U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<SU>, Unf=OtherCon []] $wxs = \ (ww :: GHC.Prim.Int#) -> case ww of ds1 { @@ -53,7 +53,7 @@ end Rec } -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> () -[GblId, Arity=1, Str=<L,U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<U>, Unf=OtherCon []] T3772.$wfoo = \ (ww :: GHC.Prim.Int#) -> case GHC.Prim.<# 0# ww of { @@ -65,7 +65,7 @@ T3772.$wfoo foo [InlPrag=[final]] :: Int -> () [GblId, Arity=1, - Str=<S,1*U(U)>, + Str=<SP(U)>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) diff --git a/testsuite/tests/simplCore/should_compile/T4201.stdout b/testsuite/tests/simplCore/should_compile/T4201.stdout index d6c3879899..c8b6acb12a 100644 --- a/testsuite/tests/simplCore/should_compile/T4201.stdout +++ b/testsuite/tests/simplCore/should_compile/T4201.stdout @@ -1,4 +1,4 @@ [HasNoCafRefs, LambdaFormInfo: LFReEntrant 1, Arity: 1, - Strictness: <S,1*U>, + Strictness: <SU>, Unfolding: InlineRule (0, True, True) bof `cast` (Sym (N:Foo[0]) %<'Many>_N ->_R <T>_R)] diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index 84cfde275b..5db6bc8506 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -42,7 +42,7 @@ T4908.$trModule Rec { -- RHS size: {terms: 19, types: 5, coercions: 0, joins: 0/0} T4908.f_$s$wf [Occ=LoopBreaker] :: Int -> Int# -> Int# -> Bool -[GblId, Arity=3, Str=<L,A><L,1*U><S,1*U>, Unf=OtherCon []] +[GblId, Arity=3, Str=<A><1U><SU>, Unf=OtherCon []] T4908.f_$s$wf = \ (sc :: Int) (sc1 :: Int#) (sc2 :: Int#) -> case sc2 of ds { @@ -59,7 +59,7 @@ end Rec } T4908.$wf [InlPrag=[2]] :: Int# -> (Int, Int) -> Bool [GblId, Arity=2, - Str=<S,1*U><L,1*U(A,1*U(1*U))>, + Str=<SU><1P(A,1P(1U))>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20] 101 20}] T4908.$wf @@ -81,7 +81,7 @@ T4908.$wf f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool [GblId, Arity=2, - Str=<S(S),1*U(1*U)><L,1*U(A,1*U(1*U))>, + Str=<SP(SU)><1P(A,1P(1U))>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index adf3bf37aa..d0319763fa 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -43,7 +43,7 @@ Rec { -- RHS size: {terms: 17, types: 3, coercions: 0, joins: 0/0} T4930.$wfoo [InlPrag=[2], Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=1, Str=<L,U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<U>, Unf=OtherCon []] T4930.$wfoo = \ (ww :: GHC.Prim.Int#) -> case GHC.Prim.<# ww 5# of { @@ -56,7 +56,7 @@ end Rec } foo [InlPrag=[2]] :: Int -> Int [GblId, Arity=1, - Str=<S,1*U(U)>, + Str=<SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index 6295890f08..73bafb04f6 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -8,7 +8,7 @@ T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo [GblId[DataConWrapper], Arity=1, Caf=NoCafRefs, - Str=<S,U>, + Str=<MU>, Cpr=m3, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -21,7 +21,7 @@ T7360.$WFoo3 -- RHS size: {terms: 5, types: 2, coercions: 0, joins: 0/0} fun1 [InlPrag=NOINLINE] :: Foo -> () -[GblId, Arity=1, Str=<S,1*U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<SA>, Unf=OtherCon []] fun1 = \ (x :: Foo) -> case x of { __DEFAULT -> GHC.Tuple.() } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} @@ -35,7 +35,7 @@ T7360.fun4 = fun1 T7360.Foo1 fun2 :: forall {a}. [a] -> ((), Int) [GblId, Arity=1, - Str=<L,1*U>, + Str=<1U>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/simplCore/should_compile/noinline01.stderr b/testsuite/tests/simplCore/should_compile/noinline01.stderr index d38b5dee03..f8b9a70ee3 100644 --- a/testsuite/tests/simplCore/should_compile/noinline01.stderr +++ b/testsuite/tests/simplCore/should_compile/noinline01.stderr @@ -2,7 +2,7 @@ ==================== Initial STG: ==================== Noinline01.f [InlPrag=INLINE (sat-args=1)] :: forall {p}. p -> GHC.Types.Bool -[GblId, Arity=1, Str=<L,A>, Unf=OtherCon []] = +[GblId, Arity=1, Str=<A>, Unf=OtherCon []] = \r [eta] GHC.Types.True []; Noinline01.g :: GHC.Types.Bool diff --git a/testsuite/tests/simplCore/should_compile/par01.stderr b/testsuite/tests/simplCore/should_compile/par01.stderr index 5b1cd6423d..91213ee1dc 100644 --- a/testsuite/tests/simplCore/should_compile/par01.stderr +++ b/testsuite/tests/simplCore/should_compile/par01.stderr @@ -6,7 +6,7 @@ Result size of CorePrep Rec { -- RHS size: {terms: 7, types: 3, coercions: 0, joins: 0/0} Par01.depth [Occ=LoopBreaker] :: GHC.Types.Int -> GHC.Types.Int -[GblId, Arity=1, Str=<L,U>, Unf=OtherCon []] +[GblId, Arity=1, Str=<U>, Unf=OtherCon []] Par01.depth = \ (d :: GHC.Types.Int) -> case GHC.Prim.par# @GHC.Types.Int d of { __DEFAULT -> diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 36639b35e1..87e8bd7980 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -54,7 +54,7 @@ Rec { -- RHS size: {terms: 40, types: 5, coercions: 0, joins: 0/0} Roman.foo_$s$wgo [Occ=LoopBreaker] :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int# -[GblId, Arity=2, Str=<L,A><L,U>, Unf=OtherCon []] +[GblId, Arity=2, Str=<A><U>, Unf=OtherCon []] Roman.foo_$s$wgo = \ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) -> case GHC.Prim.<=# sc1 0# of { @@ -76,7 +76,7 @@ end Rec } Roman.$wgo [InlPrag=[2]] :: Maybe Int -> Maybe Int -> GHC.Prim.Int# [GblId, Arity=2, - Str=<S,1*U><S,1*U>, + Str=<SU><SU>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [61 30] 249 0}] Roman.$wgo @@ -111,7 +111,7 @@ Roman.$wgo Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int [GblId, Arity=2, - Str=<S,1*U><S,1*U>, + Str=<SU><SU>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, @@ -143,7 +143,7 @@ Roman.foo1 = GHC.Maybe.Just @Int Roman.foo2 foo :: Int -> Int [GblId, Arity=1, - Str=<S,1*U(U)>, + Str=<SP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, diff --git a/testsuite/tests/stranal/should_compile/T10694.stderr b/testsuite/tests/stranal/should_compile/T10694.stderr index df5bd122d0..45060226c1 100644 --- a/testsuite/tests/stranal/should_compile/T10694.stderr +++ b/testsuite/tests/stranal/should_compile/T10694.stderr @@ -4,7 +4,7 @@ Result size of Tidy Core = {terms: 74, types: 65, coercions: 0, joins: 0/4} -- RHS size: {terms: 39, types: 25, coercions: 0, joins: 0/4} T10694.$wpm [InlPrag=NOINLINE] :: Int -> Int -> (# Int, Int #) -[GblId, Arity=2, Str=<L,U(U)><L,U(U)>, Unf=OtherCon []] +[GblId, Arity=2, Str=<UP(U)><UP(U)>, Unf=OtherCon []] T10694.$wpm = \ (w :: Int) (w1 :: Int) -> let { @@ -26,25 +26,25 @@ T10694.$wpm (# GHC.List.$w!! @Int l3 0#, GHC.List.$w!! @Int l3 1# #) -- RHS size: {terms: 10, types: 11, coercions: 0, joins: 0/0} -pm [InlPrag=NOUSERINLINE[0]] :: Int -> Int -> (Int, Int) +pm [InlPrag=[final]] :: Int -> Int -> (Int, Int) [GblId, Arity=2, - Str=<L,U(U)><L,U(U)>, + Str=<UP(U)><UP(U)>, Cpr=m1, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once] :: Int) (w1 [Occ=Once] :: Int) -> - case T10694.$wpm w w1 of { (# ww1 [Occ=Once], ww2 [Occ=Once] #) -> (ww1, ww2) }}] + Tmpl= \ (w [Occ=Once1] :: Int) (w1 [Occ=Once1] :: Int) -> + case T10694.$wpm w w1 of { (# ww1 [Occ=Once1], ww2 [Occ=Once1] #) -> (ww1, ww2) }}] pm = \ (w :: Int) (w1 :: Int) -> case T10694.$wpm w w1 of { (# ww1, ww2 #) -> (ww1, ww2) } -- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} m :: Int -> Int -> Int [GblId, Arity=2, - Str=<L,U(U)><L,U(U)>, + Str=<UP(U)><UP(U)>, Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (x [Occ=Once] :: Int) (y [Occ=Once] :: Int) -> case pm x y of { (_ [Occ=Dead], mr [Occ=Once]) -> mr }}] + Tmpl= \ (x [Occ=Once1] :: Int) (y [Occ=Once1] :: Int) -> case pm x y of { (_ [Occ=Dead], mr [Occ=Once1]) -> mr }}] m = \ (x :: Int) (y :: Int) -> case T10694.$wpm x y of { (# ww1, ww2 #) -> ww2 } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} @@ -54,7 +54,7 @@ T10694.$trModule4 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T10694.$trModule3 :: GHC.Types.TrName -[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T10694.$trModule3 = GHC.Types.TrNameS T10694.$trModule4 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} @@ -64,12 +64,12 @@ T10694.$trModule2 = "T10694"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} T10694.$trModule1 :: GHC.Types.TrName -[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T10694.$trModule1 = GHC.Types.TrNameS T10694.$trModule2 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T10694.$trModule :: GHC.Types.Module -[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T10694.$trModule = GHC.Types.Module T10694.$trModule3 T10694.$trModule1 diff --git a/testsuite/tests/stranal/should_compile/T13031.stdout b/testsuite/tests/stranal/should_compile/T13031.stdout index c42eecb616..0b40ec8eeb 100644 --- a/testsuite/tests/stranal/should_compile/T13031.stdout +++ b/testsuite/tests/stranal/should_compile/T13031.stdout @@ -1,2 +1,2 @@ hello -[GblId, Arity=3, Str=<L,U><L,U><L,U>b, Cpr=b, Unf=OtherCon []] +[GblId, Arity=3, Str=<U><U><U>b, Cpr=b, Unf=OtherCon []] diff --git a/testsuite/tests/stranal/should_compile/T18903.hs b/testsuite/tests/stranal/should_compile/T18903.hs new file mode 100644 index 0000000000..e88a0eea8b --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T18903.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp #-} + +-- | The point of this test is that @g@ get's a demand that says "whenever @g@ +-- is called, the second component of the pair is evaluated strictly". +module T18903 where + +h :: Int -> Int +h m = + let g :: Int -> (Int,Int) + g 1 = (m, 0) + g n = (2 * n, 2 `div` n) + {-# NOINLINE g #-} + in case m of + 1 -> 0 + 2 -> snd (g m) + _ -> uncurry (+) (g m) diff --git a/testsuite/tests/stranal/should_compile/T18903.stderr b/testsuite/tests/stranal/should_compile/T18903.stderr new file mode 100644 index 0000000000..4adbdd566c --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T18903.stderr @@ -0,0 +1,109 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 84, types: 55, coercions: 0, joins: 0/1} + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18903.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T18903.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18903.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T18903.$trModule3 = GHC.Types.TrNameS T18903.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18903.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T18903.$trModule2 = "T18903"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18903.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T18903.$trModule1 = GHC.Types.TrNameS T18903.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18903.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T18903.$trModule + = GHC.Types.Module T18903.$trModule3 T18903.$trModule1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18903.h1 :: Int +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T18903.h1 = GHC.Types.I# 0# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18903.h2 :: Int +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T18903.h2 = GHC.Types.I# -2# + +-- RHS size: {terms: 56, types: 41, coercions: 0, joins: 0/1} +T18903.$wh [InlPrag=[2]] :: GHC.Prim.Int# -> Int +[GblId, + Arity=1, + Str=<MU>, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [70] 262 10}] +T18903.$wh + = \ (ww :: GHC.Prim.Int#) -> + let { + $wg [InlPrag=NOINLINE, Dmd=1C1(P(1P(U),SP(U)))] + :: GHC.Prim.Int# -> (# Int, Int #) + [LclId, Arity=1, Str=<SU>, Unf=OtherCon []] + $wg + = \ (ww1 [OS=OneShot] :: GHC.Prim.Int#) -> + case ww1 of ds { + __DEFAULT -> + (# GHC.Types.I# (GHC.Prim.*# 2# ds), + case ds of { + __DEFAULT -> + case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT -> + GHC.Types.I# ww4 + }; + -1# -> T18903.h2; + 0# -> case GHC.Real.divZeroError of wild1 { } + } #); + 1# -> (# GHC.Types.I# ww, T18903.h1 #) + } } in + case ww of ds { + __DEFAULT -> + case $wg ds of { (# ww2, ww3 #) -> + case ww2 of { GHC.Types.I# x -> + case ww3 of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) } + } + }; + 1# -> T18903.h1; + 2# -> case $wg 2# of { (# ww2, ww3 #) -> ww3 } + } + +-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} +h [InlPrag=[2]] :: Int -> Int +[GblId, + Arity=1, + Str=<SP(MU)>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (w [Occ=Once1!] :: Int) -> + case w of { GHC.Types.I# ww1 [Occ=Once1] -> T18903.$wh ww1 }}] +h = \ (w :: Int) -> + case w of { GHC.Types.I# ww1 -> T18903.$wh ww1 } + + + diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T index bb3fcd2952..1262ad426e 100644 --- a/testsuite/tests/stranal/should_compile/all.T +++ b/testsuite/tests/stranal/should_compile/all.T @@ -55,3 +55,6 @@ test('T13380b', [ grep_errmsg('bigDeadAction') ], compile, ['-dppr-cols=200 -dd # We just want to find the worker of foo in there: test('T18122', [ grep_errmsg(r'wfoo =') ], compile, ['-ddump-simpl']) + +# We care about the call demand on $wg +test('T18903', [ grep_errmsg(r'Dmd=\S+C\S+') ], compile, ['-ddump-simpl -dsuppress-uniques']) diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr index c3845dd6de..a2dade38df 100644 --- a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr +++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr @@ -1,8 +1,8 @@ ==================== Strictness signatures ==================== BottomFromInnerLambda.$trModule: -BottomFromInnerLambda.expensive: <S(S),1*U(U)> -BottomFromInnerLambda.f: <S(S),1*U(U)> +BottomFromInnerLambda.expensive: <SP(MU)> +BottomFromInnerLambda.f: <SP(MU)> @@ -15,7 +15,7 @@ BottomFromInnerLambda.f: ==================== Strictness signatures ==================== BottomFromInnerLambda.$trModule: -BottomFromInnerLambda.expensive: <S(S),1*U(1*U)> -BottomFromInnerLambda.f: <S(S),1*U(1*U)> +BottomFromInnerLambda.expensive: <SP(SU)> +BottomFromInnerLambda.f: <SP(SU)> diff --git a/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr b/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr index 54b0a44763..ca6d3015ff 100644 --- a/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr +++ b/testsuite/tests/stranal/sigs/CaseBinderCPR.stderr @@ -1,7 +1,7 @@ ==================== Strictness signatures ==================== CaseBinderCPR.$trModule: -CaseBinderCPR.f_list_cmp: <L,C(C1(U(U)))><S,1*U><S,1*U> +CaseBinderCPR.f_list_cmp: <UCU(CS(P(MU)))><SU><SU> @@ -13,6 +13,6 @@ CaseBinderCPR.f_list_cmp: m1 ==================== Strictness signatures ==================== CaseBinderCPR.$trModule: -CaseBinderCPR.f_list_cmp: <L,C(C1(U(1*U)))><S,1*U><S,1*U> +CaseBinderCPR.f_list_cmp: <UCU(CS(P(SU)))><SU><SU> diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr index 6dd5576da4..41fae8f5ce 100644 --- a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr +++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr @@ -5,11 +5,11 @@ DmdAnalGADTs.$tc'B: DmdAnalGADTs.$tcD: DmdAnalGADTs.$trModule: DmdAnalGADTs.diverges: b -DmdAnalGADTs.f: <S,1*U> -DmdAnalGADTs.f': <S,1*U> -DmdAnalGADTs.g: <S,1*U> +DmdAnalGADTs.f: <SU> +DmdAnalGADTs.f': <SU> +DmdAnalGADTs.g: <SU> DmdAnalGADTs.hasCPR: -DmdAnalGADTs.hasStrSig: <S,1*U(U)> +DmdAnalGADTs.hasStrSig: <SP(U)> @@ -33,10 +33,10 @@ DmdAnalGADTs.$tc'B: DmdAnalGADTs.$tcD: DmdAnalGADTs.$trModule: DmdAnalGADTs.diverges: b -DmdAnalGADTs.f: <S,1*U> -DmdAnalGADTs.f': <S,1*U> -DmdAnalGADTs.g: <S,1*U> +DmdAnalGADTs.f: <SU> +DmdAnalGADTs.f': <SU> +DmdAnalGADTs.g: <SU> DmdAnalGADTs.hasCPR: -DmdAnalGADTs.hasStrSig: <S,1*U(U)> +DmdAnalGADTs.hasStrSig: <SP(U)> diff --git a/testsuite/tests/stranal/sigs/HyperStrUse.stderr b/testsuite/tests/stranal/sigs/HyperStrUse.stderr index 1ae91db4d4..dc26e84381 100644 --- a/testsuite/tests/stranal/sigs/HyperStrUse.stderr +++ b/testsuite/tests/stranal/sigs/HyperStrUse.stderr @@ -1,7 +1,7 @@ ==================== Strictness signatures ==================== HyperStrUse.$trModule: -HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U> +HyperStrUse.f: <SP(SP(U),A)><SU> @@ -13,6 +13,6 @@ HyperStrUse.f: m1 ==================== Strictness signatures ==================== HyperStrUse.$trModule: -HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U> +HyperStrUse.f: <SP(SP(U),A)><SU> diff --git a/testsuite/tests/stranal/sigs/NewtypeArity.stderr b/testsuite/tests/stranal/sigs/NewtypeArity.stderr index 55cfe94ac7..ebbbbc0c30 100644 --- a/testsuite/tests/stranal/sigs/NewtypeArity.stderr +++ b/testsuite/tests/stranal/sigs/NewtypeArity.stderr @@ -3,8 +3,8 @@ Test.$tc'MkT: Test.$tcT: Test.$trModule: -Test.t: <S,1*U(U)><S,1*U(U)> -Test.t2: <S,1*U(U)><S,1*U(U)> +Test.t: <SP(U)><SP(U)> +Test.t2: <SP(U)><SP(U)> @@ -21,7 +21,7 @@ Test.t2: m1 Test.$tc'MkT: Test.$tcT: Test.$trModule: -Test.t: <S,1*U(U)><S,1*U(U)> -Test.t2: <S,1*U(U)><S,1*U(U)> +Test.t: <SP(U)><SP(U)> +Test.t2: <SP(U)><SP(U)> diff --git a/testsuite/tests/stranal/sigs/StrAnalExample.stderr b/testsuite/tests/stranal/sigs/StrAnalExample.stderr index eb2c5716bc..e9ac8bab6a 100644 --- a/testsuite/tests/stranal/sigs/StrAnalExample.stderr +++ b/testsuite/tests/stranal/sigs/StrAnalExample.stderr @@ -1,7 +1,7 @@ ==================== Strictness signatures ==================== StrAnalExample.$trModule: -StrAnalExample.foo: <S,1*U> +StrAnalExample.foo: <SU> @@ -13,6 +13,6 @@ StrAnalExample.foo: ==================== Strictness signatures ==================== StrAnalExample.$trModule: -StrAnalExample.foo: <S,1*U> +StrAnalExample.foo: <SU> diff --git a/testsuite/tests/stranal/sigs/T12370.stderr b/testsuite/tests/stranal/sigs/T12370.stderr index caa780b0d2..44a90106cf 100644 --- a/testsuite/tests/stranal/sigs/T12370.stderr +++ b/testsuite/tests/stranal/sigs/T12370.stderr @@ -1,8 +1,8 @@ ==================== Strictness signatures ==================== T12370.$trModule: -T12370.bar: <S,1*U(U)><S,1*U(U)> -T12370.foo: <S(SS),1*U(1*U(U),1*U(U))> +T12370.bar: <SP(U)><SP(U)> +T12370.foo: <SP(SP(U),SP(U))> @@ -15,7 +15,7 @@ T12370.foo: m1 ==================== Strictness signatures ==================== T12370.$trModule: -T12370.bar: <S,1*U(U)><S,1*U(U)> -T12370.foo: <S(SS),1*U(1*U(U),1*U(U))> +T12370.bar: <SP(U)><SP(U)> +T12370.foo: <SP(SP(U),SP(U))> diff --git a/testsuite/tests/stranal/sigs/T13380f.stderr b/testsuite/tests/stranal/sigs/T13380f.stderr index dd53a9c971..a856a1794b 100644 --- a/testsuite/tests/stranal/sigs/T13380f.stderr +++ b/testsuite/tests/stranal/sigs/T13380f.stderr @@ -1,12 +1,12 @@ ==================== Strictness signatures ==================== T13380f.$trModule: -T13380f.f: <S,1*U(U)><S,1*U(U)><L,U> -T13380f.g: <S,1*U(U)><L,1*U(U)><L,U> -T13380f.h: <S,1*U(U)><L,1*U(U)><L,U> -T13380f.interruptibleCall: <L,U> -T13380f.safeCall: <L,U> -T13380f.unsafeCall: <L,U> +T13380f.f: <SP(U)><SP(U)><U> +T13380f.g: <SP(U)><1P(U)><U> +T13380f.h: <SP(U)><1P(U)><U> +T13380f.interruptibleCall: <U> +T13380f.safeCall: <U> +T13380f.unsafeCall: <U> @@ -23,11 +23,11 @@ T13380f.unsafeCall: ==================== Strictness signatures ==================== T13380f.$trModule: -T13380f.f: <S,1*U(U)><S,1*U(U)><L,U> -T13380f.g: <S,1*U(U)><L,1*U(U)><L,U> -T13380f.h: <S,1*U(U)><L,1*U(U)><L,U> -T13380f.interruptibleCall: <L,U> -T13380f.safeCall: <L,U> -T13380f.unsafeCall: <L,U> +T13380f.f: <SP(U)><SP(U)><U> +T13380f.g: <SP(U)><1P(U)><U> +T13380f.h: <SP(U)><1P(U)><U> +T13380f.interruptibleCall: <U> +T13380f.safeCall: <U> +T13380f.unsafeCall: <U> diff --git a/testsuite/tests/stranal/sigs/T17932.stderr b/testsuite/tests/stranal/sigs/T17932.stderr index 7ca56637df..072af8d45e 100644 --- a/testsuite/tests/stranal/sigs/T17932.stderr +++ b/testsuite/tests/stranal/sigs/T17932.stderr @@ -5,7 +5,7 @@ T17932.$tc'X: T17932.$tcOptions: T17932.$tcX: T17932.$trModule: -T17932.flags: <S(SS),1*U(1*U,1*U)> +T17932.flags: <SP(SU,SU)> @@ -25,6 +25,6 @@ T17932.$tc'X: T17932.$tcOptions: T17932.$tcX: T17932.$trModule: -T17932.flags: <S(SS),1*U(1*U,1*U)> +T17932.flags: <SP(SU,SU)> diff --git a/testsuite/tests/stranal/sigs/T18086.stderr b/testsuite/tests/stranal/sigs/T18086.stderr index 6941e233f8..0ac4c846ee 100644 --- a/testsuite/tests/stranal/sigs/T18086.stderr +++ b/testsuite/tests/stranal/sigs/T18086.stderr @@ -1,8 +1,8 @@ ==================== Strictness signatures ==================== T18086.$trModule: -T18086.m: <L,U>x -T18086.panic: <L,U>x +T18086.m: <U>x +T18086.panic: <U>x @@ -15,7 +15,7 @@ T18086.panic: ==================== Strictness signatures ==================== T18086.$trModule: -T18086.m: <L,U>x -T18086.panic: <L,U>x +T18086.m: <U>x +T18086.panic: <U>x diff --git a/testsuite/tests/stranal/sigs/T18957.hs b/testsuite/tests/stranal/sigs/T18957.hs new file mode 100644 index 0000000000..9781b7cd58 --- /dev/null +++ b/testsuite/tests/stranal/sigs/T18957.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp #-} +{-# LANGUAGE BangPatterns #-} + +-- | This ticket is about demand `seq` puts its first argument under and +-- how that affects call demands. +module T18957 where + +-- | Should put its first argument under head demand +seq' :: a -> b -> b +seq' a b = seq a b +{-# NOINLINE seq' #-} + +-- | The first argument is evaluated at once, but called every time it's +-- evaluated +g :: (Int -> Int) -> Int -> Int +g f x = if x < 100 then f x else 200 + +-- | The first argument is evaluated multiple times, but called at most once +-- every time it's evaluated +h1 :: (Int -> Int) -> Int -> Int +-- Note that seq' is like seq, but NOINLINE. See h2 below why +h1 f x = f `seq'` if x < 100 then f x else 200 + +-- | Like h1, but using `seq` directly, which will rewrite the call site +-- of @f@ to use the case binder instead, which means we won't evaluate it an +-- additional time. So evaluated once and called once. +h2 :: (Int -> Int) -> Int -> Int +h2 f x = f `seq` if x < 100 then f x else 200 + +h3 :: (Int -> Int) -> Int -> Int +h3 f x = if x < 100 then f x + f (x+1) else 200 diff --git a/testsuite/tests/stranal/sigs/T18957.stderr b/testsuite/tests/stranal/sigs/T18957.stderr new file mode 100644 index 0000000000..c536410e0a --- /dev/null +++ b/testsuite/tests/stranal/sigs/T18957.stderr @@ -0,0 +1,30 @@ + +==================== Strictness signatures ==================== +T18957.$trModule: +T18957.g: <1C1(U)><SP(U)> +T18957.h1: <MC1(U)><SP(U)> +T18957.h2: <SC1(U)><SP(U)> +T18957.h3: <UCU(P(U))><SP(U)> +T18957.seq': <SA><SU> + + + +==================== Cpr signatures ==================== +T18957.$trModule: +T18957.g: +T18957.h1: +T18957.h2: +T18957.h3: m1 +T18957.seq': + + + +==================== Strictness signatures ==================== +T18957.$trModule: +T18957.g: <1C1(U)><SP(U)> +T18957.h1: <MC1(U)><SP(U)> +T18957.h2: <SC1(U)><SP(U)> +T18957.h3: <UCU(P(U))><SP(U)> +T18957.seq': <SA><SU> + + diff --git a/testsuite/tests/stranal/sigs/T5075.stderr b/testsuite/tests/stranal/sigs/T5075.stderr index e048ce2fb3..64a78d05ec 100644 --- a/testsuite/tests/stranal/sigs/T5075.stderr +++ b/testsuite/tests/stranal/sigs/T5075.stderr @@ -1,7 +1,7 @@ ==================== Strictness signatures ==================== T5075.$trModule: -T5075.loop: <S(LLC(C(S))LLLLL),U(A,A,C(C1(U)),A,A,A,A,A)><L,U(A,A,C(C1(U)),A,A,A,C(U))><L,U> +T5075.loop: <MP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,UCU(U))><U> @@ -13,6 +13,6 @@ T5075.loop: ==================== Strictness signatures ==================== T5075.$trModule: -T5075.loop: <S(LLC(C(S))LLLLL),1*U(A,A,C(C1(U)),A,A,A,A,A)><L,U(A,A,C(C1(U)),A,A,A,C(U))><L,U> +T5075.loop: <SP(A,A,MCM(CS(U)),A,A,A,A,A)><UP(A,A,UCU(CS(U)),A,A,A,UCU(U))><U> diff --git a/testsuite/tests/stranal/sigs/T8569.stderr b/testsuite/tests/stranal/sigs/T8569.stderr index bfbd22e52e..cc7a5e9fb0 100644 --- a/testsuite/tests/stranal/sigs/T8569.stderr +++ b/testsuite/tests/stranal/sigs/T8569.stderr @@ -4,7 +4,7 @@ T8569.$tc'Rdata: T8569.$tc'Rint: T8569.$tcRep: T8569.$trModule: -T8569.addUp: <S,1*U><L,U> +T8569.addUp: <SU><U> @@ -22,6 +22,6 @@ T8569.$tc'Rdata: T8569.$tc'Rint: T8569.$tcRep: T8569.$trModule: -T8569.addUp: <S,1*U><L,U> +T8569.addUp: <SU><U> diff --git a/testsuite/tests/stranal/sigs/T8598.stderr b/testsuite/tests/stranal/sigs/T8598.stderr index 8c56089bcd..7e68094018 100644 --- a/testsuite/tests/stranal/sigs/T8598.stderr +++ b/testsuite/tests/stranal/sigs/T8598.stderr @@ -1,7 +1,7 @@ ==================== Strictness signatures ==================== T8598.$trModule: -T8598.fun: <S,1*U(U)> +T8598.fun: <SP(U)> @@ -13,6 +13,6 @@ T8598.fun: m1 ==================== Strictness signatures ==================== T8598.$trModule: -T8598.fun: <S,1*U(U)> +T8598.fun: <SP(U)> diff --git a/testsuite/tests/stranal/sigs/UnsatFun.hs b/testsuite/tests/stranal/sigs/UnsatFun.hs index c38c5cba1d..e9587245d1 100644 --- a/testsuite/tests/stranal/sigs/UnsatFun.hs +++ b/testsuite/tests/stranal/sigs/UnsatFun.hs @@ -35,6 +35,7 @@ h3 f = f 2 `seq` 3 -- And here we check that the depth of the strictness --- of h is applied correctly. +-- of h is applied correctly. The lambda is unsaturated +-- and thus x is absent. g3 :: Int -> Int g3 x = h3 (\_ _ -> error (show x)) diff --git a/testsuite/tests/stranal/sigs/UnsatFun.stderr b/testsuite/tests/stranal/sigs/UnsatFun.stderr index 325d25ced7..18723bad40 100644 --- a/testsuite/tests/stranal/sigs/UnsatFun.stderr +++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr @@ -1,13 +1,13 @@ ==================== Strictness signatures ==================== UnsatFun.$trModule: -UnsatFun.f: <B,1*U(U)><B,A>b -UnsatFun.g: <B,1*U(U)>b -UnsatFun.g': <L,1*U(U)> -UnsatFun.g3: <L,U(U)> -UnsatFun.h: <C(S),1*C1(U)> -UnsatFun.h2: <S,1*U><L,1*C1(U)> -UnsatFun.h3: <C(S),1*C1(U)> +UnsatFun.f: <SP(M)><B>b +UnsatFun.g: <SP(M)>b +UnsatFun.g': <1P(U)> +UnsatFun.g3: <A> +UnsatFun.h: <SCS(U)> +UnsatFun.h2: <SU><1C1(U)> +UnsatFun.h3: <SCS(A)> @@ -25,12 +25,12 @@ UnsatFun.h3: m1 ==================== Strictness signatures ==================== UnsatFun.$trModule: -UnsatFun.f: <B,1*U(U)><B,A>b -UnsatFun.g: <B,1*U(U)>b -UnsatFun.g': <L,1*U(U)> -UnsatFun.g3: <L,U(U)> -UnsatFun.h: <C(S),1*C1(U)> -UnsatFun.h2: <S,1*U><L,1*C1(U)> -UnsatFun.h3: <C(S),1*C1(U)> +UnsatFun.f: <SP(M)><B>b +UnsatFun.g: <SP(M)>b +UnsatFun.g': <1P(U)> +UnsatFun.g3: <A> +UnsatFun.h: <SCS(U)> +UnsatFun.h2: <SU><1C1(U)> +UnsatFun.h3: <SCS(A)> diff --git a/testsuite/tests/stranal/sigs/all.T b/testsuite/tests/stranal/sigs/all.T index 387a1a7f7d..07cc815823 100644 --- a/testsuite/tests/stranal/sigs/all.T +++ b/testsuite/tests/stranal/sigs/all.T @@ -23,3 +23,4 @@ test('T17932', normal, compile, ['']) test('T13380c', expect_broken('!3014'), compile, ['']) test('T13380f', normal, compile, ['']) test('T18086', normal, compile, ['-package ghc']) +test('T18957', normal, compile, ['']) |