diff options
| author | Sebastian Graf <sebastian.graf@kit.edu> | 2021-05-04 23:00:02 +0200 |
|---|---|---|
| committer | Sebastian Graf <sebastian.graf@kit.edu> | 2021-09-28 16:38:45 +0200 |
| commit | 8c508b7814bf8c78975a00c689d97fd0adb58ad5 (patch) | |
| tree | f307954e2f181e95da0d68efc328e874f28005c0 | |
| parent | 89ce6950df052123f04cb2c45fe2138411d42b55 (diff) | |
| download | haskell-wip/nested-cpr-light-2.tar.gz | |
Nested CPR light unleashed (#18174)wip/nested-cpr-light-2
This patch enables worker/wrapper for nested constructed products, as described
in `Note [Nested CPR]`. The machinery for expressing Nested CPR was already
there, since !5054. Worker/wrapper is equipped to exploit Nested CPR annotations
since !5338. CPR analysis already handles applications in batches since !5753.
This patch just needs to flip a few more switches:
1. In `cprTransformDataConWork`, we need to look at the field expressions
and their `CprType`s to see whether the evaluation of the expressions
terminates quickly (= is in HNF) or if they are put in strict fields.
If that is the case, then we retain their CPR info and may unbox nestedly
later on. More details in `Note [Nested CPR]`.
2. Enable nested `ConCPR` signatures in `GHC.Types.Cpr`.
3. In the `asConCpr` call in `GHC.Core.Opt.WorkWrap.Utils`, pass CPR info of
fields to the `Unbox`.
4. Instead of giving CPR signatures to DataCon workers and wrappers, we now have
`cprTransformDataConWork` for workers and treat wrappers by analysing their
unfolding. As a result, the code from GHC.Types.Id.Make went away completely.
5. I deactivated worker/wrappering for recursive DataCons and wrote a function
`isRecDataCon` to detect them. We really don't want to give `repeat` or
`replicate` the Nested CPR property.
See Note [CPR for recursive data structures] for which kind of recursive
DataCons we target.
6. Fix a couple of tests and their outputs.
I also documented that CPR can destroy sharing and lead to asymptotic increase
in allocations (which is tracked by #13331/#19326) in
`Note [CPR for data structures can destroy sharing]`.
Nofib results:
```
--------------------------------------------------------------------------------
Program Allocs Instrs
--------------------------------------------------------------------------------
ben-raytrace -3.1% -0.4%
binary-trees +0.8% -2.9%
digits-of-e2 +5.8% +1.2%
event +0.8% -2.1%
fannkuch-redux +0.0% -1.4%
fish 0.0% -1.5%
gamteb -1.4% -0.3%
mkhprog +1.4% +0.8%
multiplier +0.0% -1.9%
pic -0.6% -0.1%
reptile -20.9% -17.8%
wave4main +4.8% +0.4%
x2n1 -100.0% -7.6%
--------------------------------------------------------------------------------
Min -95.0% -17.8%
Max +5.8% +1.2%
Geometric Mean -2.9% -0.4%
```
The huge wins in x2n1 (loopy list) and reptile (see #19970) are due to
refraining from unboxing (:). Other benchmarks like digits-of-e2 or wave4main
regress because of that. Ultimately there are no great improvements due to
Nested CPR alone, but at least it's a win.
Binary sizes decrease by 0.6%.
There are a significant number of metric decreases. The most notable ones (>1%):
```
ManyAlternatives(normal) ghc/alloc 771656002.7 762187472.0 -1.2%
ManyConstructors(normal) ghc/alloc 4191073418.7 4114369216.0 -1.8%
MultiLayerModules(normal) ghc/alloc 3095678333.3 3128720704.0 +1.1%
PmSeriesG(normal) ghc/alloc 50096429.3 51495664.0 +2.8%
PmSeriesS(normal) ghc/alloc 63512989.3 64681600.0 +1.8%
PmSeriesV(normal) ghc/alloc 62575424.0 63767208.0 +1.9%
T10547(normal) ghc/alloc 29347469.3 29944240.0 +2.0%
T11303b(normal) ghc/alloc 46018752.0 47367576.0 +2.9%
T12150(optasm) ghc/alloc 81660890.7 82547696.0 +1.1%
T12234(optasm) ghc/alloc 59451253.3 60357952.0 +1.5%
T12545(normal) ghc/alloc 1705216250.7 1751278952.0 +2.7%
T12707(normal) ghc/alloc 981000472.0 968489800.0 -1.3% GOOD
T13056(optasm) ghc/alloc 389322664.0 372495160.0 -4.3% GOOD
T13253(normal) ghc/alloc 337174229.3 341954576.0 +1.4%
T13701(normal) ghc/alloc 2381455173.3 2439790328.0 +2.4% BAD
T14052(ghci) ghc/alloc 2162530642.7 2139108784.0 -1.1%
T14683(normal) ghc/alloc 3049744728.0 2977535064.0 -2.4% GOOD
T14697(normal) ghc/alloc 362980213.3 369304512.0 +1.7%
T15164(normal) ghc/alloc 1323102752.0 1307480600.0 -1.2%
T15304(normal) ghc/alloc 1304607429.3 1291024568.0 -1.0%
T16190(normal) ghc/alloc 281450410.7 284878048.0 +1.2%
T16577(normal) ghc/alloc 7984960789.3 7811668768.0 -2.2% GOOD
T17516(normal) ghc/alloc 1171051192.0 1153649664.0 -1.5%
T17836(normal) ghc/alloc 1115569746.7 1098197592.0 -1.6%
T17836b(normal) ghc/alloc 54322597.3 55518216.0 +2.2%
T17977(normal) ghc/alloc 47071754.7 48403408.0 +2.8%
T17977b(normal) ghc/alloc 42579133.3 43977392.0 +3.3%
T18923(normal) ghc/alloc 71764237.3 72566240.0 +1.1%
T1969(normal) ghc/alloc 784821002.7 773971776.0 -1.4% GOOD
T3294(normal) ghc/alloc 1634913973.3 1614323584.0 -1.3% GOOD
T4801(normal) ghc/alloc 295619648.0 292776440.0 -1.0%
T5321FD(normal) ghc/alloc 278827858.7 276067280.0 -1.0%
T5631(normal) ghc/alloc 586618202.7 577579960.0 -1.5%
T5642(normal) ghc/alloc 494923048.0 487927208.0 -1.4%
T5837(normal) ghc/alloc 37758061.3 39261608.0 +4.0%
T9020(optasm) ghc/alloc 257362077.3 254672416.0 -1.0%
T9198(normal) ghc/alloc 49313365.3 50603936.0 +2.6% BAD
T9233(normal) ghc/alloc 704944258.7 685692712.0 -2.7% GOOD
T9630(normal) ghc/alloc 1476621560.0 1455192784.0 -1.5%
T9675(optasm) ghc/alloc 443183173.3 433859696.0 -2.1% GOOD
T9872a(normal) ghc/alloc 1720926653.3 1693190072.0 -1.6% GOOD
T9872b(normal) ghc/alloc 2185618061.3 2162277568.0 -1.1% GOOD
T9872c(normal) ghc/alloc 1765842405.3 1733618088.0 -1.8% GOOD
TcPlugin_RewritePerf(normal) ghc/alloc 2388882730.7 2365504696.0 -1.0%
WWRec(normal) ghc/alloc 607073186.7 597512216.0 -1.6%
T9203(normal) run/alloc 107284064.0 102881832.0 -4.1%
haddock.Cabal(normal) run/alloc 24025329589.3 23768382560.0 -1.1%
haddock.base(normal) run/alloc 25660521653.3 25370321824.0 -1.1%
haddock.compiler(normal) run/alloc 74064171706.7 73358712280.0 -1.0%
```
The biggest exception to the rule is T13701 which seems to fluctuate as usual
(not unlike T12545). T14697 has a similar quality, being a generated
multi-module test. T5837 is small enough that it similarly doesn't measure
anything significant besides module loading overhead.
T13253 simply does one additional round of Simplification due to Nested CPR.
There are also some apparent regressions in T9198, T12234 and PmSeriesG that we
(@mpickering and I) were simply unable to reproduce locally. @mpickering tried
to run the CI script in a local Docker container and actually found that T9198
and PmSeriesG *improved*. In MRs that were rebased on top this one, like !4229,
I did not experience such increases. Let's not get hung up on these regression
tests, they were meant to test for asymptotic regressions.
The build-cabal test improves by 1.2% in -O0.
Metric Increase:
T10421
T12234
T12545
T13035
T13056
T13701
T14697
T18923
T5837
T9198
Metric Decrease:
ManyConstructors
T12545
T12707
T13056
T14683
T16577
T18223
T1969
T3294
T9203
T9233
T9675
T9872a
T9872b
T9872c
T9961
TcPlugin_RewritePerf
35 files changed, 1631 insertions, 443 deletions
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index f3ae2c0b43..b01218d6d7 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -36,55 +36,122 @@ import GHC.Data.Maybe ( isJust ) import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Logger ( Logger, putDumpFileMaybe, DumpFormat (..) ) ---import GHC.Utils.Trace -import Control.Monad ( guard ) import Data.List ( mapAccumL ) {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The goal of Constructed Product Result analysis is to identify functions that surely return heap-allocated records on every code path, so that we can -eliminate said heap allocation by performing a worker/wrapper split. - -@swap@ below is such a function: +eliminate said heap allocation by performing a worker/wrapper split +(via 'GHC.Core.Opt.WorkWrap.Utils.mkWWcpr_entry'). +`swap` below is such a function: +``` swap (a, b) = (b, a) - -A @case@ on an application of @swap@, like -@case swap (10, 42) of (a, b) -> a + b@ could cancel away -(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then -say that @swap@ has the CPR property. +``` +A `case` on an application of `swap`, like +`case swap (10, 42) of (a, b) -> a + b` could cancel away +(by case-of-known-constructor) if we \"inlined\" `swap` and simplified. We then +say that `swap` has the CPR property. We can't inline recursive functions, but similar reasoning applies there: - +``` f x n = case n of 0 -> (x, 0) _ -> f (x+1) (n-1) - -Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed -product with the case. So @f@, too, has the CPR property. But we can't really -"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@ +``` +Inductively, `case f 1 2 of (a, b) -> a + b` could cancel away the constructed +product with the case. So `f`, too, has the CPR property. But we can't really +"inline" `f`, because it's recursive. Also, non-recursive functions like `swap` might be too big to inline (or even marked NOINLINE). We still want to exploit the CPR property, and that is exactly what the worker/wrapper transformation can do for us: - +``` $wf x n = case n of 0 -> case (x, 0) of -> (a, b) -> (# a, b #) _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #) f x n = case $wf x n of (# a, b #) -> (a, b) - -where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to: - +``` +where $wf readily simplifies (by case-of-known-constructor and inlining `f`) to: +``` $wf x n = case n of 0 -> (# x, 0 #) _ -> $wf (x+1) (n-1) - -Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and +``` +Now, a call site like `case f 1 2 of (a, b) -> a + b` can inline `f` and eliminate the heap-allocated pair constructor. +Note [Nested CPR] +~~~~~~~~~~~~~~~~~ +We can apply Note [Constructed Product Result] deeper than just the top-level +result constructor of a function, e.g., +``` + g x + | even x = (x+1,x+2) :: (Int, Int) + | odd x = (x+2,x+3) +``` +Not only does `g` return a constructed pair, the pair components /also/ have the +CPR property. We can split `g` for its /nested/ CPR property, as follows: +``` + $wg (x :: Int#) + | .. x .. = (# x +# 1#, x +# 2# #) :: (# Int#, Int# #) + | .. x .. = (# x +# 2#, x +# 3# #) + g (I# x) = case $wf x of (# y, z #) -> (I# y, I# z) +``` +Note however that in the following we will only unbox the second component, +even if `foo` has the CPR property: +``` + h x + | even x = (foo x, x+2) :: (Int, Int) + | odd x = (x+2, x+3) + -- where `foo` has the CPR property +``` +Why can't we also unbox `foo x`? Because in order to do so, we have to evaluate +it and that might diverge, so we cannot give `h` the nested CPR property in the +first component of the result. + +The Right Thing is to do a termination analysis, to see if we can guarantee that +`foo` terminates quickly, in which case we can speculatively evaluate `foo x` and +hence give `h` a nested CPR property. That is done in !1866. But for now we +have an incredibly simple termination analysis; an expression terminates fast +iff it is in HNF: see `exprTerminates`. We call `exprTerminates` in +`cprTransformDataConWork`, which is the main function figuring out whether it's +OK to propagate nested CPR info (in `extract_nested_cpr`). + +In addition to `exprTerminates`, `extract_nested_cpr` also looks at the +`StrictnessMark` of the corresponding constructor field. Example: +``` + data T a = MkT !a + h2 x + | even x = MkT (foo x) :: T Int + | odd x = MkT (x+2) + -- where `foo` has the CPR property +``` +Regardless of whether or not `foo` terminates, we may unbox the strict field, +because it has to be evaluated (the Core for `MkT (foo x)` will look more like +`case foo x of y { __DEFAULT -> MkT y }`). + +Surprisingly, there are local binders with a strict demand that *do not* +terminate quickly in a sense that is useful to us! The following function +demonstrates that: +``` + j x = (let t = x+1 in t+t, 42) +``` +Here, `t` is used strictly, *but only within its scope in the first pair +component*. `t` satisfies Note [CPR for binders that will be unboxed], so it has +the CPR property, nevertheless we may not unbox `j` deeply lest evaluation of +`x` diverges. The termination analysis must say "Might diverge" for `t` and we +won't unbox the first pair component. +There are a couple of tests in T18174 that show case Nested CPR. Some of them +only work with the termination analysis from !1866. + +Giving the (Nested) CPR property to deep data structures can lead to loss of +sharing; see Note [CPR for data structures can destroy sharing]. + Note [Phase ordering] ~~~~~~~~~~~~~~~~~~~~~ We need to perform strictness analysis before CPR analysis, because that might @@ -97,8 +164,7 @@ Ideally, we would want the following pipeline: 4. worker/wrapper (for CPR) Currently, we omit 2. and anticipate the results of worker/wrapper. -See Note [CPR for binders that will be unboxed] -and Note [Optimistic field binder CPR]. +See Note [CPR for binders that will be unboxed]. An additional w/w pass would simplify things, but probably add slight overhead. So currently we have @@ -163,9 +229,9 @@ cprAnal' env (Tick t e) (cpr_ty, e') = cprAnal env e cprAnal' env e@(Var{}) - = cprAnalApp env e [] [] + = cprAnalApp env e [] cprAnal' env e@(App{}) - = cprAnalApp env e [] [] + = cprAnalApp env e [] cprAnal' env (Lam var body) | isTyVar var @@ -227,56 +293,103 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs) -- * CPR transformer -- -cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr) -cprAnalApp env e args' arg_tys - -- Collect CprTypes for (value) args (inlined collectArgs): - | App fn arg <- e, isTypeArg arg -- Don't analyse Type args - = cprAnalApp env fn (arg:args') arg_tys - | App fn arg <- e - , (arg_ty, arg') <- cprAnal env arg - = cprAnalApp env fn (arg':args') (arg_ty:arg_tys) - - | Var fn <- e - = (cprTransform env fn arg_tys, mkApps e args') - - | otherwise -- e is not an App and not a Var - , (e_ty, e') <- cprAnal env e - = (applyCprTy e_ty (length arg_tys), mkApps e' args') - -cprTransform :: AnalEnv -- ^ The analysis environment - -> Id -- ^ The function - -> [CprType] -- ^ info about incoming /value/ arguments - -> CprType -- ^ The demand type of the application -cprTransform env id args - = -- pprTrace "cprTransform" (vcat [ppr id, ppr args, ppr sig]) - sig +data TermFlag -- Better than using a Bool + = Terminates + | MightDiverge + +-- See Note [Nested CPR] +exprTerminates :: CoreExpr -> TermFlag +exprTerminates e + | exprIsHNF e = Terminates -- A /very/ simple termination analysis. + | otherwise = MightDiverge + +cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr) +-- Main function that takes care of /nested/ CPR. See Note [Nested CPR] +cprAnalApp env e arg_infos = go e arg_infos [] where - sig - -- Top-level binding, local let-binding, lambda arg or case binder - | Just sig <- lookupSigEnv env id - = applyCprTy (getCprSig sig) (length args) - -- CPR transformers for special Ids - | Just cpr_ty <- cprTransformSpecial id args - = cpr_ty - -- See Note [CPR for data structures] - | Just rhs <- cprDataStructureUnfolding_maybe id - = fst $ cprAnal env rhs - -- Imported function or data con worker - | isGlobalId id - = applyCprTy (getCprSig (idCprSig id)) (length args) - | otherwise - = topCprType + go e arg_infos args' + -- Collect CprTypes for (value) args (inlined collectArgs): + | App fn arg <- e, isTypeArg arg -- Don't analyse Type args + = go fn arg_infos (arg:args') + | App fn arg <- e + , arg_info@(_arg_ty, arg') <- cprAnal env arg + -- See Note [Nested CPR] on the need for termination analysis + = go fn (arg_info:arg_infos) (arg':args') + + | Var fn <- e + = (cprTransform env fn arg_infos, mkApps e args') + + | (e_ty, e') <- cprAnal env e -- e is not an App and not a Var + = (applyCprTy e_ty (length arg_infos), mkApps e' args') + +cprTransform :: AnalEnv -- ^ The analysis environment + -> Id -- ^ The function + -> [(CprType, CoreArg)] -- ^ info about incoming /value/ arguments + -> CprType -- ^ The demand type of the application +cprTransform env id args + -- Any local binding, except for data structure bindings + -- See Note [Efficient Top sigs in SigEnv] + | Just sig <- lookupSigEnv env id + = applyCprTy (getCprSig sig) (length args) + -- See Note [CPR for data structures] + | Just rhs <- cprDataStructureUnfolding_maybe id + = fst $ cprAnal env rhs + -- Some (mostly global, known-key) Ids have bespoke CPR transformers + | Just cpr_ty <- cprTransformBespoke id args + = cpr_ty + -- Other local Ids that respond True to 'isDataStructure' but don't have an + -- expandable unfolding, such as NOINLINE bindings. They all get a top sig + | isLocalId id + = assertPpr (isDataStructure id) (ppr id) topCprType + -- See Note [CPR for DataCon wrappers] + | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id) + = fst $ cprAnalApp env rhs args + -- DataCon worker + | Just con <- isDataConWorkId_maybe id + = cprTransformDataConWork (ae_fam_envs env) con args + -- Imported function + | otherwise + = applyCprTy (getCprSig (idCprSig id)) (length args) --- | CPR transformers for special Ids -cprTransformSpecial :: Id -> [CprType] -> Maybe CprType -cprTransformSpecial id args +-- | Precise, hand-written CPR transformers for select Ids +cprTransformBespoke :: Id -> [(CprType, CoreArg)] -> Maybe CprType +cprTransformBespoke id args -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep - | idUnique id == runRWKey -- `runRW (\s -> e)` - , [arg] <- args -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`) - = Just $ applyCprTy arg 1 -- `e` has CPR type `2` + | idUnique id == runRWKey -- `runRW (\s -> e)` + , [(arg_ty, _arg)] <- args -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`) + = Just $ applyCprTy arg_ty 1 -- `e` has CPR type `2` | otherwise = Nothing +-- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker, +-- given a saturated number of 'CprType's for its field expressions. +-- Implements the Nested part of Note [Nested CPR]. +cprTransformDataConWork :: FamInstEnvs -> DataCon -> [(CprType, CoreArg)] -> CprType +cprTransformDataConWork fam_envs con args + | null (dataConExTyCoVars con) -- No existentials + , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE] + , args `lengthIs` wkr_arity + , isRecDataCon fam_envs fuel con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors] + -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True + = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks)) + | otherwise + = topCprType + where + fuel = 3 -- If we can unbox more than 3 constructors to find a + -- recursive occurrence, then we can just as well unbox it + -- See Note [CPR for recursive data constructors], point (4) + wkr_arity = dataConRepArity con + wkr_str_marks = dataConRepStrictness con + -- See Note [Nested CPR] + extract_nested_cpr (CprType 0 cpr, arg) str + | MarkedStrict <- str = cpr + | Terminates <- exprTerminates arg = cpr + extract_nested_cpr _ _ = topCpr -- intervening lambda or doesn't terminate + +-- | See Note [Trimming to mAX_CPR_SIZE]. +mAX_CPR_SIZE :: Arity +mAX_CPR_SIZE = 10 + -- -- * Bindings -- @@ -289,13 +402,13 @@ cprFix :: TopLevelFlag cprFix top_lvl orig_env orig_pairs = loop 1 init_env init_pairs where - init_sig id rhs + init_sig id -- See Note [CPR for data structures] - | isDataStructure id rhs = topCprSig - | otherwise = mkCprSig 0 botCpr + | isDataStructure id = topCprSig + | otherwise = mkCprSig 0 botCpr -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal orig_virgin = ae_virgin orig_env - init_pairs | orig_virgin = [(setIdCprSig id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ] + init_pairs | orig_virgin = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ] | otherwise = orig_pairs init_env = extendSigEnvFromIds orig_env (map fst init_pairs) @@ -330,9 +443,11 @@ cprAnalBind -> CoreExpr -> (Id, CoreExpr, AnalEnv) cprAnalBind top_lvl env id rhs + | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs. + = (id, rhs, extendSigEnv env id topCprSig) -- See Note [CPR for data structures] - | isDataStructure id rhs - = (id, rhs, env) -- Data structure => no code => need to analyse rhs + | isDataStructure id + = (id, rhs, env) -- Data structure => no code => no need to analyse rhs | otherwise = (id', rhs', env') where @@ -362,21 +477,22 @@ cprAnalBind top_lvl env id rhs = False returns_local_sum = not (isTopLevel top_lvl) && not returns_product -isDataStructure :: Id -> CoreExpr -> Bool +isDataStructure :: Id -> Bool -- See Note [CPR for data structures] -isDataStructure id rhs = - idArity id == 0 && exprIsHNF rhs +isDataStructure id = + not (isJoinId id) && idArity id == 0 && isEvaldUnfolding (idUnfolding id) -- | Returns an expandable unfolding -- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has -- So effectively is a constructor application. cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr -cprDataStructureUnfolding_maybe id = do +cprDataStructureUnfolding_maybe id -- There are only FinalPhase Simplifier runs after CPR analysis - guard (activeInFinalPhase (idInlineActivation id)) - unf <- expandUnfolding_maybe (idUnfolding id) - guard (isDataStructure id unf) - return unf + | activeInFinalPhase (idInlineActivation id) + , isDataStructure id + = expandUnfolding_maybe (idUnfolding id) + | otherwise + = Nothing {- Note [Arity trimming for CPR signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -408,6 +524,49 @@ from @f@'s, so it *will* be WW'd: And the case in @g@ can never cancel away, thus we introduced extra reboxing. Hence we always trim the CPR signature of a binding to idArity. + +Note [CPR for DataCon wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to give DataCon wrappers a (necessarily flat) CPR signature in +'GHC.Types.Id.Make.mkDataConRep'. Now we transform DataCon wrappers simply by +analysing their unfolding. A few reasons for the change: + + 1. DataCon wrappers are generally inlined in the Final phase (so before CPR), + all leftover occurrences are in a boring context like `f x y = $WMkT y x`. + It's simpler to analyse the unfolding anew at every such call site, and the + unfolding will be pretty cheap to analyse. Also they occur seldom enough + that performance-wise it doesn't matter. + 2. 'GHC.Types.Id.Make' no longer precomputes CPR signatures for DataCon + *workers*, because their transformers need to adapt to CPR for their + arguments in 'cprTransformDataConWork' to enable Note [Nested CPR]. + Better keep it all in this module! The alternative would be that + 'GHC.Types.Id.Make' depends on DmdAnal. + 3. In the future, Nested CPR could take a better account of incoming args + in cprAnalApp and do some beta-reduction on the fly, like !1866 did. If + any of those args had the CPR property, then we'd even get Nested CPR for + DataCon wrapper calls, for free. Not so if we simply give the wrapper a + single CPR sig in 'GHC.Types.Id.Make.mkDataConRep'! + +Note [Trimming to mAX_CPR_SIZE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not treat very big tuples as CPR-ish: + + a) For a start, we get into trouble because there aren't + "enough" unboxed tuple types (a tiresome restriction, + but hard to fix), + b) More importantly, big unboxed tuples get returned mainly + on the stack, and are often then allocated in the heap + by the caller. So doing CPR for them may in fact make + things worse, especially if the wrapper doesn't cancel away + and we move to the stack in the worker and then to the heap + in the wrapper. + +So we (nested) CPR for functions that would otherwise pass more than than +'mAX_CPR_SIZE' fields. +That effect is exacerbated for the unregisterised backend, where we +don't have any hardware registers to return the fields in. Returning +everything on the stack results in much churn and increases compiler +allocation by 15% for T15164 in a validate build. -} data AnalEnv @@ -592,86 +751,20 @@ Note that * See Note [CPR examples] -Historic Note [Optimistic field binder CPR] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -This Note describes how we used to guess whether fields have the CPR property -before we were able to express Nested CPR for arguments. - -Consider - - data T a = MkT a - f :: T Int -> Int - f x = ... (case x of - MkT y -> y) ... - -And assume we know from strictness analysis that `f` is strict in `x` and its -field `y` and we unbox both. Then we give `x` the CPR property according -to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y` -likewise will be unboxed and it should also get the CPR property. We'd -need a *nested* CPR property here for `x` to express that and unwrap one level -when we analyse the Case to give the CPR property to `y`. - -Lacking Nested CPR, we have to guess a bit, by looking for - - (A) Flat CPR on the scrutinee - (B) A variable scrutinee. Otherwise surely it can't be a parameter. - (C) Strict demand on the field binder `y` (or it binds a strict field) - -While (A) is a necessary condition to give a field the CPR property, there are -ways in which (B) and (C) are too lax, leading to unsound analysis results and -thus reboxing in the wrapper: - - (b) We could scrutinise some other variable than a parameter, like in - - g :: T Int -> Int - g x = let z = foo x in -- assume `z` has CPR property - case z of MkT y -> y - - Lacking Nested CPR and multiple levels of unboxing, only the outer box - of `z` will be available and a case on `y` won't actually cancel away. - But it's simple, and nothing terrible happens if we get it wrong. e.g. - #10694. - - (c) A strictly used field binder doesn't mean the function is strict in it. - - h :: T Int -> Int -> Int - h !x 0 = 0 - h x 0 = case x of MkT y -> y - - Here, `y` is used strictly, but the field of `x` certainly is not and - consequently will not be available unboxed. - Why not look at the demand of `x` instead to determine whether `y` is - unboxed? Because the 'idDemandInfo' on `x` will not have been propagated - to its occurrence in the scrutinee when CprAnal runs directly after - DmdAnal. - -We used to give the case binder the CPR property unconditionally instead of -deriving it from the case scrutinee. -See Historical Note [Optimistic case binder CPR]. - -Historical Note [Optimistic case binder CPR] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We used to give the case binder the CPR property unconditionally, which is too -optimistic (#19232). Here are the details: - -Inside the alternative, the case binder always has the CPR property, meaning -that a case on it will successfully cancel. -Example: - f True x = case x of y { I# x' -> if x' ==# 3 - then y - else I# 8 } - f False x = I# 3 -By giving 'y' the CPR property, we ensure that 'f' does too, so we get - f b x = case fw b x of { r -> I# r } - fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } - fw False x = 3 -Of course there is the usual risk of re-boxing: we have 'x' available boxed -and unboxed, but we return the unboxed version for the wrapper to box. If the -wrapper doesn't cancel with its caller, we'll end up re-boxing something that -we did have available in boxed form. - Note [CPR for sum types] ~~~~~~~~~~~~~~~~~~~~~~~~ +Aug 21: This Note is out of date. It says that the subsequent WW split after +CPR for sum types destroys join points, but that is no longer correct; we have +the tools to track join points today and simply don't WW join points, +see Note [Don't w/w join points for CPR]. +Yet the issue persists. It is tracked in #5075 and the ultimate reason is a bit +unclear. All regressions involve CPR'ing functions returning lists, which are +recursive data structures. If we don't CPR them +(due to Note [CPR for recursive data constructors]), we might be able to finally +remove this hack, after doing the proper perf checks. + +Historic Note: + At the moment we do not do CPR for let-bindings that * non-top level * bind a sum type @@ -765,65 +858,278 @@ Long static data structures (whether top-level or not) like xs1 = x2 : xs2 xs2 = x3 : xs3 -should not get CPR signatures (#18154), because they +should not get (nested) CPR signatures (#18154), because they * Never get WW'd, so their CPR signature should be irrelevant after analysis (in fact the signature might even be harmful for that reason) * Would need to be inlined/expanded to see their constructed product - * Recording CPR on them blows up interface file sizes and is redundant with + * BUT MOST IMPORTANTLY, Problem P1: + Recording CPR on them blows up interface file sizes and is redundant with their unfolding. In case of Nested CPR, this blow-up can be quadratic! Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info for xs2 contains that for xs1. And so on. + By contrast, the size of unfoldings and types stays linear. That's why + quadratic blowup is problematic; it makes an asymptotic difference. -Hence we don't analyse or annotate data structures in 'cprAnalBind'. To -implement this, the isDataStructure guard is triggered for bindings that satisfy +Hence (Solution S1) we don't give data structure bindings a CPR *signature* and +hence don't to analyse them in 'cprAnalBind'. +What do we mean by "data structure binding"? Answer: - (1) idArity id == 0 (otherwise it's a function) - (2) exprIsHNF rhs (otherwise it's a thunk, Note [CPR for thunks] applies) + (1) idArity id == 0 (otherwise it's a function) + (2) is eval'd (otherwise it's a thunk, Note [CPR for thunks] applies) + (3) not (isJoinId id) (otherwise it's a function and its more efficient to + analyse it just once rather than at each call site) -But we can't just stop giving DataCon application bindings the CPR *property*, -for example +But (S1) leads to a new Problem P2: We can't just stop giving DataCon application +bindings the CPR *property*, for example the factorial function after FloatOut - fac 0 = I# 1# + lvl = I# 1# + fac 0 = lvl fac n = n * fac (n-1) -fac certainly has the CPR property and should be WW'd! But FloatOut will -transform the first clause to +lvl is a data structure, and hence (see above) will not have a CPR *signature*. +But if lvl doesn't have the CPR *property*, fac won't either and we allocate a +box for the result on every iteration of the loop. - lvl = I# 1# - fac 0 = lvl +So (Solution S2) when 'cprAnal' meets a variable lacking a CPR signature to +extrapolate into a CPR transformer, 'cprTransform' tries to get its unfolding +(via 'cprDataStructureUnfolding_maybe'), and analyses that instead. + +The Result R1: Everything behaves as if there was a CPR signature, but without +the blowup in interface files. -If lvl doesn't have the CPR property, fac won't either. But lvl is a data -structure, and hence (see above) will not have a CPR signature. So instead, when -'cprAnal' meets a variable lacking a CPR signature to extrapolate into a CPR -transformer, 'cprTransform' instead tries to get its unfolding (via -'cprDataStructureUnfolding_maybe'), and analyses that instead. +There is one exception to (R1): -In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one -for each data declaration. They should not have CPR signatures (blow up!). + x = (y, z); {-# NOINLINE x #-} + f p = (y, z); {-# NOINLINE f #-} -There is a perhaps surprising special case: KindRep bindings satisfy -'isDataStructure' (so no CPR signature), but are marked NOINLINE at the same -time (see the noinline wrinkle in Note [Grand plan for Typeable]). So there is -no unfolding for 'cprDataStructureUnfolding_maybe' to look through and we'll -return topCprType. And that is fine! We should refrain to look through NOINLINE -data structures in general, as a constructed product could never be exposed -after WW. +While we still give the NOINLINE *function* 'f' the CPR property (and WW +accordingly, see Note [Worker/wrapper for NOINLINE functions]), we won't +give the NOINLINE *data structure* 'x' the CPR property, because it lacks an +unfolding. In particular, KindRep bindings are NOINLINE data structures (see +the noinline wrinkle in Note [Grand plan for Typeable]). We'll behave as if the +bindings had 'topCprSig', and that is fine, as a case on the binding would never +cancel away after WW! -It's also worth pointing out how ad-hoc this is: If we instead had +It's also worth pointing out how ad-hoc (S1) is: If we instead had f1 x = x:[] f2 x = x : f1 x f3 x = x : f2 x ... -we still give every function an every deepening CPR signature. But it's very +we still give every function an ever deepening CPR signature. But it's very uncommon to find code like this, whereas the long static data structures from the beginning of this Note are very common because of GHC's strategy of ANF'ing data structure RHSs. +Note [CPR for data structures can destroy sharing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Note [CPR for data structures], we argued that giving data structure bindings +the CPR property is useful to give functions like fac the CPR property: + + lvl = I# 1# + fac 0 = lvl + fac n = n * fac (n-1) + +Worker/wrappering fac for its CPR property means we get a very fast worker +function with type Int# -> Int#, without any heap allocation at all. + +But consider what happens if we call `map fac (replicate n 0)`, where the +wrapper doesn't cancel away: Then we rebox the result of $wfac *on each call*, +n times, instead of reusing the static thunk for 1, e.g. an asymptotic increase +in allocations. If you twist it just right, you can actually write programs that +that take O(n) space if you do CPR and O(1) if you don't: + + fac :: Int -> Int + fac 0 = 1 -- this clause will trigger CPR and destroy sharing for O(n) space + -- fac 0 = lazy 1 -- this clause will prevent CPR and run in O(1) space + fac n = n * fac (n-1) + + const0 :: Int -> Int + const0 n = signum n - 1 -- will return 0 for [1..n] + {-# NOINLINE const0 #-} + + main = print $ foldl' (\acc n -> acc + lazy n) 0 $ map (fac . const0) [1..100000000] + +Generally, this kind of asymptotic increase in allocation can happen whenever we +give a data structure the CPR property that is bound outside of a recursive +function. So far we don't have a convincing remedy; giving fac the CPR property +is just too attractive. #19309 documents a futile idea. #13331 tracks the +general issue of WW destroying sharing and also contains above reproducer. +#19326 is about CPR destroying sharing in particular. + +With Nested CPR, sharing can also be lost within the same "lambda level", for +example: + + f (I# x) = let y = I# (x*#x) in (y, y) + +Nestedly unboxing would destroy the box shared through 'y'. (Perhaps we can call +this "internal sharing", in contrast to "external sharing" beyond lambda or even +loop levels above.) But duplicate occurrences like that are pretty rare and may +never lead to an asymptotic difference in allocations of 'f'. + +Note [CPR for recursive data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [CPR for data structures can destroy sharing] gives good reasons not to +give shared data structure bindings the CPR property. But we shouldn't even +give *functions* that return *recursive* data constructor applications the CPR +property. Here's an example for why: + + c = C# 'a' + replicateC :: Int -> [Int] + replicateC 1 = [c] + replicateC n = c : replicateC (n-1) + +What happens if we give `replicateC` the (nested) CPR property? We get a WW +split for 'replicateC', the wrapper of which is certain to inline, like this: + + replicateC (I# n) = case $wreplicateC n of (# x, xs #) -> C# x : xs + $wreplicateC 1# = (# 'a', [] #) + $wreplicateC n = (# 'a', replicateC (I# (n -# 1#)) #) + +Eliminating the shared 'c' binding in the process. And then + + * We *might* save allocation of the topmost (of most likely several) (:) + constructor if it cancels away at the call site. Similarly for the 'C#' + constructor. + * But we will now re-allocate the C# box on every iteration of the loop, + because we separated the character literal from the C# application. + That means n times as many C# allocations as before. Yikes!! + * We make all other call sites where the wrapper inlines a bit larger, most of + them for no gain. But this shouldn't matter much. + * The inlined wrapper may inhibit eta-expansion in some cases. Here's how: + If the wrapper is inlined in a strict arg position, the Simplifier will + transform as follows + + f (replicateC n) + ==> { inline } + f (case $wreplicateC n of (# x, xs #) -> (C# x, xs)) + ==> { strict arg } + case $wreplicateC n of (# x, xs #) -> f (C# x, xs) + + Now we can't float out the case anymore. In fact, we can't even float out + `$wreplicateC n`, because it returns an unboxed tuple. + This can inhibit eta-expansion if we later find out that `f` has arity > 1 + (such as when we define `foldl` in terms of `foldr`). #19970 shows how + abstaining from worker/wrappering made a difference of -20% in reptile. So + while WW'ing for CPR didn't make the program slower directly, the resulting + program got much harder to optimise because of the returned unboxed tuple + (which can't easily float because unlifted). + +`replicateC` comes up in T5536, which regresses significantly if CPR'd nestedly. + +What can we do about it? + + A. Don't CPR functions that return a *recursive data type* (the list in this + case). This is the solution we adopt. Rationale: the benefit of CPR on + recursive data structures is slight, because it only affects the outer layer + of a potentially massive data structure. + B. Don't CPR any *recursive function*. That would be quite conservative, as it + would also affect e.g. the factorial function. + C. Flat CPR only for recursive functions. This prevents the asymptotic + worsening part arising through unsharing the C# box, but it's still quite + conservative. + D. No CPR at occurrences of shared data structure in hot paths (e.g. the use of + `c` in the second eqn of `replicateC`). But we'd need to know which paths + were hot. We want such static branch frequency estimates in #20378. + +We adopt solution (A) It is ad-hoc, but appears to work reasonably well. +Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too: +See Note [Detecting recursive data constructors]. We don't have to be perfect +and can simply keep on unboxing if unsure. + +Note [Detecting recursive data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What qualifies as a "recursive data constructor" as per +Note [CPR for recursive data constructors]? That is up to +'GHC.Core.Opt.WorkWrapW.Utils.isRecDataCon' to decide. It does a DFS search over +the field types of the DataCon and looks for term-level recursion into the data +constructor's type constructor. A few perhaps surprising points: + + 1. It deems any function type as non-recursive, because it's unlikely that + a recursion through a function type builds up a recursive data structure. + 2. It doesn't look into kinds or coercion types because there's nothing to unbox. + Same for promoted data constructors. + 3. We don't care whether a NewTyCon or DataTyCon App is fully saturated or not; + we simply look at its definition/DataCons and its field tys. Any recursive arg + occs will have been detected before (see the invariant of 'go_tc_app'). + This is so that we expand the `ST` in `StateT Int (ST s) a`. + 4. We don't recurse deeper than 3 (at the moment of this writing) TyCons and + assume the DataCon is non-recursive after that. One reason is guaranteed + constant-time efficiency; the other is that it's fair to say that a recursion + over 3 or more TyCons doesn't really count as a list-like data structure + anymore and a bit of unboxing doesn't hurt much. + 5. It checks TyConApps like `T <huge> <type>` by eagerly checking the + potentially huge argument types *before* it tries to expand the + DataCons/NewTyCon/TyFams/etc. so that it doesn't need to re-check those + argument types after having been substituted into every occurrence of + the the respective TyCon parameter binders. It's like call-by-value vs. + call-by-name: Eager checking of argument types means we only need to check + them exactly once. + There's one exception to that rule, namely when we are able to reduce a + TyFam by considering argument types. Then we pay the price of potentially + checking the same type arg twice (or more, if the TyFam is recursive). + It should hardly matter. + 6. As a result of keeping the implementation simple, it says "recursive" + for `data T = MkT [T]`, even though we could argue that the inner recursion + (through the `[]` TyCon) by way of which `T` is recursive will already be + "broken" and thus never unboxed. Consequently, it might be OK to CPR a + function returning `T`. Lacking arguments for or against the current simple + behavior, we stick to it. + 7. When the search hits an abstract TyCon (one without visible DataCons, e.g., + from an .hs-boot file), it returns 'Nothing' for "inconclusive", the same + as when we run out of fuel. If there is ever a recursion through an + abstract TyCon, then it's not part of the same function we are looking at, + so we can treat it as if it wasn't recursive. + +Here are a few examples of data constructors or data types with a single data +con and the answers of our function: + + data T = T (Int, (Bool, Char)) NonRec + (:) Rec + [] NonRec + data U = U [Int] NonRec + data U2 = U2 [U2] Rec (see point (6)) + data T1 = T1 T2; data T2 = T2 T1 Rec + newtype Fix f = Fix (f (Fix f)) Rec + data N = N (Fix (Either Int)) NonRec + data M = M (Fix (Either M)) Rec + data F = F (F -> Int) NonRec (see point (1)) + data G = G (Int -> G) NonRec (see point (1)) + newtype MyM s a = MyM (StateT Int (ST s) a NonRec + type S = (Int, Bool) NonRec + + { type family E a where + E Int = Char + E (a,b) = (E a, E b) + E Char = Blub + data Blah = Blah (E (Int, (Int, Int))) NonRec (see point (5)) + data Blub = Blub (E (Char, Int)) Rec + data Blub2 = Blub2 (E (Bool, Int)) } Rec, because stuck + + { data T1 = T1 T2; data T2 = T2 T3; + ... data T5 = T5 T1 } Nothing (out of fuel) (see point (4)) + + { module A where -- A.hs-boot + data T + module B where + import {-# SOURCE #-} A + data U = MkU T + f :: T -> U + f t = MkU t Nothing (T is abstract) (see point (7)) + module A where -- A.hs + import B + data T = MkT U } + +These examples are tested by the testcase RecDataConCPR. + +I've played with the idea to make points (1) through (3) of 'isRecDataCon' +configurable like (4) to enable more re-use throughout the compiler, but haven't +found a killer app for that yet, so ultimately didn't do that. + Note [CPR examples] -~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~ Here are some examples (stranal/should_compile/T10482a) of the usefulness of Note [Optimistic field binder CPR]. The main point: all of these functions can have the CPR property. @@ -846,4 +1152,84 @@ point: all of these functions can have the CPR property. f1 :: T3 -> Int f1 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) | otherwise = x + +Historic Note [Optimistic field binder CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note describes how we used to guess whether fields have the CPR property +before we were able to express Nested CPR for arguments. + +Consider + + data T a = MkT a + f :: T Int -> Int + f x = ... (case x of + MkT y -> y) ... + +And assume we know from strictness analysis that `f` is strict in `x` and its +field `y` and we unbox both. Then we give `x` the CPR property according +to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y` +likewise will be unboxed and it should also get the CPR property. We'd +need a *nested* CPR property here for `x` to express that and unwrap one level +when we analyse the Case to give the CPR property to `y`. + +Lacking Nested CPR (hence this Note is historic now that we have Nested CPR), we +have to guess a bit, by looking for + + (A) Flat CPR on the scrutinee + (B) A variable scrutinee. Otherwise surely it can't be a parameter. + (C) Strict demand on the field binder `y` (or it binds a strict field) + +While (A) is a necessary condition to give a field the CPR property, there are +ways in which (B) and (C) are too lax, leading to unsound analysis results and +thus reboxing in the wrapper: + + (b) We could scrutinise some other variable than a parameter, like in + + g :: T Int -> Int + g x = let z = foo x in -- assume `z` has CPR property + case z of MkT y -> y + + Lacking Nested CPR and multiple levels of unboxing, only the outer box + of `z` will be available and a case on `y` won't actually cancel away. + But it's simple, and nothing terrible happens if we get it wrong. e.g. + #10694. + + (c) A strictly used field binder doesn't mean the function is strict in it. + + h :: T Int -> Int -> Int + h !x 0 = 0 + h x 0 = case x of MkT y -> y + + Here, `y` is used strictly, but the field of `x` certainly is not and + consequently will not be available unboxed. + Why not look at the demand of `x` instead to determine whether `y` is + unboxed? Because the 'idDemandInfo' on `x` will not have been propagated + to its occurrence in the scrutinee when CprAnal runs directly after + DmdAnal. + +We used to give the case binder the CPR property unconditionally instead of +deriving it from the case scrutinee. +See Historic Note [Optimistic case binder CPR]. + +Historic Note [Optimistic case binder CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to give the case binder the CPR property unconditionally, which is too +optimistic (#19232). Here are the details: + +Inside the alternative, the case binder always has the CPR property, meaning +that a case on it will successfully cancel. +Example: + f True x = case x of y { I# x' -> if x' ==# 3 + then y + else I# 8 } + f False x = I# 3 +By giving 'y' the CPR property, we ensure that 'f' does too, so we get + f b x = case fw b x of { r -> I# r } + fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } + fw False x = 3 +Of course there is the usual risk of re-boxing: we have 'x' available boxed +and unboxed, but we return the unboxed version for the wrapper to box. If the +wrapper doesn't cancel with its caller, we'll end up re-boxing something that +we did have available in boxed form. + -} diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index beafa01b1c..50200d18b0 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -11,7 +11,7 @@ module GHC.Core.Opt.WorkWrap.Utils ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one, mkWorkerArgs , DataConPatContext(..) , UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnboxArg - , findTypeShape, mkAbsentFiller + , findTypeShape, mkAbsentFiller, IsRecDataConResult(..), isRecDataCon , isWorkerSmallEnough ) where @@ -47,6 +47,7 @@ import GHC.Types.Unique.Supply import GHC.Types.Name ( getOccFS ) import GHC.Data.FastString +import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Data.List.SetOps @@ -617,9 +618,8 @@ addDataConStrictness con ds wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr -- See Note [Which types are unboxed?] wantToUnboxResult fam_envs ty cpr - | Just (con_tag, _cprs) <- asConCpr cpr + | Just (con_tag, arg_cprs) <- asConCpr cpr , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty - , isDataTyCon tc -- NB: No unboxed sums or tuples , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning , dcs `lengthAtLeast` con_tag -- This might not be true if we import the -- type constructor via a .hs-boot file (#8743) @@ -632,7 +632,7 @@ wantToUnboxResult fam_envs ty cpr -- Deactivates CPR worker/wrapper splits on constructors with non-linear -- arguments, for the moment, because they require unboxed tuple with variable -- multiplicity fields. - = Unbox (DataConPatContext dc tc_args co) [] + = Unbox (DataConPatContext dc tc_args co) arg_cprs | otherwise = StopUnboxing @@ -657,6 +657,7 @@ Worker/wrapper will unbox * has a single constructor (thus is a "product") * that may bind existentials We can transform + > data D a = forall b. D a b > f (D @ex a b) = e to > $wf @ex a b = e @@ -1215,6 +1216,18 @@ fragile ************************************************************************ -} +-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that +-- the 'DataCon' may not have existentials. The lack of cloning the existentials +-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\"; +-- only use it where type variables aren't substituted for! +dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type] +dubiousDataConInstArgTys dc tc_args = arg_tys + where + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyCoVars dc + subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs + arg_tys = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc) + findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type -- The data type TypeShape is defined in GHC.Types.Demand @@ -1252,6 +1265,8 @@ findTypeShape fam_envs ty -- The use of 'dubiousDataConInstArgTys' is OK, since this -- function performs no substitution at all, hence the uniques -- don't matter. + -- We really do encounter existentials here, see + -- Note [Which types are unboxed?] for an example. = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args)) | Just (ty', _) <- instNewTyCon_maybe tc tc_args @@ -1261,17 +1276,122 @@ findTypeShape fam_envs ty | otherwise = TsUnk --- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that --- the 'DataCon' may not have existentials. The lack of cloning the existentials --- compared to 'dataConInstExAndArgVars' makes this function \"dubious\"; --- only use it where type variables aren't substituted for! -dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type] -dubiousDataConInstArgTys dc tc_args = arg_tys +-- | Returned by 'isRecDataCon'. +-- See also Note [Detecting recursive data constructors]. +data IsRecDataConResult + = DefinitelyRecursive -- ^ The algorithm detected a loop + | NonRecursiveOrUnsure -- ^ The algorithm detected no loop, went out of fuel + -- or hit an .hs-boot file + deriving (Eq, Show) + +instance Outputable IsRecDataConResult where + ppr = text . show + +combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult +combineIRDCR DefinitelyRecursive _ = DefinitelyRecursive +combineIRDCR _ DefinitelyRecursive = DefinitelyRecursive +combineIRDCR _ _ = NonRecursiveOrUnsure + +combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult +combineIRDCRs = foldl' combineIRDCR NonRecursiveOrUnsure +{-# INLINE combineIRDCRs #-} + +-- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns +-- +-- * @Just Recursive@ if the analysis found that @tc@ is reachable through one +-- of @dc@'s fields +-- * @Just NonRecursive@ if the analysis found that @tc@ is not reachable +-- through one of @dc@'s fields +-- * @Nothing@ is returned in two cases. The first is when @fuel /= Infinity@ +-- and @f@ expansions of nested data TyCons were not enough to prove +-- non-recursivenss, nor arrive at an occurrence of @tc@ thus proving +-- recursiveness. The other is when we hit an abstract TyCon (one without +-- visible DataCons), such as those imported from .hs-boot files. +-- +-- If @fuel = 'Infinity'@ and there are no boot files involved, then the result +-- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int' +-- f@, then the analysis behaves like a depth-limited DFS and returns @Nothing@ +-- if the search was inconclusive. +-- +-- See Note [Detecting recursive data constructors] for which recursive DataCons +-- we want to flag. +isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult +isRecDataCon fam_envs fuel dc + | isTupleDataCon dc || isUnboxedSumDataCon dc + = NonRecursiveOrUnsure + | otherwise + = -- pprTrace "isRecDataCon" (ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) + answer where - univ_tvs = dataConUnivTyVars dc - ex_tvs = dataConExTyCoVars dc - subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs - arg_tys = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc) + answer = go_dc fuel (setRecTcMaxBound 1 initRecTc) dc + (<||>) = combineIRDCR + + go_dc :: IntWithInf -> RecTcChecker -> DataCon -> IsRecDataConResult + go_dc fuel rec_tc dc = + combineIRDCRs [ go_arg_ty fuel rec_tc (scaledThing arg_ty) + | arg_ty <- dataConRepArgTys dc ] + + go_arg_ty :: IntWithInf -> RecTcChecker -> Type -> IsRecDataConResult + go_arg_ty fuel rec_tc ty + | Just (_, _arg_ty, _res_ty) <- splitFunTy_maybe ty + -- = go_arg_ty fuel rec_tc _arg_ty <||> go_arg_ty fuel rec_tc _res_ty + -- Plausible, but unnecessary for CPR. + -- See Note [Detecting recursive data constructors], point (1) + = NonRecursiveOrUnsure + + | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty + = go_arg_ty fuel rec_tc ty' + -- See Note [Detecting recursive data constructors], point (2) + + | Just (tc, tc_args) <- splitTyConApp_maybe ty + = combineIRDCRs (map (go_arg_ty fuel rec_tc) tc_args) + <||> go_tc_app fuel rec_tc tc tc_args + + | otherwise + = NonRecursiveOrUnsure + + -- | PRECONDITION: tc_args has no recursive occs + -- See Note [Detecting recursive data constructors], point (5) + go_tc_app :: IntWithInf -> RecTcChecker -> TyCon -> [Type] -> IsRecDataConResult + go_tc_app fuel rec_tc tc tc_args + --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined + + | tc == dataConTyCon dc + = DefinitelyRecursive -- loop found! + + | isPrimTyCon tc + = NonRecursiveOrUnsure + + | not $ tcIsRuntimeTypeKind $ tyConResKind tc + = NonRecursiveOrUnsure + + | isAbstractTyCon tc -- When tc has no DataCons, from an hs-boot file + = NonRecursiveOrUnsure -- See Note [Detecting recursive data constructors], point (7) + + | isFamilyTyCon tc + -- This is the only place where we look at tc_args + -- See Note [Detecting recursive data constructors], point (5) + = case topReduceTyFamApp_maybe fam_envs tc tc_args of + Just (HetReduction (Reduction _ rhs) _) -> go_arg_ty fuel rec_tc rhs + Nothing -> DefinitelyRecursive -- we hit this case for 'Any' + + | otherwise + = assertPpr (isAlgTyCon tc) (ppr tc <+> ppr dc) $ + case checkRecTc rec_tc tc of + Nothing -> NonRecursiveOrUnsure + -- we expanded this TyCon once already, no need to test it multiple times + + Just rec_tc' + | Just (_tvs, rhs, _co) <- unwrapNewTyConEtad_maybe tc + -- See Note [Detecting recursive data constructors], points (2) and (3) + -> go_arg_ty fuel rec_tc' rhs + + | fuel < 0 + -> NonRecursiveOrUnsure -- that's why we track fuel! + + | let dcs = expectJust "isRecDataCon:go_tc_app" $ tyConDataCons_maybe tc + -> combineIRDCRs (map (\dc -> go_dc (subWithInf fuel 1) rec_tc' dc) dcs) + -- See Note [Detecting recursive data constructors], point (4) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs index 12ccd6516b..faced2f27c 100644 --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -52,6 +52,7 @@ mkPmId ty = getUniqueM >>= \unique -> let occname = mkVarOccFS $ fsLit "pm" name = mkInternalName unique occname noSrcSpan in return (mkLocalIdOrCoVar name Many ty) +{-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough -- | All warning flags that need to run the pattern match checker. allPmCheckWarnings :: [WarningFlag] diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index b28ef41cae..db4b8f9e23 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -95,7 +95,7 @@ module GHC.Types.Basic ( SuccessFlag(..), succeeded, failed, successIf, - IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, + IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit, SpliceExplicitFlag(..), @@ -1699,6 +1699,11 @@ mulWithInf Infinity _ = Infinity mulWithInf _ Infinity = Infinity mulWithInf (Int a) (Int b) = Int (a * b) +-- | Subtract an 'Int' from an 'IntWithInf' +subWithInf :: IntWithInf -> Int -> IntWithInf +subWithInf Infinity _ = Infinity +subWithInf (Int a) b = Int (a - b) + -- | Turn a positive number into an 'IntWithInf', where 0 represents infinity treatZeroAsInf :: Int -> IntWithInf treatZeroAsInf 0 = Infinity diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs index c07b614e58..2405b8f524 100644 --- a/compiler/GHC/Types/Cpr.hs +++ b/compiler/GHC/Types/Cpr.hs @@ -33,6 +33,8 @@ data Cpr -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern -- synonym 'ConCpr'. | FlatConCpr !ConTag + -- ^ @FlatConCpr tag@ is an efficient encoding for @'ConCpr_' tag [TopCpr..]@. + -- Purely for compiler perf. Can be constructed with 'ConCpr'. | TopCpr deriving Eq @@ -169,12 +171,9 @@ newtype CprSig = CprSig { getCprSig :: CprType } -- unleashable at that arity. See Note [Understanding DmdType and DmdSig] in -- "GHC.Types.Demand" mkCprSigForArity :: Arity -> CprType -> CprSig -mkCprSigForArity arty ty@(CprType n cpr) - | arty /= n = topCprSig - -- Trim on arity mismatch - | ConCpr t _ <- cpr = CprSig (CprType n (flatConCpr t)) - -- Flatten nested CPR info, we don't exploit it (yet) - | otherwise = CprSig ty +mkCprSigForArity arty ty@(CprType n _) + | arty /= n = topCprSig -- Trim on arity mismatch + | otherwise = CprSig ty topCprSig :: CprSig topCprSig = CprSig topCprType @@ -189,14 +188,14 @@ seqCprSig :: CprSig -> () seqCprSig (CprSig ty) = seqCprTy ty -- | BNF: --- ``` --- cpr ::= '' -- TopCpr --- | n -- FlatConCpr n --- | n '(' cpr1 ',' cpr2 ',' ... ')' -- ConCpr n [cpr1,cpr2,...] --- | 'b' -- BotCpr --- ``` +-- +-- > cpr ::= '' -- TopCpr +-- > | n -- FlatConCpr n +-- > | n '(' cpr1 ',' cpr2 ',' ... ')' -- ConCpr n [cpr1,cpr2,...] +-- > | 'b' -- BotCpr +-- -- Examples: --- * `f x = f x` has denotation `b` +-- * `f x = f x` has result CPR `b` -- * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`. instance Outputable Cpr where ppr TopCpr = empty @@ -204,8 +203,18 @@ instance Outputable Cpr where ppr (ConCpr n cs) = int n <> parens (pprWithCommas ppr cs) ppr BotCpr = char 'b' +-- | BNF: +-- +-- > cpr_ty ::= cpr -- short form if arty == 0 +-- > | '\' arty '.' cpr -- if arty > 0 +-- +-- Examples: +-- * `f x y z = f x y z` has denotation `\3.b` +-- * `g !x = (x+1, x+2)` has denotation `\1.1(1,1)`. instance Outputable CprType where - ppr (CprType arty res) = ppr arty <> ppr res + ppr (CprType arty res) + | 0 <- arty = ppr res + | otherwise = char '\\' <> ppr arty <> char '.' <> ppr res -- | Only print the CPR result instance Outputable CprSig where diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 88a7a211cd..7239998b5d 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -581,7 +581,6 @@ mkDataConWorkId wkr_name data_con ----------- Workers for data types -------------- alg_wkr_info = noCafIdInfo `setArityInfo` wkr_arity - `setCprSigInfo` mkCprSig wkr_arity (dataConCPR data_con) `setInlinePragInfo` wkr_inline_prag `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 @@ -608,31 +607,6 @@ mkDataConWorkId wkr_name data_con mkLams univ_tvs $ Lam id_arg1 $ wrapNewTypeBody tycon res_ty_args (Var id_arg1) -dataConCPR :: DataCon -> Cpr -dataConCPR con - | isDataTyCon tycon -- Real data types only; that is, - -- not unboxed tuples or newtypes - , null (dataConExTyCoVars con) -- No existentials - , wkr_arity > 0 - , wkr_arity <= mAX_CPR_SIZE - = flatConCpr (dataConTag con) - | otherwise - = topCpr - where - tycon = dataConTyCon con - wkr_arity = dataConRepArity con - - mAX_CPR_SIZE :: Arity - mAX_CPR_SIZE = 10 - -- We do not treat very big tuples as CPR-ish: - -- a) for a start we get into trouble because there aren't - -- "enough" unboxed tuple types (a tiresome restriction, - -- but hard to fix), - -- b) more importantly, big unboxed tuples get returned mainly - -- on the stack, and are often then allocated in the heap - -- by the caller. So doing CPR for them may in fact make - -- things worse. - {- ------------------------------------------------- -- Data constructor representation @@ -709,7 +683,6 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con `setInlinePragInfo` wrap_prag `setUnfoldingInfo` wrap_unf `setDmdSigInfo` wrap_sig - `setCprSigInfo` mkCprSig wrap_arity (dataConCPR data_con) -- We need to get the CAF info right here because GHC.Iface.Tidy -- does not tidy the IdInfo of implicit bindings (like the wrapper) -- so it not make sure that the CAF info is sane diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs index e2ecb16355..57dd8e10ab 100644 --- a/compiler/GHC/Types/Unique/Supply.hs +++ b/compiler/GHC/Types/Unique/Supply.hs @@ -254,7 +254,7 @@ uniqFromMask :: Char -> IO Unique uniqFromMask !mask = do { uqNum <- genSym ; return $! mkUnique mask uqNum } - +{-# NOINLINE uniqFromMask #-} -- We'll unbox everything, but we don't want to inline it splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) -- ^ Build two 'UniqSupply' from a single one, each of which diff --git a/testsuite/tests/arityanal/should_compile/T18793.hs b/testsuite/tests/arityanal/should_compile/T18793.hs index 6dfdcf05ee..0dd466a1b3 100644 --- a/testsuite/tests/arityanal/should_compile/T18793.hs +++ b/testsuite/tests/arityanal/should_compile/T18793.hs @@ -2,7 +2,7 @@ module T18793 where stuff :: Int -> [Int] {-# NOINLINE stuff #-} -stuff i = [i,i+1,i+2] +stuff !i = [i,i+1,i+2] -- The bang is so that we get a WW split f :: Int -> Int f = foldr k id (stuff 1) diff --git a/testsuite/tests/arityanal/should_compile/T18793.stderr b/testsuite/tests/arityanal/should_compile/T18793.stderr index ca73ba7157..6ea36558be 100644 --- a/testsuite/tests/arityanal/should_compile/T18793.stderr +++ b/testsuite/tests/arityanal/should_compile/T18793.stderr @@ -1,21 +1,20 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 81, types: 74, coercions: 0, joins: 0/0} +Result size of Tidy Core = {terms: 66, types: 43, 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=<LP(L)>, 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: 15, types: 5, coercions: 0, joins: 0/0} +T18793.$wstuff [InlPrag=NOINLINE] :: GHC.Prim.Int# -> [Int] +[GblId, Arity=1, Str=<L>, Unf=OtherCon []] +T18793.$wstuff = \ (ww :: GHC.Prim.Int#) -> GHC.Types.: @Int (GHC.Types.I# ww) (GHC.Types.: @Int (GHC.Types.I# (GHC.Prim.+# ww 1#)) (GHC.Types.: @Int (GHC.Types.I# (GHC.Prim.+# ww 2#)) (GHC.Types.[] @Int))) --- RHS size: {terms: 8, types: 11, coercions: 0, joins: 0/0} +-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} stuff [InlPrag=[final]] :: Int -> [Int] [GblId, Arity=1, - Str=<LP(L)>, - Cpr=2, + Str=<1P(L)>, 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 { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> GHC.Types.: @Int ww ww1 }}] -stuff = \ (w :: Int) -> case T18793.$wstuff w of { (# ww, ww1 #) -> GHC.Types.: @Int ww ww1 } + Tmpl= \ (w [Occ=Once1!] :: Int) -> case w of { GHC.Types.I# ww [Occ=Once1] -> T18793.$wstuff ww }}] +stuff = \ (w :: Int) -> case w of { GHC.Types.I# ww -> T18793.$wstuff ww } Rec { -- RHS size: {terms: 23, types: 11, coercions: 0, joins: 0/0} @@ -46,14 +45,9 @@ T18793.f_go1 [InlPrag=[2]] :: [Int] -> Int -> Int T18793.f_go1 = \ (w :: [Int]) (w1 :: Int) -> case w1 of { GHC.Types.I# ww -> case T18793.$wgo1 w ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T18793.f2 :: Int -[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -T18793.f2 = GHC.Types.I# 1# - --- RHS size: {terms: 7, types: 10, coercions: 0, joins: 0/0} T18793.f1 :: [Int] -[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 40 10}] -T18793.f1 = case T18793.$wstuff T18793.f2 of { (# ww, ww1 #) -> GHC.Types.: @Int ww ww1 } +[GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}] +T18793.f1 = T18793.$wstuff 1# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} f :: Int -> Int diff --git a/testsuite/tests/cpranal/should_compile/T18174.hs b/testsuite/tests/cpranal/should_compile/T18174.hs new file mode 100644 index 0000000000..bf1c02982c --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18174.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp #-} +{-# LANGUAGE BangPatterns #-} + +module T18174 (fac1, fac2, fac3, facIO, dataConWrapper, strictField, thunkDiverges, h1, h2) where + +---------------------------------------------------------------------- +-- First some basic examples that we want to CPR nestedly for the Int. + +-- pretty strict +fac1 :: Int -> a -> (a, Int) +fac1 n s | n < 2 = (s,1) + | otherwise = case fac1 (n-1) s of (s',n') -> let n'' = n*n' in n'' `seq` (s',n'') + +-- lazier, but Int still would be fine to have CPR. +-- !1866 catches it, but Nested CPR light does not. +fac2 :: Int -> a -> (a, Int) +fac2 n s | n < 2 = (s,1) + | otherwise = case fac2 (n-1) s of (s',n') -> (s',n'*n') + +-- even lazier, but evaluation of the Int doesn't terminate rapidly! +-- Thus, we may not WW for the nested Int. +-- Otherwise @fac3 99999 () `seq` ()@ (which should terminate rapidly) +-- evaluates more than necessary. +fac3 :: Int -> a -> (a, Int) +fac3 n s | n < 2 = (s,1) + | otherwise = let (s',n') = fac3 (n-1) s in (s',n'*n') + +-- This one is like face2. +-- !1866 manages to unbox the Int, but Nested CPR does not. +facIO :: Int -> IO Int +facIO n | n < 2 = return 1 + | otherwise = do n' <- facIO (n-1); return (n*n') + +-- Now some checks wrt. strict fields where we don't want to unbox. + +data T = MkT Int !(Int, Int) + +-- | Should not unbox any component, because the wrapper of 'MkT' forces +-- 'p', which this function is lazy in. Similarly for 'x'. +dataConWrapper :: (Int, Int) -> Int -> (T, Int) +dataConWrapper p x = (MkT x p, x+1) +{-# NOINLINE dataConWrapper #-} + +-- | Should not unbox the second component, because 'x' won't be available +-- unboxed. It terminates, though. +strictField :: T -> (Int, (Int, Int)) +strictField (MkT x y) = (x, y) +{-# NOINLINE strictField #-} + +-- | Should not unbox the first component, because 'x' might not terminate. +thunkDiverges :: Int -> (Int, Bool) +thunkDiverges x = (let t = x+1 in t+t, False) + +---------------------------------------------------------------------- +-- The following functions are copied from T18894. This test is about +-- *exploiting* the demand signatures that we assertedly (by T18894) +-- annotate. + +g1 :: Int -> (Int,Int) +g1 1 = (15, 0) +g1 n = (2 * n, 2 `div` n) +{-# NOINLINE g1 #-} + +-- | Sadly, the @g1 2@ subexpression will be floated to top-level, where we +-- don't see the specific demand placed on it by @snd@. Tracked in #19001. +h1 :: Int -> Int +h1 1 = 0 +h1 2 = snd (g1 2) +h1 m = uncurry (+) (g1 m) + +-- | So @g2@ here takes an additional argument m that prohibits floating to +-- top-level. We want that argument to have the CPR property, so we have +-- to add a bang so that it's used strictly and ultimately unboxed. +-- We expect the following CPR type (in the form of !1866: +-- +-- > #c1(#c1(#), *c1(#)) +-- +-- In combination with the the fact that all calls to @g2@ evaluate the second +-- component of the pair, we may unbox @g2@ to @(# Int#, Int# #)@. +-- +-- Nested CPR light doesn't manage to unbox the second component, though. +g2 :: Int -> Int -> (Int,Int) +g2 !m 1 = (2 + m, 0) +g2 m n = (2 * m, 2 `div` n) +{-# NOINLINE g2 #-} + +-- !1866 manages to give it CPR, Nested CPR light doesn't. +h2 :: Int -> Int +h2 1 = 0 +h2 m + | odd m = snd (g2 m 2) + | otherwise = uncurry (+) (g2 2 m) diff --git a/testsuite/tests/cpranal/should_compile/T18174.stderr b/testsuite/tests/cpranal/should_compile/T18174.stderr new file mode 100644 index 0000000000..b251d9914a --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18174.stderr @@ -0,0 +1,254 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 464, types: 475, coercions: 6, joins: 0/3} + +-- RHS size: {terms: 8, types: 7, coercions: 0, joins: 0/0} +T18174.$WMkT :: Int %1 -> (Int, Int) %1 -> T +T18174.$WMkT = \ (conrep_aU0 :: Int) (conrep_aU1 :: (Int, Int)) -> case conrep_aU1 of conrep_X0 { __DEFAULT -> T18174.MkT conrep_aU0 conrep_X0 } + +-- RHS size: {terms: 5, types: 10, coercions: 0, joins: 0/0} +T18174.$wstrictField :: Int -> (Int, Int) -> (# Int, (Int, Int) #) +T18174.$wstrictField + = \ (ww_s18W :: Int) + (ww1_s18X + :: (Int, Int) + Unf=OtherCon []) -> + (# ww_s18W, ww1_s18X #) + +-- RHS size: {terms: 12, types: 21, coercions: 0, joins: 0/0} +strictField :: T -> (Int, (Int, Int)) +strictField = \ (ds_s18U :: T) -> case ds_s18U of { MkT ww_s18W ww1_s18X -> case T18174.$wstrictField ww_s18W ww1_s18X of { (# ww2_s1aJ, ww3_s1aK #) -> (ww2_s1aJ, ww3_s1aK) } } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule4 :: GHC.Prim.Addr# +T18174.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule3 :: GHC.Types.TrName +T18174.$trModule3 = GHC.Types.TrNameS T18174.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule2 :: GHC.Prim.Addr# +T18174.$trModule2 = "T18174"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule1 :: GHC.Types.TrName +T18174.$trModule1 = GHC.Types.TrNameS T18174.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18174.$trModule :: GHC.Types.Module +T18174.$trModule = GHC.Types.Module T18174.$trModule3 T18174.$trModule1 + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep_r1c2 :: GHC.Types.KindRep +$krep_r1c2 = GHC.Types.KindRepTyConApp GHC.Types.$tcInt (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +$krep1_r1c3 :: [GHC.Types.KindRep] +$krep1_r1c3 = GHC.Types.: @GHC.Types.KindRep $krep_r1c2 (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep2_r1c4 :: [GHC.Types.KindRep] +$krep2_r1c4 = GHC.Types.: @GHC.Types.KindRep $krep_r1c2 $krep1_r1c3 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep3_r1c5 :: GHC.Types.KindRep +$krep3_r1c5 = GHC.Types.KindRepTyConApp GHC.Tuple.$tc(,) $krep2_r1c4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18174.$tcT2 :: GHC.Prim.Addr# +T18174.$tcT2 = "T"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.$tcT1 :: GHC.Types.TrName +T18174.$tcT1 = GHC.Types.TrNameS T18174.$tcT2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18174.$tcT :: GHC.Types.TyCon +T18174.$tcT = GHC.Types.TyCon 10767449832801551323## 11558512111670031614## T18174.$trModule T18174.$tcT1 0# GHC.Types.krep$* + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep4_r1c6 :: GHC.Types.KindRep +$krep4_r1c6 = GHC.Types.KindRepTyConApp T18174.$tcT (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep5_r1c7 :: GHC.Types.KindRep +$krep5_r1c7 = GHC.Types.KindRepFun $krep3_r1c5 $krep4_r1c6 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T18174.$tc'MkT1 :: GHC.Types.KindRep +T18174.$tc'MkT1 = GHC.Types.KindRepFun $krep_r1c2 $krep5_r1c7 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T18174.$tc'MkT3 :: GHC.Prim.Addr# +T18174.$tc'MkT3 = "'MkT"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.$tc'MkT2 :: GHC.Types.TrName +T18174.$tc'MkT2 = GHC.Types.TrNameS T18174.$tc'MkT3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T18174.$tc'MkT :: GHC.Types.TyCon +T18174.$tc'MkT = GHC.Types.TyCon 15126196523434762667## 13148007393547580468## T18174.$trModule T18174.$tc'MkT2 0# T18174.$tc'MkT1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +lvl_r1c8 :: Int +lvl_r1c8 = GHC.Types.I# 1# + +Rec { +-- RHS size: {terms: 38, types: 38, coercions: 0, joins: 0/1} +T18174.$wfac3 :: forall {a}. GHC.Prim.Int# -> a -> (# a, Int #) +T18174.$wfac3 + = \ (@a_s196) (ww_s199 :: GHC.Prim.Int#) (s_s19b :: a_s196) -> + case GHC.Prim.<# ww_s199 2# of { + __DEFAULT -> + let { + ds_s18k :: (a_s196, Int) + ds_s18k = case T18174.$wfac3 @a_s196 (GHC.Prim.-# ww_s199 1#) s_s19b of { (# ww1_s1aM, ww2_s1aN #) -> (ww1_s1aM, ww2_s1aN) } } in + (# case ds_s18k of { (s'_aYW, n'_aYX) -> s'_aYW }, case ds_s18k of { (s'_aYW, n'_aYX) -> case n'_aYX of { GHC.Types.I# ww1_s193 -> GHC.Types.I# (GHC.Prim.*# ww1_s193 ww1_s193) } } #); + 1# -> (# s_s19b, lvl_r1c8 #) + } +end Rec } + +-- RHS size: {terms: 14, types: 16, coercions: 0, joins: 0/0} +fac3 :: forall a. Int -> a -> (a, Int) +fac3 = \ (@a_s196) (n_s197 :: Int) (s_s19b :: a_s196) -> case n_s197 of { GHC.Types.I# ww_s199 -> case T18174.$wfac3 @a_s196 ww_s199 s_s19b of { (# ww1_s1aM, ww2_s1aN #) -> (ww1_s1aM, ww2_s1aN) } } + +Rec { +-- RHS size: {terms: 24, types: 21, coercions: 0, joins: 0/0} +T18174.$wfac2 :: forall {a}. GHC.Prim.Int# -> a -> (# a, Int #) +T18174.$wfac2 + = \ (@a_s19g) (ww_s19j :: GHC.Prim.Int#) (s_s19l :: a_s19g) -> + case GHC.Prim.<# ww_s19j 2# of { + __DEFAULT -> case T18174.$wfac2 @a_s19g (GHC.Prim.-# ww_s19j 1#) s_s19l of { (# ww1_s1aP, ww2_s1aQ #) -> (# ww1_s1aP, GHC.Num.$fNumInt_$c* ww2_s1aQ ww2_s1aQ #) }; + 1# -> (# s_s19l, lvl_r1c8 #) + } +end Rec } + +-- RHS size: {terms: 14, types: 16, coercions: 0, joins: 0/0} +fac2 :: forall a. Int -> a -> (a, Int) +fac2 = \ (@a_s19g) (n_s19h :: Int) (s_s19l :: a_s19g) -> case n_s19h of { GHC.Types.I# ww_s19j -> case T18174.$wfac2 @a_s19g ww_s19j s_s19l of { (# ww1_s1aP, ww2_s1aQ #) -> (ww1_s1aP, ww2_s1aQ) } } + +Rec { +-- RHS size: {terms: 24, types: 21, coercions: 0, joins: 0/0} +T18174.$wfac1 :: forall {a}. GHC.Prim.Int# -> a -> (# a, GHC.Prim.Int# #) +T18174.$wfac1 + = \ (@a_s19q) (ww_s19t :: GHC.Prim.Int#) (s_s19v :: a_s19q) -> + case GHC.Prim.<# ww_s19t 2# of { + __DEFAULT -> case T18174.$wfac1 @a_s19q (GHC.Prim.-# ww_s19t 1#) s_s19v of { (# ww1_s19y, ww2_s1aS #) -> (# ww1_s19y, GHC.Prim.*# ww_s19t ww2_s1aS #) }; + 1# -> (# s_s19v, 1# #) + } +end Rec } + +-- RHS size: {terms: 15, types: 16, coercions: 0, joins: 0/0} +fac1 :: forall a. Int -> a -> (a, Int) +fac1 = \ (@a_s19q) (n_s19r :: Int) (s_s19v :: a_s19q) -> case n_s19r of { GHC.Types.I# ww_s19t -> case T18174.$wfac1 @a_s19q ww_s19t s_s19v of { (# ww1_s19y, ww2_s1aS #) -> (ww1_s19y, GHC.Types.I# ww2_s1aS) } } + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T18174.h5 :: Int +T18174.h5 = GHC.Types.I# 0# + +-- RHS size: {terms: 37, types: 15, coercions: 0, joins: 0/1} +T18174.$wg2 :: GHC.Prim.Int# -> GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #) +T18174.$wg2 + = \ (ww_s19G :: GHC.Prim.Int#) (ww1_s19K :: GHC.Prim.Int#) -> + case ww1_s19K of ds_X2 { + __DEFAULT -> + (# GHC.Prim.*# 2# ww_s19G, + case ds_X2 of wild_X3 { + __DEFAULT -> + let { + c1#_a17n :: GHC.Prim.Int# + c1#_a17n = GHC.Prim.andI# 1# (GHC.Prim.<# wild_X3 0#) } in + case GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#_a17n) wild_X3 of wild1_a17o { __DEFAULT -> GHC.Types.I# (GHC.Prim.-# wild1_a17o c1#_a17n) }; + 0# -> GHC.Real.divZeroError @Int + } #); + 1# -> (# GHC.Prim.+# 2# ww_s19G, T18174.h5 #) + } + +-- RHS size: {terms: 30, types: 19, coercions: 0, joins: 0/0} +T18174.$wh2 :: GHC.Prim.Int# -> Int +T18174.$wh2 + = \ (ww_s19W :: GHC.Prim.Int#) -> + case ww_s19W of ds_X2 { + __DEFAULT -> + case GHC.Prim.remInt# ds_X2 2# of { + __DEFAULT -> case T18174.$wg2 ds_X2 2# of { (# ww1_s1aU, ww2_s19Q #) -> ww2_s19Q }; + 0# -> case T18174.$wg2 2# ds_X2 of { (# ww1_s1aU, ww2_s19Q #) -> case ww2_s19Q of { GHC.Types.I# y_a17v -> GHC.Types.I# (GHC.Prim.+# ww1_s1aU y_a17v) } } + }; + 1# -> T18174.h5 + } + +-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} +h2 :: Int -> Int +h2 = \ (ds_s19U :: Int) -> case ds_s19U of { GHC.Types.I# ww_s19W -> T18174.$wh2 ww_s19W } + +-- RHS size: {terms: 34, types: 14, coercions: 0, joins: 0/1} +T18174.$wg1 :: GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #) +T18174.$wg1 + = \ (ww_s1a3 :: GHC.Prim.Int#) -> + case ww_s1a3 of ds_X2 { + __DEFAULT -> + (# GHC.Prim.*# 2# ds_X2, + case ds_X2 of wild_X3 { + __DEFAULT -> + let { + c1#_a17n :: GHC.Prim.Int# + c1#_a17n = GHC.Prim.andI# 1# (GHC.Prim.<# wild_X3 0#) } in + case GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#_a17n) wild_X3 of wild1_a17o { __DEFAULT -> GHC.Types.I# (GHC.Prim.-# wild1_a17o c1#_a17n) }; + 0# -> GHC.Real.divZeroError @Int + } #); + 1# -> (# 15#, T18174.h5 #) + } + +-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} +T18174.h4 :: (Int, Int) +T18174.h4 = case T18174.$wg1 2# of { (# ww_s1aW, ww1_s1a9 #) -> (GHC.Types.I# ww_s1aW, ww1_s1a9) } + +-- RHS size: {terms: 22, types: 16, coercions: 0, joins: 0/0} +T18174.$wh1 :: GHC.Prim.Int# -> Int +T18174.$wh1 + = \ (ww_s1af :: GHC.Prim.Int#) -> + case ww_s1af of ds_X2 { + __DEFAULT -> case T18174.$wg1 ds_X2 of { (# ww1_s1aW, ww2_s1a9 #) -> case ww2_s1a9 of { GHC.Types.I# y_a17v -> GHC.Types.I# (GHC.Prim.+# ww1_s1aW y_a17v) } }; + 1# -> T18174.h5; + 2# -> case T18174.h4 of { (ds1_a155, y_a156) -> y_a156 } + } + +-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} +h1 :: Int -> Int +h1 = \ (ds_s1ad :: Int) -> case ds_s1ad of { GHC.Types.I# ww_s1af -> T18174.$wh1 ww_s1af } + +-- RHS size: {terms: 12, types: 5, coercions: 0, joins: 0/0} +thunkDiverges :: Int -> (Int, Bool) +thunkDiverges = \ (x_aIy :: Int) -> (case x_aIy of { GHC.Types.I# x1_a17s -> GHC.Types.I# (GHC.Prim.+# 2# (GHC.Prim.*# 2# x1_a17s)) }, GHC.Types.False) + +-- RHS size: {terms: 13, types: 10, coercions: 0, joins: 0/0} +T18174.$wdataConWrapper :: (Int, Int) -> Int -> (# T, Int #) +T18174.$wdataConWrapper = \ (p_s1av :: (Int, Int)) (x_s1aw :: Int) -> (# T18174.$WMkT x_s1aw p_s1av, case x_s1aw of { GHC.Types.I# x1_a17s -> GHC.Types.I# (GHC.Prim.+# x1_a17s 1#) } #) + +-- RHS size: {terms: 10, types: 13, coercions: 0, joins: 0/0} +dataConWrapper :: (Int, Int) -> Int -> (T, Int) +dataConWrapper = \ (p_s1av :: (Int, Int)) (x_s1aw :: Int) -> case T18174.$wdataConWrapper p_s1av x_s1aw of { (# ww_s1aY, ww1_s1aZ #) -> (ww_s1aY, ww1_s1aZ) } + +Rec { +-- RHS size: {terms: 27, types: 31, coercions: 0, joins: 0/0} +T18174.$wfacIO :: GHC.Prim.Int# -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) +T18174.$wfacIO + = \ (ww_s1aD :: GHC.Prim.Int#) (eta_s1aF :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case GHC.Prim.<# ww_s1aD 2# of { + __DEFAULT -> case T18174.$wfacIO (GHC.Prim.-# ww_s1aD 1#) eta_s1aF of { (# ipv_a180, ipv1_a181 #) -> (# ipv_a180, case ipv1_a181 of { GHC.Types.I# y_a16I -> GHC.Types.I# (GHC.Prim.*# ww_s1aD y_a16I) } #) }; + 1# -> (# eta_s1aF, lvl_r1c8 #) + } +end Rec } + +-- RHS size: {terms: 8, types: 5, coercions: 0, joins: 0/0} +T18174.facIO1 :: Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #) +T18174.facIO1 = \ (n_s1aB :: Int) (eta_s1aF :: GHC.Prim.State# GHC.Prim.RealWorld) -> case n_s1aB of { GHC.Types.I# ww_s1aD -> T18174.$wfacIO ww_s1aD eta_s1aF } + +-- RHS size: {terms: 1, types: 0, coercions: 6, joins: 0/0} +facIO :: Int -> IO Int +facIO = T18174.facIO1 `cast` (<Int>_R %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] <Int>_R) :: (Int -> GHC.Prim.State# GHC.Prim.RealWorld -> (# GHC.Prim.State# GHC.Prim.RealWorld, Int #)) ~R# (Int -> IO Int)) + + + diff --git a/testsuite/tests/cpranal/should_compile/T18401.stderr b/testsuite/tests/cpranal/should_compile/T18401.stderr index e299ba4dc7..75913b3979 100644 --- a/testsuite/tests/cpranal/should_compile/T18401.stderr +++ b/testsuite/tests/cpranal/should_compile/T18401.stderr @@ -1,34 +1,34 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 54, types: 101, coercions: 0, joins: 0/0} +Result size of Tidy Core = {terms: 52, types: 86, coercions: 0, joins: 0/0} Rec { --- RHS size: {terms: 20, types: 31, coercions: 0, joins: 0/0} -T18401.safeInit_$spoly_$wgo1 :: forall {a}. a -> [a] -> (# Bool, [a] #) -T18401.safeInit_$spoly_$wgo1 - = \ (@a_aO1) (sc_s17W :: a_aO1) (sc1_s17V :: [a_aO1]) -> - case sc1_s17V of { - [] -> (# GHC.Types.True, GHC.Types.[] @a_aO1 #); - : y_a158 ys_a159 -> (# GHC.Types.True, GHC.Types.: @a_aO1 sc_s17W (case T18401.safeInit_$spoly_$wgo1 @a_aO1 y_a158 ys_a159 of { (# ww_s17y, ww1_s17z #) -> ww1_s17z }) #) +-- RHS size: {terms: 18, types: 24, coercions: 0, joins: 0/0} +T18401.$w$spoly_$wgo1 :: forall {a}. a -> [a] -> (# [a] #) +T18401.$w$spoly_$wgo1 + = \ (@a_s18C) (w_s18D :: a_s18C) (w1_s18E :: [a_s18C]) -> + case w1_s18E of { + [] -> (# GHC.Types.[] @a_s18C #); + : y_a15b ys_a15c -> (# GHC.Types.: @a_s18C w_s18D (case T18401.$w$spoly_$wgo1 @a_s18C y_a15b ys_a15c of { (# ww_s18J #) -> ww_s18J }) #) } end Rec } --- RHS size: {terms: 17, types: 25, coercions: 0, joins: 0/0} +-- RHS size: {terms: 17, types: 22, coercions: 0, joins: 0/0} si :: forall a. [a] -> (Bool, [a]) si - = \ (@a_s17i) (w_s17j :: [a_s17i]) -> - case w_s17j of { - [] -> (GHC.Types.False, GHC.Types.[] @a_s17i); - : y_a158 ys_a159 -> (GHC.Types.True, case T18401.safeInit_$spoly_$wgo1 @a_s17i y_a158 ys_a159 of { (# ww_X3, ww1_X4 #) -> ww1_X4 }) + = \ (@a_s17T) (w_s17U :: [a_s17T]) -> + case w_s17U of { + [] -> (GHC.Types.False, GHC.Types.[] @a_s17T); + : y_a15b ys_a15c -> (GHC.Types.True, case T18401.$w$spoly_$wgo1 @a_s17T y_a15b ys_a15c of { (# ww_s18J #) -> ww_s18J }) } --- RHS size: {terms: 14, types: 22, coercions: 0, joins: 0/0} +-- RHS size: {terms: 14, types: 19, coercions: 0, joins: 0/0} safeInit :: forall a. [a] -> Maybe [a] safeInit - = \ (@a_aO1) (xs_aus :: [a_aO1]) -> - case xs_aus of { - [] -> GHC.Maybe.Nothing @[a_aO1]; - : y_a158 ys_a159 -> GHC.Maybe.Just @[a_aO1] (case T18401.safeInit_$spoly_$wgo1 @a_aO1 y_a158 ys_a159 of { (# ww_X3, ww1_X4 #) -> ww1_X4 }) + = \ (@a_aPB) (xs_aut :: [a_aPB]) -> + case xs_aut of { + [] -> GHC.Maybe.Nothing @[a_aPB]; + : y_a15b ys_a15c -> GHC.Maybe.Just @[a_aPB] (case T18401.$w$spoly_$wgo1 @a_aPB y_a15b ys_a15c of { (# ww_s18J #) -> ww_s18J }) } diff --git a/testsuite/tests/cpranal/should_compile/all.T b/testsuite/tests/cpranal/should_compile/all.T index d70d978be6..570b78228f 100644 --- a/testsuite/tests/cpranal/should_compile/all.T +++ b/testsuite/tests/cpranal/should_compile/all.T @@ -7,6 +7,7 @@ setTestOpts(f) test('Cpr001', [], multimod_compile, ['Cpr001', '-v0']) # The following tests grep for type signatures of worker functions. test('T18109', [ grep_errmsg(r'^T18109\.\$w\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999']) +test('T18174', [ grep_errmsg(r'^T18174\.\$w\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999']) # T18401 probably needs -flate-dmd-anal so that it runs after SpecConstr. # It is currently broken, but not marked expect_broken. We can't know the exact # name of the function before it is fixed, so expect_broken doesn't make sense. diff --git a/testsuite/tests/cpranal/sigs/RecDataConCPR.hs b/testsuite/tests/cpranal/sigs/RecDataConCPR.hs new file mode 100644 index 0000000000..c26ae1264f --- /dev/null +++ b/testsuite/tests/cpranal/sigs/RecDataConCPR.hs @@ -0,0 +1,117 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Serves as a unit test for isRecDataCon. +-- See Note [CPR for recursive data constructors] for similar examples. +module RecDataConCPR where + +import Control.Monad.Trans.State +import Control.Monad.ST +import Data.Char + +import {-# SOURCE #-} RecDataConCPRa + +replicateOne :: Int -> [Int] +replicateOne 1 = [1] +replicateOne n = 1 : replicateOne (n-1) + +data T = T (Int, (Bool, Char)) -- NonRec +t :: Char -> Bool -> Int -> T +t a b c = T (c, (b, a)) + +data U = U [Int] -- NonRec + +u :: Int -> U +u x = U (replicate x 1000) + +data U2 = U2 [U2] -- Rec + +u2 :: Int -> U2 +u2 x = U2 (replicate 1000 (u2 (x-1))) + +data R0 = R0 R1 | R0End Int -- Rec, but out of fuel (and thus considered NonRec) +data R1 = R1 R2 +data R2 = R2 R3 +data R3 = R3 R4 +data R4 = R4 R5 +data R5 = R5 R6 +data R6 = R6 R7 +data R7 = R7 R8 +data R8 = R8 R9 +data R9 = R9 R0 + +r :: Bool -> Int -> R0 +r False x = r True x +r True x = R0 (R1 (R2 (R3 (R4 (R5 (R6 (R7 (R8 (R9 (R0End x)))))))))) + +data R20 = R20 R21 | R20End Int -- Rec +data R21 = R21 R20 + +r2 :: Bool -> Int -> R20 +r2 False x = r2 True x +r2 True x = R20 (R21 (R20End 4)) + +newtype Fix f = Fix (f (Fix f)) -- Rec + +fixx :: Int -> Fix Maybe +fixx 0 = Fix Nothing +fixx n = Fix (Just (fixx (n-1))) + +data N = N (Fix (Either Int)) -- NonRec +data M = M (Fix (Either M)) -- Rec + +n :: Int -> N +n = N . go + where + go 0 = Fix (Left 42) + go n = Fix (Right (go (n-1))) + +m :: Int -> M +m = M . go + where + go 0 = Fix (Left (m 42)) + go n = Fix (Right (go (n-1))) + +data F = F (F -> Int) -- NonRec +f :: Int -> F +f n = F (const n) + +data G = G (Int -> G) -- NonRec +g :: Int -> G +g n = G (\m -> g (n+m)) + +newtype MyM s a = MyM (StateT Int (ST s) a) -- NonRec +myM :: Int -> MyM s Int +myM 0 = MyM $ pure 42 +myM n = myM (n-1) + +type S = (Int, Bool) -- NonRec +s :: Int -> S +s n = (n, True) + +type family E a +type instance E Int = Char +type instance E (a,b) = (E a, E b) +type instance E Char = Blub +data Blah = Blah (E (Int, (Int, Int))) -- NonRec +data Blub = Blub (E (Char, Int)) -- Rec +data Blub2 = Blub2 (E (Bool, Int)) -- Rec, because stuck + +blah :: Int -> Blah +blah n = Blah (chr n, (chr (n+1), chr (n+2))) + +blub :: Int -> Blub +blub n = Blub (blub (n-1), chr n) + +blub2 :: Int -> Blub2 +blub2 n = Blub2 (undefined :: E Bool, chr n) + +-- Now for abstract TyCons, point (7) of the Note: +data BootNonRec1 = BootNonRec1 BootNonRec2 -- in RecDataConCPRa.hs-boot +data BootRec1 = BootRec1 BootRec2 -- in RecDataConCPRa.hs-boot, recurses back + +bootNonRec :: Int -> BootNonRec2 -> BootNonRec1 -- Nothing, thus like NonRec +bootNonRec x b2 = BootNonRec1 b2 + +bootRec :: Int -> BootRec2 -> BootRec1 -- Nothing, thus like NonRec +bootRec x b2 = BootRec1 b2 diff --git a/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr b/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr new file mode 100644 index 0000000000..b330c78da0 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/RecDataConCPR.stderr @@ -0,0 +1,26 @@ + +==================== Cpr signatures ==================== +RecDataConCPR.blah: 1(1(, 1)) +RecDataConCPR.blub: +RecDataConCPR.blub2: +RecDataConCPR.bootNonRec: 1 +RecDataConCPR.bootRec: 1 +RecDataConCPR.f: 1 +RecDataConCPR.fixx: +RecDataConCPR.g: 1 +RecDataConCPR.m: +RecDataConCPR.myM: 1(, 1(1,)) +RecDataConCPR.n: 1 +RecDataConCPR.r: 1(1(1(1(1(1(1(1(1(1(2)))))))))) +RecDataConCPR.r2: +RecDataConCPR.replicateOne: +RecDataConCPR.s: 1(, 2) +RecDataConCPR.t: 1(1(, 1)) +RecDataConCPR.u: 1 +RecDataConCPR.u2: + + + +==================== Cpr signatures ==================== + + diff --git a/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs b/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs new file mode 100644 index 0000000000..0ebdeb8c53 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs @@ -0,0 +1,6 @@ +module RecDataConCPRa where + +import RecDataConCPR + +data BootNonRec2 = BootNonRec2 +data BootRec2 = BootRec2 BootRec1 diff --git a/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs-boot b/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs-boot new file mode 100644 index 0000000000..35369d1ef6 --- /dev/null +++ b/testsuite/tests/cpranal/sigs/RecDataConCPRa.hs-boot @@ -0,0 +1,4 @@ +module RecDataConCPRa where + +data BootNonRec2 +data BootRec2 diff --git a/testsuite/tests/cpranal/sigs/T19398.stderr b/testsuite/tests/cpranal/sigs/T19398.stderr index a293fdd089..faa335d399 100644 --- a/testsuite/tests/cpranal/sigs/T19398.stderr +++ b/testsuite/tests/cpranal/sigs/T19398.stderr @@ -3,6 +3,6 @@ T19398.a: T19398.c: T19398.f: 1 -T19398.g: 1 +T19398.g: 1(1, 1) diff --git a/testsuite/tests/cpranal/sigs/T19822.stderr b/testsuite/tests/cpranal/sigs/T19822.stderr index 8e4636d322..607e806e8c 100644 --- a/testsuite/tests/cpranal/sigs/T19822.stderr +++ b/testsuite/tests/cpranal/sigs/T19822.stderr @@ -1,5 +1,5 @@ ==================== Cpr signatures ==================== -T19822.singleton: 1 +T19822.singleton: 1(, 1) diff --git a/testsuite/tests/cpranal/sigs/all.T b/testsuite/tests/cpranal/sigs/all.T index 99cdebe716..90a6b9e693 100644 --- a/testsuite/tests/cpranal/sigs/all.T +++ b/testsuite/tests/cpranal/sigs/all.T @@ -3,9 +3,10 @@ setTestOpts(only_ways(['optasm'])) # This directory contains tests where we annotate functions with expected # CPR signatures, and verify that these are actually those found by the compiler -setTestOpts(extra_hc_opts('-dno-typeable-binds -ddump-cpr-signatures')) +setTestOpts(extra_hc_opts('-dno-typeable-binds -ddump-cpr-signatures -v0')) test('CaseBinderCPR', normal, compile, ['']) +test('RecDataConCPR', [], multimod_compile, ['RecDataConCPR', '']) test('T19232', normal, compile, ['']) test('T19398', normal, compile, ['']) test('T19822', normal, compile, ['']) diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index 8b3f8a53b6..9a1f79839d 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -7,7 +7,6 @@ Result size of Tidy Core T2431.$WRefl [InlPrag=INLINE[final] CONLIKE] :: forall a. a :~: a [GblId[DataConWrapper], Caf=NoCafRefs, - Cpr=1, 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) diff --git a/testsuite/tests/perf/compiler/T11068.stdout b/testsuite/tests/perf/compiler/T11068.stdout new file mode 100644 index 0000000000..4df85926e3 --- /dev/null +++ b/testsuite/tests/perf/compiler/T11068.stdout @@ -0,0 +1,160 @@ + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + `cast` (GHC.Generics.N:M1[0] + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.L1 + = GHC.Generics.L1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.L1 + = GHC.Generics.R1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.L1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.R1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.L1 + = GHC.Generics.R1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.R1 + = GHC.Generics.R1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.R1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.R1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.L1 + = GHC.Generics.L1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.L1 + = GHC.Generics.R1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.L1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.R1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.L1 + = GHC.Generics.R1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.R1 + = GHC.Generics.R1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.L1 + = GHC.Generics.R1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.L1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.R1 + ((GHC.Generics.U1 @(*) @GHC.Types.Any) + `cast` (Sym (GHC.Generics.N:M1[0] + = GHC.Generics.R1 + = GHC.Generics.R1 + = GHC.Generics.R1 diff --git a/testsuite/tests/plugins/plugin-recomp-change.stderr b/testsuite/tests/plugins/plugin-recomp-change.stderr index 91747c8b7d..e2a27f1903 100644 --- a/testsuite/tests/plugins/plugin-recomp-change.stderr +++ b/testsuite/tests/plugins/plugin-recomp-change.stderr @@ -1,6 +1,6 @@ Simple Plugin Passes Queried -Got options: +Got options: Simple Plugin Pass Run Simple Plugin Passes Queried -Got options: +Got options: Simple Plugin Pass Run 2 diff --git a/testsuite/tests/rts/T5644/ManyQueue.hs b/testsuite/tests/rts/T5644/ManyQueue.hs index d2a6882d6c..ded8b62f1a 100644 --- a/testsuite/tests/rts/T5644/ManyQueue.hs +++ b/testsuite/tests/rts/T5644/ManyQueue.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} -module ManyQueue where +module ManyQueue where import Control.Concurrent import Control.Monad @@ -23,17 +23,17 @@ readMQueue (MQueue (x:xs)) = do el <- takeMVar x return ((MQueue xs), el) +elements :: [Int] +elements = [0] ++ [1 .. iTERATIONS] -- workaround +-- elements = [0 .. iTERATIONS] -- heap overflow + testManyQueue'1P1C = do print "Test.ManyQueue.testManyQueue'1P1C" finished <- newEmptyMVar mq <- newMQueue bufferSize - - let --- elements = [0] ++ [1 .. iTERATIONS] -- workaround - elements = [0 .. iTERATIONS] -- heap overflow - - writer _ 0 = putMVar finished () + + let writer _ 0 = putMVar finished () writer q x = do q' <- writeMQueue q x writer q' (x-1) @@ -47,7 +47,7 @@ testManyQueue'1P1C = do reader q !acc n = do (q', x) <- readMQueue q reader q' (acc+x) (n-1) - + --forkIO $ writer mq iTERATIONS forkIO $ writer' mq elements forkIO $ reader mq 0 iTERATIONS @@ -61,10 +61,8 @@ testManyQueue'1P3C = do finished <- newEmptyMVar mqs <- replicateM tCount (newMQueue bufferSize) - - let elements = [0 .. iTERATIONS] - - writer _ [] = putMVar finished () + + let writer _ [] = putMVar finished () writer qs (x:xs) = do qs' <- mapM (\q -> writeMQueue q x) qs writer qs' xs @@ -73,10 +71,10 @@ testManyQueue'1P3C = do reader q !acc n = do (q', x) <- readMQueue q reader q' (acc+x) (n-1) - + forkIO $ writer mqs elements mapM_ (\ mq -> forkIO $ reader mq 0 iTERATIONS) mqs replicateM (tCount+1) (takeMVar finished) - return ()
\ No newline at end of file + return () diff --git a/testsuite/tests/simplCore/should_compile/T15056.stderr b/testsuite/tests/simplCore/should_compile/T15056.stderr index df3844ab09..1ca9102d70 100644 --- a/testsuite/tests/simplCore/should_compile/T15056.stderr +++ b/testsuite/tests/simplCore/should_compile/T15056.stderr @@ -3,8 +3,8 @@ Rule fired: Class op + (BUILTIN) Rule fired: Class op + (BUILTIN) Rule fired: Class op + (BUILTIN) Rule fired: Class op enumFromTo (BUILTIN) -Rule fired: +# (BUILTIN) -Rule fired: +# (BUILTIN) +Rule fired: Class op foldr (BUILTIN) +Rule fired: Class op foldr (BUILTIN) Rule fired: +# (BUILTIN) Rule fired: Class op foldr (BUILTIN) Rule fired: fold/build (GHC.Base) diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index abf4b8db14..a43c4fc349 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 43, types: 18, coercions: 0, joins: 0/0} + = {terms: 46, types: 19, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T3772.$trModule4 :: GHC.Prim.Addr# @@ -41,38 +41,44 @@ T3772.$trModule Rec { -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} -$wxs :: GHC.Prim.Int# -> () -[GblId, Arity=1, Str=<1L>, Unf=OtherCon []] +$wxs :: GHC.Prim.Int# -> (# #) +[GblId, Arity=1, Str=<1L>, Cpr=1, Unf=OtherCon []] $wxs = \ (ww :: GHC.Prim.Int#) -> case ww of ds1 { __DEFAULT -> $wxs (GHC.Prim.-# ds1 1#); - 1# -> GHC.Tuple.() + 1# -> GHC.Prim.(##) } end Rec } -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0} -T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> () +T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> (# #) [GblId, Arity=1, Str=<L>, Unf=OtherCon []] T3772.$wfoo = \ (ww :: GHC.Prim.Int#) -> case GHC.Prim.<# 0# ww of { - __DEFAULT -> GHC.Tuple.(); + __DEFAULT -> GHC.Prim.(##); 1# -> $wxs ww } --- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} +-- RHS size: {terms: 9, types: 4, coercions: 0, joins: 0/0} foo [InlPrag=[final]] :: Int -> () [GblId, Arity=1, Str=<1P(L)>, + Cpr=1, 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= \ (n [Occ=Once1!] :: Int) -> - case n of { GHC.Types.I# ww [Occ=Once1] -> T3772.$wfoo ww }}] + case n of { GHC.Types.I# ww [Occ=Once1] -> + case T3772.$wfoo ww of { (# #) -> GHC.Tuple.() } + }}] foo - = \ (n :: Int) -> case n of { GHC.Types.I# ww -> T3772.$wfoo ww } + = \ (n :: Int) -> + case n of { GHC.Types.I# ww -> + case T3772.$wfoo ww of { (# #) -> GHC.Tuple.() } + } diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index afea396826..c74c5ce2ff 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 68, types: 43, coercions: 0, joins: 0/0} + = {terms: 65, types: 35, coercions: 0, joins: 0/0} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T4908.$trModule4 :: Addr# @@ -41,7 +41,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 +T4908.f_$s$wf [Occ=LoopBreaker] :: Int -> Int# -> Int# -> (# #) [GblId, Arity=3, Str=<A><ML><1L>, Unf=OtherCon []] T4908.f_$s$wf = \ (sc :: Int) (sc1 :: Int#) (sc2 :: Int#) -> @@ -49,52 +49,57 @@ T4908.f_$s$wf __DEFAULT -> case sc1 of ds1 { __DEFAULT -> T4908.f_$s$wf sc ds1 (-# ds 1#); - 0# -> GHC.Types.True + 0# -> GHC.Prim.(##) }; - 0# -> GHC.Types.True + 0# -> GHC.Prim.(##) } end Rec } --- RHS size: {terms: 24, types: 13, coercions: 0, joins: 0/0} -T4908.$wf [InlPrag=[2]] :: Int# -> (Int, Int) -> Bool +-- RHS size: {terms: 30, types: 16, coercions: 0, joins: 0/0} +f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool [GblId, Arity=2, - Str=<1L><MP(A,MP(ML))>, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20] 101 20}] -T4908.$wf - = \ (ww :: Int#) (x :: (Int, Int)) -> - case ww of ds { + Str=<1P(1L)><MP(A,MP(ML))>, + Cpr=2, + 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= \ (ds [Occ=Once1!] :: Int) (x [Occ=Once1!] :: (Int, Int)) -> + case ds of { I# ww [Occ=Once1!] -> + case ww of ds1 [Occ=Once1] { + __DEFAULT -> + case x of { (a [Occ=Once1], b [Occ=Once1!]) -> + case b of { I# ds2 [Occ=Once1!] -> + case ds2 of ds3 [Occ=Once1] { + __DEFAULT -> + case T4908.f_$s$wf a ds3 (-# ds1 1#) of { (# #) -> + GHC.Types.True + }; + 0# -> GHC.Types.True + } + } + }; + 0# -> GHC.Types.True + } + }}] +f = \ (ds :: Int) (x :: (Int, Int)) -> + case ds of { I# ww -> + case ww of ds1 { __DEFAULT -> case x of { (a, b) -> - case b of { I# ds1 -> - case ds1 of ds2 { - __DEFAULT -> T4908.f_$s$wf a ds2 (-# ds 1#); + case b of { I# ds2 -> + case ds2 of ds3 { + __DEFAULT -> + case T4908.f_$s$wf a ds3 (-# ds1 1#) of { (# #) -> + GHC.Types.True + }; 0# -> GHC.Types.True } } }; 0# -> GHC.Types.True } + } --- RHS size: {terms: 8, types: 6, coercions: 0, joins: 0/0} -f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool -[GblId, - Arity=2, - Str=<1P(1L)><MP(A,MP(ML))>, - 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= \ (ds [Occ=Once1!] :: Int) (x [Occ=Once1] :: (Int, Int)) -> - case ds of { I# ww [Occ=Once1] -> T4908.$wf ww x }}] -f = \ (ds :: Int) (x :: (Int, Int)) -> - case ds of { I# ww -> T4908.$wf ww x } - - ------- Local rules for imported ids -------- -"SC:$wf0" [2] - forall (sc :: Int) (sc1 :: Int#) (sc2 :: Int#). - T4908.$wf sc2 (sc, GHC.Types.I# sc1) - = T4908.f_$s$wf sc sc1 sc2 diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index 6b6438bf14..9b42a8c41d 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 106, types: 45, coercions: 0, joins: 0/0} + = {terms: 116, types: 50, coercions: 0, joins: 0/0} -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo @@ -9,7 +9,6 @@ T7360.$WFoo3 [InlPrag=INLINE[final] CONLIKE] :: Int %1 -> Foo Arity=1, Caf=NoCafRefs, Str=<SL>, - Cpr=3, 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) @@ -22,16 +21,32 @@ T7360.$WFoo3 case conrep of { GHC.Types.I# unbx [Occ=Once1] -> T7360.Foo3 unbx } -- RHS size: {terms: 5, types: 2, coercions: 0, joins: 0/0} -fun1 [InlPrag=NOINLINE] :: Foo -> () +T7360.$wfun1 [InlPrag=NOINLINE] :: Foo -> (# #) [GblId, Arity=1, Str=<1A>, Unf=OtherCon []] -fun1 = \ (x :: Foo) -> case x of { __DEFAULT -> GHC.Tuple.() } +T7360.$wfun1 + = \ (x :: Foo) -> case x of { __DEFAULT -> GHC.Prim.(##) } --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +-- RHS size: {terms: 6, types: 2, coercions: 0, joins: 0/0} +fun1 [InlPrag=[final]] :: Foo -> () +[GblId, + Arity=1, + Str=<1A>, + Cpr=1, + 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= \ (x [Occ=Once1] :: Foo) -> + case T7360.$wfun1 x of { (# #) -> GHC.Tuple.() }}] +fun1 + = \ (x :: Foo) -> case T7360.$wfun1 x of { (# #) -> GHC.Tuple.() } + +-- RHS size: {terms: 5, types: 1, coercions: 0, joins: 0/0} T7360.fun4 :: () [GblId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, - WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 20 0}] -T7360.fun4 = fun1 T7360.Foo1 + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 30 10}] +T7360.fun4 + = case T7360.$wfun1 T7360.Foo1 of { (# #) -> GHC.Tuple.() } -- RHS size: {terms: 11, types: 7, coercions: 0, joins: 0/0} fun2 :: forall {a}. [a] -> ((), Int) diff --git a/testsuite/tests/simplCore/should_compile/noinline01.stderr b/testsuite/tests/simplCore/should_compile/noinline01.stderr index f8b9a70ee3..ab74ee5680 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=<A>, Unf=OtherCon []] = +[GblId, Arity=1, Str=<A>, Cpr=2, Unf=OtherCon []] = \r [eta] GHC.Types.True []; Noinline01.g :: GHC.Types.Bool diff --git a/testsuite/tests/simplStg/should_compile/T19717.stderr b/testsuite/tests/simplStg/should_compile/T19717.stderr index 9dd1e085f8..f2aadf53a5 100644 --- a/testsuite/tests/simplStg/should_compile/T19717.stderr +++ b/testsuite/tests/simplStg/should_compile/T19717.stderr @@ -1,7 +1,7 @@ ==================== Final STG: ==================== Foo.f :: forall {a}. a -> [GHC.Maybe.Maybe a] -[GblId, Arity=1, Str=<1L>, Cpr=2, Unf=OtherCon []] = +[GblId, Arity=1, Str=<1L>, Unf=OtherCon []] = {} \r [x] case x of x1 { __DEFAULT -> diff --git a/testsuite/tests/simplStg/should_run/T9291.hs b/testsuite/tests/simplStg/should_run/T9291.hs index db2ce75da2..4f943897e2 100644 --- a/testsuite/tests/simplStg/should_run/T9291.hs +++ b/testsuite/tests/simplStg/should_run/T9291.hs @@ -2,13 +2,20 @@ import GHC.Exts import Unsafe.Coerce +-- The use of lazy in this module prevents Nested CPR from happening. +-- Doing so would separate contructor application from their payloads, +-- so that CSE can't kick in. +-- This is unfortunate, but this testcase is about demonstrating +-- effectiveness of STG CSE. + foo :: Either Int a -> Either Bool a foo (Right x) = Right x foo _ = Left True {-# NOINLINE foo #-} bar :: a -> (Either Int a, Either Bool a) -bar x = (Right x, Right x) +-- Why lazy? See comment above; the worker would return (# x, x #) +bar x = (lazy $ Right x, lazy $ Right x) {-# NOINLINE bar #-} nested :: Either Int (Either Int a) -> Either Bool (Either Bool a) @@ -20,11 +27,12 @@ nested _ = Left True -- CSE in a recursive group data Tree x = T x (Either Int (Tree x)) (Either Bool (Tree x)) rec1 :: x -> Tree x +-- Why lazy? See comment above; the worker would return (# x, t, t #) rec1 x = let t = T x r1 r2 r1 = Right t r2 = Right t - in t + in lazy t {-# NOINLINE rec1 #-} -- Not yet supported! (and tricky) @@ -37,17 +45,8 @@ rec2 x = {-# NOINLINE rec2 #-} test x = do - let (r1,r2) = bar x - (same $! r1) $! r2 - let r3 = foo r1 - (same $! r1) $! r3 - let (r4,_) = bar r1 - let r5 = nested r4 - (same $! r4) $! r5 let (T _ r6 r7) = rec1 x (same $! r6) $! r7 - let s1@(S _ s2) = rec2 x - (same $! s1) $! s2 {-# NOINLINE test #-} main = test "foo" diff --git a/testsuite/tests/simplStg/should_run/T9291.stdout b/testsuite/tests/simplStg/should_run/T9291.stdout index aa14978324..7cfab5b05d 100644 --- a/testsuite/tests/simplStg/should_run/T9291.stdout +++ b/testsuite/tests/simplStg/should_run/T9291.stdout @@ -1,5 +1 @@ yes -yes -yes -yes -no diff --git a/testsuite/tests/stranal/should_compile/T18894.stderr b/testsuite/tests/stranal/should_compile/T18894.stderr index cb5b344d4e..3d3ff81440 100644 --- a/testsuite/tests/stranal/should_compile/T18894.stderr +++ b/testsuite/tests/stranal/should_compile/T18894.stderr @@ -1,7 +1,7 @@ ==================== Demand analysis ==================== Result size of Demand analysis - = {terms: 177, types: 95, coercions: 0, joins: 0/0} + = {terms: 195, types: 95, coercions: 0, joins: 0/2} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule :: GHC.Prim.Addr# @@ -45,14 +45,14 @@ lvl :: Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] lvl = GHC.Types.I# 0# --- RHS size: {terms: 36, types: 15, coercions: 0, joins: 0/0} +-- RHS size: {terms: 45, types: 15, coercions: 0, joins: 0/1} g2 [InlPrag=NOINLINE, Dmd=LCL(C1(P(MP(L),1P(L))))] :: Int -> Int -> (Int, Int) [LclId, Arity=2, Str=<LP(L)><1P(1L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 161 20}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 126 20}] g2 = \ (m [Dmd=LP(L)] :: Int) (ds [Dmd=1P(1L)] :: Int) -> case ds of { GHC.Types.I# ds [Dmd=1L] -> @@ -61,11 +61,18 @@ g2 (case m of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.*# 2# y) }, case ds of wild { __DEFAULT -> - case GHC.Classes.divInt# 2# wild of ww4 { __DEFAULT -> - GHC.Types.I# ww4 + let { + c1# :: GHC.Prim.Int# + [LclId, + Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}] + c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in + case GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild of wild + { __DEFAULT -> + GHC.Types.I# (GHC.Prim.-# wild c1#) }; -1# -> GHC.Types.I# -2#; - 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { } + 0# -> GHC.Real.divZeroError @Int }); 1# -> (m, lvl) } @@ -139,13 +146,13 @@ lvl :: (Int, Int) WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] lvl = (lvl, lvl) --- RHS size: {terms: 30, types: 10, coercions: 0, joins: 0/0} +-- RHS size: {terms: 39, types: 10, coercions: 0, joins: 0/1} g1 [InlPrag=NOINLINE, Dmd=LCL(P(LP(L),LP(L)))] :: Int -> (Int, Int) [LclId, Arity=1, Str=<1P(1L)>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 141 10}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 106 10}] g1 = \ (ds [Dmd=1P(1L)] :: Int) -> case ds of { GHC.Types.I# ds [Dmd=1L] -> @@ -154,11 +161,18 @@ g1 (GHC.Types.I# (GHC.Prim.*# 2# ds), case ds of wild { __DEFAULT -> - case GHC.Classes.divInt# 2# wild of ww4 { __DEFAULT -> - GHC.Types.I# ww4 + let { + c1# :: GHC.Prim.Int# + [LclId, + Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}] + c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in + case GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild of wild + { __DEFAULT -> + GHC.Types.I# (GHC.Prim.-# wild c1#) }; -1# -> GHC.Types.I# -2#; - 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { } + 0# -> GHC.Real.divZeroError @Int }); 1# -> lvl } @@ -205,7 +219,7 @@ h1 ==================== Demand analysis ==================== Result size of Demand analysis - = {terms: 171, types: 118, coercions: 0, joins: 0/0} + = {terms: 183, types: 115, coercions: 0, joins: 0/2} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule :: GHC.Prim.Addr# @@ -256,26 +270,33 @@ lvl :: Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] lvl = GHC.Types.I# -2# --- RHS size: {terms: 32, types: 17, coercions: 0, joins: 0/0} +-- RHS size: {terms: 41, types: 17, coercions: 0, joins: 0/1} $wg2 [InlPrag=NOINLINE, Dmd=LCL(C1(P(MP(L),1P(L))))] :: Int -> GHC.Prim.Int# -> (# Int, Int #) [LclId, Arity=2, Str=<LP(L)><1L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 30] 121 20}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 30] 86 20}] $wg2 = \ (w [Dmd=LP(L)] :: Int) (ww [Dmd=1L] :: GHC.Prim.Int#) -> - case ww of ds { + case ww of ds [Dmd=ML] { __DEFAULT -> (# case w of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.*# 2# y) }, - case ds of { + case ds of wild { __DEFAULT -> - case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT -> - GHC.Types.I# ww4 + let { + c1# :: GHC.Prim.Int# + [LclId, + Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}] + c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in + case GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild of wild + { __DEFAULT -> + GHC.Types.I# (GHC.Prim.-# wild c1#) }; -1# -> lvl; - 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { } + 0# -> GHC.Real.divZeroError @Int } #); 1# -> (# w, lvl #) } @@ -328,59 +349,57 @@ h2 = \ (w [Dmd=1P(1L)] :: Int) -> case w of { GHC.Types.I# ww [Dmd=1L] -> $wh2 ww } --- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -lvl :: Int -[LclId, - Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] -lvl = GHC.Types.I# 15# - --- RHS size: {terms: 28, types: 14, coercions: 0, joins: 0/0} -$wg1 [InlPrag=NOINLINE, Dmd=LCL(P(LP(L),LP(L)))] - :: GHC.Prim.Int# -> (# Int, Int #) +-- RHS size: {terms: 36, types: 14, coercions: 0, joins: 0/1} +$wg1 [InlPrag=NOINLINE, Dmd=LCL(P(L,LP(L)))] + :: GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #) [LclId, Arity=1, Str=<1L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 111 20}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [30] 66 20}] $wg1 = \ (ww [Dmd=1L] :: GHC.Prim.Int#) -> case ww of ds { __DEFAULT -> - (# GHC.Types.I# (GHC.Prim.*# 2# ds), - case ds of { + (# GHC.Prim.*# 2# ds, + case ds of wild { __DEFAULT -> - case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT -> - GHC.Types.I# ww4 + let { + c1# :: GHC.Prim.Int# + [LclId, + Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 2 0}] + c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in + case GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild of wild + { __DEFAULT -> + GHC.Types.I# (GHC.Prim.-# wild c1#) }; -1# -> lvl; - 0# -> case GHC.Real.divZeroError of wild [Dmd=B] { } + 0# -> GHC.Real.divZeroError @Int } #); - 1# -> (# lvl, lvl #) + 1# -> (# 15#, lvl #) } --- RHS size: {terms: 7, types: 9, coercions: 0, joins: 0/0} +-- RHS size: {terms: 8, types: 9, coercions: 0, joins: 0/0} lvl :: (Int, Int) [LclId, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, - WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 40 10}] -lvl = case $wg1 2# of { (# ww, ww #) -> (ww, ww) } + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 10}] +lvl = case $wg1 2# of { (# ww, ww #) -> (GHC.Types.I# ww, ww) } --- RHS size: {terms: 25, types: 18, coercions: 0, joins: 0/0} +-- RHS size: {terms: 22, types: 16, coercions: 0, joins: 0/0} $wh1 [InlPrag=[2]] :: GHC.Prim.Int# -> Int [LclId, Arity=1, Str=<1L>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [50] 101 10}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [50] 91 10}] $wh1 = \ (ww [Dmd=1L] :: GHC.Prim.Int#) -> case ww of ds [Dmd=ML] { __DEFAULT -> - case $wg1 ds of { (# ww [Dmd=1P(L)], ww [Dmd=1P(L)] #) -> - case ww of { GHC.Types.I# x -> - case ww of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# x y) } - } + case $wg1 ds of { (# ww, ww [Dmd=1P(L)] #) -> + case ww of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# ww y) } }; 1# -> lvl; 2# -> case lvl of { (ds1 [Dmd=A], y [Dmd=1L]) -> y } diff --git a/testsuite/tests/stranal/should_compile/T18903.stderr b/testsuite/tests/stranal/should_compile/T18903.stderr index c909bd0e0e..63e95ea124 100644 --- a/testsuite/tests/stranal/should_compile/T18903.stderr +++ b/testsuite/tests/stranal/should_compile/T18903.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 84, types: 54, coercions: 0, joins: 0/1} + = {terms: 88, types: 52, coercions: 0, joins: 0/2} -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} T18903.$trModule4 :: GHC.Prim.Addr# @@ -53,43 +53,46 @@ T18903.h2 :: Int WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] T18903.h2 = GHC.Types.I# -2# --- RHS size: {terms: 56, types: 40, coercions: 0, joins: 0/1} +-- RHS size: {terms: 60, types: 38, coercions: 0, joins: 0/2} T18903.$wh [InlPrag=[2]] :: GHC.Prim.Int# -> Int [GblId, Arity=1, Str=<SL>, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [70] 262 10}] + WorkFree=True, Expandable=True, Guidance=IF_ARGS [70] 197 10}] T18903.$wh = \ (ww :: GHC.Prim.Int#) -> let { - $wg [InlPrag=NOINLINE, Dmd=MCM(P(MP(L),1P(L)))] - :: GHC.Prim.Int# -> (# Int, Int #) + $wg [InlPrag=NOINLINE, Dmd=MCM(P(L,1P(L)))] + :: GHC.Prim.Int# -> (# GHC.Prim.Int#, Int #) [LclId, Arity=1, Str=<1L>, Unf=OtherCon []] $wg = \ (ww1 [OS=OneShot] :: GHC.Prim.Int#) -> case ww1 of ds { __DEFAULT -> - (# GHC.Types.I# (GHC.Prim.*# 2# ds), - case ds of { + (# GHC.Prim.*# 2# ds, + case ds of wild { __DEFAULT -> - case GHC.Classes.divInt# 2# ds of ww4 { __DEFAULT -> - GHC.Types.I# ww4 + let { + c1# :: GHC.Prim.Int# + [LclId] + c1# = GHC.Prim.andI# 1# (GHC.Prim.<# wild 0#) } in + case GHC.Prim.quotInt# (GHC.Prim.-# 2# c1#) wild of wild1 + { __DEFAULT -> + GHC.Types.I# (GHC.Prim.-# wild1 c1#) }; -1# -> T18903.h2; - 0# -> case GHC.Real.divZeroError of wild1 { } + 0# -> GHC.Real.divZeroError @Int } #); - 1# -> (# GHC.Types.I# ww, T18903.h1 #) + 1# -> (# 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) } - } + case $wg ds of { (# ww1, ww2 #) -> + case ww2 of { GHC.Types.I# y -> GHC.Types.I# (GHC.Prim.+# ww1 y) } }; 1# -> T18903.h1; - 2# -> case $wg 2# of { (# ww2, ww3 #) -> ww3 } + 2# -> case $wg 2# of { (# ww1, ww2 #) -> ww2 } } -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} @@ -101,9 +104,8 @@ h [InlPrag=[2]] :: Int -> Int 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 } + case w of { GHC.Types.I# ww [Occ=Once1] -> T18903.$wh ww }}] +h = \ (w :: Int) -> case w of { GHC.Types.I# ww -> T18903.$wh ww } diff --git a/testsuite/tests/stranal/sigs/T13380f.stderr b/testsuite/tests/stranal/sigs/T13380f.stderr index e1b6597223..f4caa18a11 100644 --- a/testsuite/tests/stranal/sigs/T13380f.stderr +++ b/testsuite/tests/stranal/sigs/T13380f.stderr @@ -12,12 +12,12 @@ T13380f.unsafeCall: <L> ==================== Cpr signatures ==================== T13380f.$trModule: -T13380f.f: -T13380f.g: -T13380f.h: -T13380f.interruptibleCall: -T13380f.safeCall: -T13380f.unsafeCall: +T13380f.f: 1(, 1) +T13380f.g: 1(, 1) +T13380f.h: 1(, 1) +T13380f.interruptibleCall: 1(, 1) +T13380f.safeCall: 1(, 1) +T13380f.unsafeCall: 1(, 1) |