diff options
34 files changed, 1453 insertions, 335 deletions
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index f3ae2c0b43..d9bf411e35 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 /= Just Recursive -- 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 @@ -672,6 +831,14 @@ we did have available in boxed form. Note [CPR for sum types] ~~~~~~~~~~~~~~~~~~~~~~~~ +Aug 21: This Note is out of date. We have the tools to track join points today, +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. Note [CPR for recursive data constructors] might fix +it. + +Historical Note: + At the moment we do not do CPR for let-bindings that * non-top level * bind a sum type @@ -778,8 +945,9 @@ should not get CPR signatures (#18154), because they Hence we don't analyse or annotate data structures in 'cprAnalBind'. To implement this, the isDataStructure guard is triggered for bindings that satisfy - (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) But we can't just stop giving DataCon application bindings the CPR *property*, for example @@ -799,6 +967,9 @@ structure, and hence (see above) will not have a CPR signature. So instead, when transformer, 'cprTransform' instead tries to get its unfolding (via 'cprDataStructureUnfolding_maybe'), and analyses that instead. +Note that giving fac the CPR property means we potentially rebox lvl at call +sites. See Note [CPR for data structures can destroy sharing]. + 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!). @@ -822,6 +993,158 @@ 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. + +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. And then + + * We *might* save allocation of one (of most likely several) (:) constructor + if it cancels away at the call site. Similarly for the 'C#' constructor. + * But we will never be able to cancel away *all* 'C#' constructors, unless we + unroll the whole loop. And that means we destroy sharing of the 'c' binding. + Yikes! + * We make all other call sites where the wrapper inlines a bit larger, most of + them for no gain. The case from the inlined wrapper can also float and + inhibit other useful optimisations like eta-expansion. Thus, not CPR'ing + works around the issue and avoids a 20% regression in reptile, the proper + fix of which is tracked in #19970. + +`replicateC` comes up in T5536, which regresses significantly if CPR'd nestedly. +There is also Note [CPR for sum types], which tracks why local functions +returning sum types are not CPR'd. With the plan above, we might have a shot at +fixing the issue (#5075). + +What qualifies as a recursive data constructor? 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 diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index beafa01b1c..915d6c035c 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, 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,115 @@ 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 +-- | @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 [CPR for recursive data constructors] for which recursive DataCons +-- we want to flag. +isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> Maybe RecFlag +isRecDataCon fam_envs fuel dc + | isTupleDataCon dc || isUnboxedSumDataCon dc + = Just NonRecursive + | 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 + (<||>) = combineRecFlag + + go_dc :: IntWithInf -> RecTcChecker -> DataCon -> Maybe RecFlag + go_dc fuel rec_tc dc = + combineRecFlags [ go_arg_ty fuel rec_tc (scaledThing arg_ty) + | arg_ty <- dataConRepArgTys dc ] + + go_arg_ty :: IntWithInf -> RecTcChecker -> Type -> Maybe RecFlag + 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 [CPR for recursive data constructors], point (1) + = Just NonRecursive + + | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty + = go_arg_ty fuel rec_tc ty' + -- See Note [CPR for recursive data constructors], point (2) + + | Just (tc, tc_args) <- splitTyConApp_maybe ty + = combineRecFlags (map (go_arg_ty fuel rec_tc) tc_args) + <||> go_tc_app fuel rec_tc tc tc_args + + | otherwise + = Just NonRecursive + + -- | PRECONDITION: tc_args has no recursive occs + -- See Note [CPR for recursive data constructors], point (5) + go_tc_app :: IntWithInf -> RecTcChecker -> TyCon -> [Type] -> Maybe RecFlag + go_tc_app fuel rec_tc tc tc_args + --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined + + | tc == dataConTyCon dc + = Just Recursive -- loop found! + + | isPrimTyCon tc + = Just NonRecursive + + | not $ tcIsRuntimeTypeKind $ tyConResKind tc + = Just NonRecursive + + | isAbstractTyCon tc -- When tc has no DataCons, from an hs-boot file + = Nothing -- See Note [CPR for recursive data constructors], point (7) + + | isFamilyTyCon tc + -- This is the only place where we look at tc_args + -- See Note [CPR for 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 -> Just Recursive -- we hit this case for 'Any' + + | otherwise + = assertPpr (isAlgTyCon tc) (ppr tc <+> ppr dc) $ + case checkRecTc rec_tc tc of + Nothing -> Just NonRecursive + -- 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 [CPR for recursive data constructors], points (2) and (3) + -> go_arg_ty fuel rec_tc' rhs + + | fuel < 0 + -> Nothing -- that's why we track fuel! + + | let dcs = expectJust "isRecDataCon:go_tc_app" $ tyConDataCons_maybe tc + -> combineRecFlags (map (\dc -> go_dc (subWithInf fuel 1) rec_tc' dc) dcs) + -- See Note [CPR for recursive data constructors], point (4) + +-- | Computes the least upper bound on the total order +-- @Just Recursive > Nothing > Just NonRecursive@. +combineRecFlag :: Maybe RecFlag -> Maybe RecFlag -> Maybe RecFlag +combineRecFlag (Just Recursive) _ = Just Recursive +combineRecFlag _ (Just Recursive) = Just Recursive +combineRecFlag Nothing _ = Nothing +combineRecFlag _ Nothing = Nothing +combineRecFlag (Just NonRecursive) (Just NonRecursive) = Just NonRecursive + +combineRecFlags :: [Maybe RecFlag] -> Maybe RecFlag +combineRecFlags = foldr combineRecFlag (Just NonRecursive) +{-# INLINE combineRecFlags #-} {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs index 0bafac4088..72f5f6f768 100644 --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -42,6 +42,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/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) |