diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2022-07-07 14:21:41 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2022-08-25 08:38:16 +0100 |
| commit | a90298cc7291677fddd9e374e222676306265c17 (patch) | |
| tree | 8db696c8599547a2775eec15108d49304744f58f | |
| parent | a9f0e68ede36ad571d32e66a8e49e8c9f3b6a92b (diff) | |
| download | haskell-a90298cc7291677fddd9e374e222676306265c17.tar.gz | |
Fix arityType: -fpedantic-bottoms, join points, etcwip/T21694a
This MR fixes #21694, #21755. It also makes sure that #21948 and
fix to #21694.
* For #21694 the underlying problem was that we were calling arityType
on an expression that had free join points. This is a Bad Bad Idea.
See Note [No free join points in arityType].
* To make "no free join points in arityType" work out I had to avoid
trying to use eta-expansion for runRW#. This entailed a few changes
in the Simplifier's treatment of runRW#. See
GHC.Core.Opt.Simplify.Iteration Note [No eta-expansion in runRW#]
* I also made andArityType work correctly with -fpedantic-bottoms;
see Note [Combining case branches: andWithTail].
* Rewrote Note [Combining case branches: optimistic one-shot-ness]
* arityType previously treated join points differently to other
let-bindings. This patch makes them unform; arityType analyses
the RHS of all bindings to get its ArityType, and extends am_sigs.
I realised that, now we have am_sigs giving the ArityType for
let-bound Ids, we don't need the (pre-dating) special code in
arityType for join points. But instead we need to extend the env for
Rec bindings, which weren't doing before. More uniform now. See
Note [arityType for let-bindings].
This meant we could get rid of ae_joins, and in fact get rid of
EtaExpandArity altogether. Simpler.
* And finally, it was the strange treatment of join-point Ids in
arityType (involving a fake ABot type) that led to a serious bug:
#21755. Fixed by this refactoring, which treats them uniformly;
but without breaking #18328.
In fact, the arity for recursive join bindings is pretty tricky;
see the long Note [Arity for recursive join bindings]
in GHC.Core.Opt.Simplify.Utils. That led to more refactoring,
including deciding that an Id could have an Arity that is bigger
than its JoinArity; see Note [Invariants on join points], item
2(b) in GHC.Core
* Make sure that the "demand threshold" for join points in DmdAnal
is no bigger than the join-arity. In GHC.Core.Opt.DmdAnal see
Note [Demand signatures are computed for a threshold arity based on idArity]
* I moved GHC.Core.Utils.exprIsDeadEnd into GHC.Core.Opt.Arity,
where it more properly belongs.
* Remove an old, redundant hack in FloatOut. The old Note was
Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels.
Compile time improves very slightly on average:
Metrics: compile_time/bytes allocated
---------------------------------------------------------------------------------------
T18223(normal) ghc/alloc 725,808,720 747,839,216 +3.0% BAD
T6048(optasm) ghc/alloc 105,006,104 101,599,472 -3.2% GOOD
geo. mean -0.2%
minimum -3.2%
maximum +3.0%
For some reason Windows was better
T10421(normal) ghc/alloc 125,888,360 124,129,168 -1.4% GOOD
T18140(normal) ghc/alloc 85,974,520 83,884,224 -2.4% GOOD
T18698b(normal) ghc/alloc 236,764,568 234,077,288 -1.1% GOOD
T18923(normal) ghc/alloc 75,660,528 73,994,512 -2.2% GOOD
T6048(optasm) ghc/alloc 112,232,512 108,182,520 -3.6% GOOD
geo. mean -0.6%
I had a quick look at T18223 but it is knee deep in coercions and
the size of everything looks similar before and after. I decided
to accept that 3% increase in exchange for goodness elsewhere.
Metric Decrease:
T10421
T18140
T18698b
T18923
T6048
Metric Increase:
T18223
26 files changed, 3359 insertions, 492 deletions
diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs index 16b428cca4..ad1d87feae 100644 --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -43,7 +43,7 @@ module GHC.Core ( -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectTyAndValBinders, - collectNBinders, + collectNBinders, collectNValBinders_maybe, collectArgs, stripNArgs, collectArgsTicks, flattenBinds, collectFunSimple, @@ -746,17 +746,18 @@ Join points must follow these invariants: the binder. Reason: if we want to push a continuation into the RHS we must push it into the unfolding as well. - 2b. The Arity (in the IdInfo) of a join point is the number of value - binders in the top n lambdas, where n is the join arity. + 2b. The Arity (in the IdInfo) of a join point varies independently of the + join-arity. For example, we could have + j x = case x of { T -> \y.y; F -> \y.3 } + Its join-arity is 1, but its idArity is 2; and we do not eta-expand + join points: see Note [Do not eta-expand join points] in + GHC.Core.Opt.Simplify.Utils. - So arity <= join arity; the former counts only value binders - while the latter counts all binders. - e.g. Suppose $j has join arity 1 - let j = \x y. e in case x of { A -> j 1; B -> j 2 } - Then its ordinary arity is also 1, not 2. + Allowing the idArity to be bigger than the join-arity is + important in arityType; see GHC.Core.Opt.Arity + Note [Arity for recursive join bindings] - The arity of a join point isn't very important; but short of setting - it to zero, it is helpful to have an invariant. E.g. #17294. + Historical note: see #17294. 3. If the binding is recursive, then all other bindings in the recursive group must also be join points. @@ -1973,9 +1974,11 @@ collectBinders :: Expr b -> ([b], Expr b) collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) collectValBinders :: CoreExpr -> ([Id], CoreExpr) collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) --- | Strip off exactly N leading lambdas (type or value). Good for use with --- join points. -collectNBinders :: Int -> Expr b -> ([b], Expr b) + +-- | Strip off exactly N leading lambdas (type or value). +-- Good for use with join points. +-- Panic if there aren't enough +collectNBinders :: JoinArity -> Expr b -> ([b], Expr b) collectBinders expr = go [] expr @@ -2008,6 +2011,18 @@ collectNBinders orig_n orig_expr go n bs (Lam b e) = go (n-1) (b:bs) e go _ _ _ = pprPanic "collectNBinders" $ int orig_n +-- | Strip off exactly N leading value lambdas +-- returning all the binders found up to that point +-- Return Nothing if there aren't enough +collectNValBinders_maybe :: Arity -> CoreExpr -> Maybe ([Var], CoreExpr) +collectNValBinders_maybe orig_n orig_expr + = go orig_n [] orig_expr + where + go 0 bs expr = Just (reverse bs, expr) + go n bs (Lam b e) | isId b = go (n-1) (b:bs) e + | otherwise = go n (b:bs) e + go _ _ _ = Nothing + -- | Takes a nested application expression and returns the function -- being applied and the arguments to which it is applied collectArgs :: Expr b -> (Expr b, [Arg b]) diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index b92938e92f..44f6c9d710 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -54,7 +54,7 @@ import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify import GHC.Core.Coercion.Opt ( checkAxInstCo ) -import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Core.Opt.Arity ( typeArity, exprIsDeadEnd ) import GHC.Core.Opt.Monad @@ -895,8 +895,8 @@ lintCoreExpr e@(App _ _) -- N.B. we may have an over-saturated application of the form: -- runRW (\s -> \x -> ...) y , ty_arg1 : ty_arg2 : arg3 : rest <- args - = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1 - ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 ty_arg2 + = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1 + ; (fun_ty2, ue2) <- lintCoreArg fun_pair1 ty_arg2 -- See Note [Linting of runRW#] ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv) lintRunRWCont expr@(Lam _ _) = diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 33e2e44cf2..dc4ffbdc7d 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -13,7 +13,7 @@ module GHC.Core.Opt.Arity ( -- Finding arity manifestArity, joinRhsArity, exprArity - , findRhsArity, exprBotStrictness_maybe + , findRhsArity, cheapArityType , ArityOpts(..) -- ** Eta expansion @@ -23,8 +23,11 @@ module GHC.Core.Opt.Arity , tryEtaReduce -- ** ArityType - , ArityType, mkBotArityType, mkManifestArityType - , arityTypeArity, idArityType, getBotArity + , ArityType, mkBotArityType + , arityTypeArity, idArityType + + -- ** Bottoming things + , exprIsDeadEnd, exprBotStrictness_maybe, arityTypeBotSigs_maybe -- ** typeArity and the state hack , typeArity, typeOneShots, typeOneShot @@ -63,6 +66,7 @@ import GHC.Core.Type as Type import GHC.Core.Coercion as Type import GHC.Types.Demand +import GHC.Types.Cpr( CprSig, mkCprSig, botCpr ) import GHC.Types.Id import GHC.Types.Var.Env import GHC.Types.Var.Set @@ -134,36 +138,22 @@ joinRhsArity _ = 0 --------------- -exprArity :: CoreExpr -> Arity --- ^ An approximate, fast, version of 'exprEtaExpandArity' --- We do /not/ guarantee that exprArity e <= typeArity e --- You may need to do arity trimming after calling exprArity --- See Note [Arity trimming] --- Reason: if we do arity trimming here we have take exprType --- and that can be expensive if there is a large cast -exprArity e = go e - where - go (Var v) = idArity v - go (Lam x e) | isId x = go e + 1 - | otherwise = go e - go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e _) = go e - go (App e (Type _)) = go e - go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 - -- See Note [exprArity for applications] - -- NB: coercions count as a value argument +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness and CPR signatures. +-- It's used during float-out +exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e) - go _ = 0 +arityTypeBotSigs_maybe :: ArityType -> Maybe (Arity, DmdSig, CprSig) +-- Arity of a divergent function +arityTypeBotSigs_maybe (AT lams div) + | isDeadEndDiv div = Just ( arity + , mkVanillaDmdSig arity botDiv + , mkCprSig arity botCpr) + | otherwise = Nothing + where + arity = length lams ---------------- -exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig) --- A cheap and cheerful function that identifies bottoming functions --- and gives them a suitable strictness signatures. It's used during --- float-out -exprBotStrictness_maybe e - = case getBotArity (arityType botStrictnessArityEnv e) of - Nothing -> Nothing - Just ar -> Just (ar, mkVanillaDmdSig ar botDiv) {- Note [exprArity for applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -467,7 +457,14 @@ We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. Note [Dealing with bottom] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -A Big Deal with computing arities is expressions like +GHC does some transformations that are technically unsound wrt +bottom, because doing so improves arities... a lot! We describe +them in this Note. + +The flag -fpedantic-bottoms (off by default) restore technically +correct behaviour at the cots of efficiency. + +It's mostly to do with eta-expansion. Consider f = \x -> case x of True -> \s -> e1 @@ -487,7 +484,7 @@ would lose an important transformation for many programs. (See Consider also f = \x -> error "foo" -Here, arity 1 is fine. But if it is +Here, arity 1 is fine. But if it looks like this (see #22068) f = \x -> case x of True -> error "foo" False -> \y -> x+y @@ -752,7 +749,8 @@ SafeArityType to indicate where we believe the ArityType is safe. -- where the @at@ fields of @ALam@ are inductively subject to the same order. -- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@. -- --- Why the strange Top element? See Note [Combining case branches]. +-- Why the strange Top element? +-- See Note [Combining case branches: optimistic one-shot-ness] -- -- We rely on this lattice structure for fixed-point iteration in -- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType]. @@ -812,9 +810,6 @@ mkBotArityType oss = AT [(IsCheap,os) | os <- oss] botDiv botArityType :: ArityType botArityType = mkBotArityType [] -mkManifestArityType :: [OneShotInfo] -> ArityType -mkManifestArityType oss = AT [(IsCheap,os) | os <- oss] topDiv - topArityType :: ArityType topArityType = AT [] topDiv @@ -850,7 +845,7 @@ trimArityType :: Arity -> ArityType -> ArityType -- they end in 'ABot'. See Note [Arity trimming] trimArityType max_arity at@(AT lams _) | lams `lengthAtMost` max_arity = at - | otherwise = AT (take max_arity lams) topDiv + | otherwise = AT (take max_arity lams) topDiv data ArityOpts = ArityOpts { ao_ped_bot :: !Bool -- See Note [Dealing with bottom] @@ -869,13 +864,7 @@ exprEtaExpandArity opts e | otherwise = Just arity_type where - arity_type = safeArityType (arityType (etaExpandArityEnv opts) e) - -getBotArity :: ArityType -> Maybe Arity --- Arity of a divergent function -getBotArity (AT oss div) - | isDeadEndDiv div = Just $ length oss - | otherwise = Nothing + arity_type = safeArityType (arityType (findRhsArityEnv opts False) e) {- ********************************************************************* @@ -900,7 +889,7 @@ findRhsArity opts is_rec bndr rhs old_arity NonRecursive -> step init_env where init_env :: ArityEnv - init_env = findRhsArityEnv opts + init_env = findRhsArityEnv opts (isJoinId bndr) ty_arity = typeArity (idType bndr) id_one_shots = idDemandOneShots bndr @@ -925,13 +914,13 @@ findRhsArity opts is_rec bndr rhs old_arity go !n cur_at@(AT lams div) | not (isDeadEndDiv div) -- the "stop right away" case , length lams <= old_arity = cur_at -- from above - | next_at == cur_at = cur_at - | otherwise = + | next_at == cur_at = cur_at + | otherwise -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity] - warnPprTrace (debugIsOn && n > 2) + = warnPprTrace (debugIsOn && n > 2) "Exciting arity" (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $ - go (n+1) next_at + go (n+1) next_at where next_at = step (extendSigEnv init_env bndr cur_at) @@ -945,8 +934,9 @@ combineWithDemandOneShots at@(AT lams div) oss where zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo] zip_lams lams [] = lams - zip_lams [] oss = [ (IsExpensive,OneShotLam) - | _ <- takeWhile isOneShotInfo oss] + zip_lams [] oss | isDeadEndDiv div = [] + | otherwise = [ (IsExpensive,OneShotLam) + | _ <- takeWhile isOneShotInfo oss] zip_lams ((ch,os1):lams) (os2:oss) = (ch, os1 `bestOneShot` os2) : zip_lams lams oss @@ -1112,13 +1102,14 @@ floatIn IsCheap at = at floatIn IsExpensive at = addWork at addWork :: ArityType -> ArityType +-- Add work to the outermost level of the arity type addWork at@(AT lams div) = case lams of [] -> at lam:lams' -> AT (add_work lam : lams') div - where - add_work :: ATLamInfo -> ATLamInfo - add_work (_,os) = (IsExpensive,os) + +add_work :: ATLamInfo -> ATLamInfo +add_work (_,os) = (IsExpensive,os) arityApp :: ArityType -> Cost -> ArityType -- Processing (fun arg) where at is the ArityType of fun, @@ -1130,55 +1121,96 @@ arityApp at _ = at -- See the haddocks on 'ArityType' for the lattice. -- -- Used for branches of a @case@. -andArityType :: ArityType -> ArityType -> ArityType -andArityType (AT (lam1:lams1) div1) (AT (lam2:lams2) div2) - | AT lams' div' <- andArityType (AT lams1 div1) (AT lams2 div2) - = AT ((lam1 `and_lam` lam2) : lams') div' -- See Note [Combining case branches] +andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType +andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2) + | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2) + = AT ((lam1 `and_lam` lam2) : lams') div' where (ch1,os1) `and_lam` (ch2,os2) = ( ch1 `addCost` ch2, os1 `bestOneShot` os2) + -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness] -andArityType (AT [] div1) at2 = andWithTail div1 at2 -andArityType at1 (AT [] div2) = andWithTail div2 at1 +andArityType env (AT [] div1) at2 = andWithTail env div1 at2 +andArityType env at1 (AT [] div2) = andWithTail env div2 at1 + +andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType +andWithTail env div1 at2@(AT lams2 _) + | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e } + = at2 -- See Note + | pedanticBottoms env -- [Combining case branches: andWithTail] + = AT [] topDiv -andWithTail :: Divergence -> ArityType -> ArityType -andWithTail div1 at2@(AT oss2 _) - | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e } - = at2 | otherwise -- case x of { T -> plusInt <expensive>; F -> \y.e } - = addWork (AT oss2 topDiv) -- We know div1 = topDiv - -- Note [ABot branches: max arity wins] - -- See Note [Combining case branches] + = AT (map add_work lams2) topDiv -- We know div1 = topDiv + -- See Note [Combining case branches: andWithTail] -{- Note [ABot branches: max arity wins] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider case x of - True -> \x. error "urk" - False -> \xy. error "urk2" +{- Note [Combining case branches: optimistic one-shot-ness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When combining the ArityTypes for two case branches (with +andArityType) and both ArityTypes have ATLamInfo, then we just combine +their expensive-ness and one-shot info. The tricky point is when we +have -Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely diverge". -So we need \??.⊥ for the whole thing, the /max/ of both arities. + case x of True -> \x{one-shot). blah1 + Fale -> \y. blah2 -Note [Combining case branches] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider +Since one-shot-ness is about the /consumer/ not the /producer/, we +optimistically assume that if either branch is one-shot, we combine +the best of the two branches, on the (slightly dodgy) basis that if we +know one branch is one-shot, then they all must be. Surprisingly, +this means that the one-shot arity type is effectively the top element +of the lattice. + +Hence the call to `bestOneShot` in `andArityType`. + +Here's an example: go = \x. let z = go e0 go2 = \x. case x of True -> z False -> \s(one-shot). e1 in go2 x + We *really* want to respect the one-shot annotation provided by the -user and eta-expand go and go2. -When combining the branches of the case we have - T `andAT` \1.T -and we want to get \1.T. -But if the inner lambda wasn't one-shot (\?.T) we don't want to do this. -(We need a usage analysis to justify that.) - -So we combine the best of the two branches, on the (slightly dodgy) -basis that if we know one branch is one-shot, then they all must be. -Surprisingly, this means that the one-shot arity type is effectively the top -element of the lattice. +user and eta-expand go and go2. In the first fixpoint iteration of +'go' we'll bind 'go' to botArityType (written \.⊥, see Note +[ArityType]). So 'z' will get arityType \.⊥; so we end up combining +the True and False branches: + + \.⊥ `andArityType` \1.T + +That gives \1.T (see Note [Combining case branches: andWithTail], +first bullet). So 'go2' gets an arityType of \(C?)(C1).T, which is +what we want. + +Note [Combining case branches: andWithTail] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When combining the ArityTypes for two case branches (with andArityType) +and one side or the other has run out of ATLamInfo; then we get +into `andWithTail`. + +* If one branch is guaranteed bottom (isDeadEndDiv), we just take + the other. Consider case x of + True -> \x. error "urk" + False -> \xy. error "urk2" + + Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely + diverge". So we need \??.⊥ for the whole thing, the /max/ of both + arities. + +* Otherwise, if pedantic-bottoms is on, we just have to return + AT [] topDiv. E.g. if we have + f x z = case x of True -> \y. blah + False -> z + then we can't eta-expand, because that would change the behaviour + of (f False bottom(). + +* But if pedantic-bottoms is not on, we allow ourselves to push + `z` under a lambda (much as we allow ourselves to put the `case x` + under a lambda). However we know nothing about the expensiveness + or one-shot-ness of `z`, so we'd better assume it looks like + (Expensive, NoOneShotInfo) all the way. Remembering + Note [Combining case branches: optimistic one-shot-ness], + we just add work to ever ATLamInfo, keeping the one-shot-ness. Note [Eta expanding through CallStacks] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1213,71 +1245,37 @@ dictionary-typed expression, but that's more work. --------------------------- --- | Each of the entry-points of the analyser ('arityType') has different --- requirements. The entry-points are --- --- 1. 'exprBotStrictness_maybe' --- 2. 'exprEtaExpandArity' --- 3. 'findRhsArity' --- --- For each of the entry-points, there is a separate mode that governs --- --- 1. How pedantic we are wrt. ⊥, in 'pedanticBottoms'. --- 2. Whether we store arity signatures for non-recursive let-bindings, --- accessed in 'extendSigEnv'/'lookupSigEnv'. --- See Note [Arity analysis] why that's important. --- 3. Which expressions we consider cheap to float inside a lambda, --- in 'myExprIsCheap'. -data AnalysisMode - = BotStrictness - -- ^ Used during 'exprBotStrictness_maybe'. - - | EtaExpandArity { am_opts :: !ArityOpts } - -- ^ Used for finding an expression's eta-expanding arity quickly, - -- without fixed-point iteration ('exprEtaExpandArity'). - - | FindRhsArity { am_opts :: !ArityOpts - , am_sigs :: !(IdEnv SafeArityType) } - -- ^ Used for regular, fixed-point arity analysis ('findRhsArity'). - -- See Note [Arity analysis] for details about fixed-point iteration. - -- am_dicts_cheap: see Note [Eta expanding through dictionaries] - -- am_sigs: note `SafeArityType` so we can use this in myIsCheapApp - -- INVARIANT: am_sigs is disjoint with 'ae_joins'. - data ArityEnv - = AE - { ae_mode :: !AnalysisMode - -- ^ The analysis mode. See 'AnalysisMode'. - , ae_joins :: !IdSet - -- ^ In-scope join points. See Note [Eta-expansion and join points] - -- INVARIANT: Disjoint with the domain of 'am_sigs' (if present). - } + = AE { am_opts :: !ArityOpts + + , am_sigs :: !(IdEnv SafeArityType) + -- NB `SafeArityType` so we can use this in myIsCheapApp + -- See Note [Arity analysis] for details about fixed-point iteration. --- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms --- and no application is ever considered cheap. -botStrictnessArityEnv :: ArityEnv -botStrictnessArityEnv = AE { ae_mode = BotStrictness, ae_joins = emptyVarSet } + , am_free_joins :: !Bool -- True <=> free join points allowed + -- Used /only/ to support assertion checks + } --- | The @ArityEnv@ used by 'exprEtaExpandArity'. -etaExpandArityEnv :: ArityOpts -> ArityEnv -etaExpandArityEnv opts - = AE { ae_mode = EtaExpandArity { am_opts = opts } - , ae_joins = emptyVarSet } +instance Outputable ArityEnv where + ppr (AE { am_sigs = sigs, am_free_joins = free_joins }) + = text "AE" <+> braces (sep [ text "free joins:" <+> ppr free_joins + , text "sigs:" <+> ppr sigs ]) -- | The @ArityEnv@ used by 'findRhsArity'. -findRhsArityEnv :: ArityOpts -> ArityEnv -findRhsArityEnv opts - = AE { ae_mode = FindRhsArity { am_opts = opts - , am_sigs = emptyVarEnv } - , ae_joins = emptyVarSet } +findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv +findRhsArityEnv opts free_joins + = AE { am_opts = opts + , am_free_joins = free_joins + , am_sigs = emptyVarEnv } + +freeJoinsOK :: ArityEnv -> Bool +freeJoinsOK (AE { am_free_joins = free_joins }) = free_joins -- First some internal functions in snake_case for deleting in certain VarEnvs -- of the ArityType. Don't call these; call delInScope* instead! modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv -modifySigEnv f env@AE { ae_mode = am@FindRhsArity{am_sigs = sigs} } = - env { ae_mode = am { am_sigs = f sigs } } -modifySigEnv _ env = env +modifySigEnv f env@(AE { am_sigs = sigs }) = env { am_sigs = f sigs } {-# INLINE modifySigEnv #-} del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal! @@ -1288,48 +1286,26 @@ del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal! del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids) {-# INLINE del_sig_env_list #-} -del_join_env :: JoinId -> ArityEnv -> ArityEnv -- internal! -del_join_env id env@(AE { ae_joins = joins }) - = env { ae_joins = delVarSet joins id } -{-# INLINE del_join_env #-} - -del_join_env_list :: [JoinId] -> ArityEnv -> ArityEnv -- internal! -del_join_env_list ids env@(AE { ae_joins = joins }) - = env { ae_joins = delVarSetList joins ids } -{-# INLINE del_join_env_list #-} - -- end of internal deletion functions -extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv -extendJoinEnv env@(AE { ae_joins = joins }) join_ids - = del_sig_env_list join_ids - $ env { ae_joins = joins `extendVarSetList` join_ids } - extendSigEnv :: ArityEnv -> Id -> SafeArityType -> ArityEnv extendSigEnv env id ar_ty - = del_join_env id $ - modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) $ + = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) $ env delInScope :: ArityEnv -> Id -> ArityEnv -delInScope env id = del_join_env id $ del_sig_env id env +delInScope env id = del_sig_env id env delInScopeList :: ArityEnv -> [Id] -> ArityEnv -delInScopeList env ids = del_join_env_list ids $ del_sig_env_list ids env +delInScopeList env ids = del_sig_env_list ids env lookupSigEnv :: ArityEnv -> Id -> Maybe SafeArityType -lookupSigEnv AE{ ae_mode = mode } id = case mode of - BotStrictness -> Nothing - EtaExpandArity{} -> Nothing - FindRhsArity{ am_sigs = sigs } -> lookupVarEnv sigs id +lookupSigEnv (AE { am_sigs = sigs }) id = lookupVarEnv sigs id -- | Whether the analysis should be pedantic about bottoms. -- 'exprBotStrictness_maybe' always is. pedanticBottoms :: ArityEnv -> Bool -pedanticBottoms AE{ ae_mode = mode } = case mode of - BotStrictness -> True - EtaExpandArity{ am_opts = ArityOpts{ ao_ped_bot = ped_bot } } -> ped_bot - FindRhsArity{ am_opts = ArityOpts{ ao_ped_bot = ped_bot } } -> ped_bot +pedanticBottoms (AE { am_opts = ArityOpts{ ao_ped_bot = ped_bot }}) = ped_bot exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost exprCost env e mb_ty @@ -1340,23 +1316,17 @@ exprCost env e mb_ty -- and optionally the expression's type. -- Under 'exprBotStrictness_maybe', no expressions are cheap. myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool -myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of - BotStrictness -> False - _ -> cheap_dict || cheap_fun e - where - cheap_dict = case mb_ty of +myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty + = cheap_dict || cheap_fun e + where + cheap_dict = case mb_ty of Nothing -> False - Just ty -> (ao_dicts_cheap (am_opts mode) && isDictTy ty) + Just ty -> (ao_dicts_cheap opts && isDictTy ty) || isCallStackPredTy ty -- See Note [Eta expanding through dictionaries] -- See Note [Eta expanding through CallStacks] - cheap_fun e = case mode of -#if __GLASGOW_HASKELL__ <= 900 - BotStrictness -> panic "impossible" -#endif - EtaExpandArity{} -> exprIsCheap e - FindRhsArity{am_sigs = sigs} -> exprIsCheapX (myIsCheapApp sigs) e + cheap_fun e = exprIsCheapX (myIsCheapApp sigs) e -- | A version of 'isCheapApp' that considers results from arity analysis. -- See Note [Arity analysis] for what's in the signature environment and why @@ -1369,6 +1339,8 @@ myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of Nothing -> isCheapApp fn n_val_args -- `Just at` means local function with `at` as current SafeArityType. + -- NB the SafeArityType bit: that means we can ignore the cost flags + -- in 'lams', and just consider the length -- Roughly approximate what 'isCheapApp' is doing. Just (AT lams div) | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils @@ -1377,15 +1349,21 @@ myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of | otherwise -> False ---------------- -arityType :: ArityEnv -> CoreExpr -> ArityType - +arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType +-- Precondition: all the free join points of the expression +-- are bound by the ArityEnv +-- See Note [No free join points in arityType] +-- +-- Returns ArityType, not SafeArityType. The caller must do +-- trimArityType if necessary. arityType env (Var v) - | v `elemVarSet` ae_joins env - = botArityType -- See Note [Eta-expansion and join points] | Just at <- lookupSigEnv env v -- Local binding = at | otherwise - = idArityType v + = assertPpr (freeJoinsOK env || not (isJoinId v)) (ppr v) $ + -- All join-point should be in the ae_sigs + -- See Note [No free join points in arityType] + idArityType v arityType env (Cast e _) = arityType env e @@ -1430,50 +1408,237 @@ arityType env (Case scrut bndr _ alts) where env' = delInScope env bndr arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs - alts_type = foldr1 andArityType (map arity_type_alt alts) - -arityType env (Let (NonRec j rhs) body) - | Just join_arity <- isJoinId_maybe j - , (_, rhs_body) <- collectNBinders join_arity rhs - = -- See Note [Eta-expansion and join points] - andArityType (arityType env rhs_body) - (arityType env' body) - where - env' = extendJoinEnv env [j] - -arityType env (Let (Rec pairs) body) - | ((j,_):_) <- pairs - , isJoinId j - = -- See Note [Eta-expansion and join points] - foldr (andArityType . do_one) (arityType env' body) pairs - where - env' = extendJoinEnv env (map fst pairs) - do_one (j,rhs) - | Just arity <- isJoinId_maybe j - = arityType env' $ snd $ collectNBinders arity rhs - | otherwise - = pprPanic "arityType:joinrec" (ppr pairs) + alts_type = foldr1 (andArityType env) (map arity_type_alt alts) arityType env (Let (NonRec b rhs) e) - = floatIn rhs_cost (arityType env' e) + = -- See Note [arityType for non-recursive let-bindings] + floatIn rhs_cost (arityType env' e) where rhs_cost = exprCost env rhs (Just (idType b)) env' = extendSigEnv env b (safeArityType (arityType env rhs)) arityType env (Let (Rec prs) e) - = floatIn (allCosts bind_cost prs) (arityType env' e) + = -- See Note [arityType for recursive let-bindings] + floatIn (allCosts bind_cost prs) (arityType env' e) where - env' = delInScopeList env (map fst prs) bind_cost (b,e) = exprCost env' e (Just (idType b)) + env' = foldl extend_rec env prs + extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv + extend_rec env (b,_) = extendSigEnv env b $ + idArityType b + -- See Note [arityType for recursive let-bindings] arityType env (Tick t e) | not (tickishIsCode t) = arityType env e arityType _ _ = topArityType -{- Note [Eta-expansion and join points] +-------------------- +idArityType :: Id -> ArityType +idArityType v + | strict_sig <- idDmdSig v + , (ds, div) <- splitDmdSig strict_sig + , isDeadEndDiv div + = AT (takeList ds one_shots) div + + | isEmptyTy id_ty + = botArityType + + | otherwise + = AT (take (idArity v) one_shots) topDiv + where + id_ty = idType v + + one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type + one_shots = repeat IsCheap `zip` typeOneShots id_ty + +-------------------- +cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType +-- A fast and cheap version of arityType. +-- Returns an ArityType with IsCheap everywhere +-- c.f. GHC.Core.Utils.exprIsDeadEnd +-- +-- /Can/ encounter a free join-point Id; e.g. via the call +-- in exprBotStrictness_maybe, which is called in lots +-- of places +-- +-- Returns ArityType, not SafeArityType. The caller must do +-- trimArityType if necessary. +cheapArityType e = go e + where + go (Var v) = idArityType v + go (Cast e _) = go e + go (Lam x e) | isId x = arityLam x (go e) + | otherwise = go e + go (App e a) | isTypeArg a = go e + | otherwise = arity_app a (go e) + + go (Tick t e) | not (tickishIsCode t) = go e + + -- Null alts: see Note [Empty case alternatives] in GHC.Core + go (Case _ _ _ alts) | null alts = botArityType + + -- Give up on let, case. In particular, unlike arityType, + -- we make no attempt to look inside let's. + go _ = topArityType + + -- Specialised version of arityApp; all costs in ArityType are IsCheap + -- See Note [exprArity for applications] + -- NB: (1) coercions count as a value argument + -- (2) we use the super-cheap exprIsTrivial rather than the + -- more complicated and expensive exprIsCheap + arity_app _ at@(AT [] _) = at + arity_app arg at@(AT ((cost,_):lams) div) + | assertPpr (cost == IsCheap) (ppr at $$ ppr arg) $ + isDeadEndDiv div = AT lams div + | exprIsTrivial arg = AT lams topDiv + | otherwise = topArityType + +--------------- +exprArity :: CoreExpr -> Arity +-- ^ An approximate, even faster, version of 'cheapArityType' +-- Roughly exprArity e = arityTypeArity (cheapArityType e) +-- But it's a bit less clever about bottoms +-- +-- We do /not/ guarantee that exprArity e <= typeArity e +-- You may need to do arity trimming after calling exprArity +-- See Note [Arity trimming] +-- Reason: if we do arity trimming here we have take exprType +-- and that can be expensive if there is a large cast +exprArity e = go e + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e _) = go e + go (App e (Type _)) = go e + go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 + -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + + go _ = 0 + +--------------- +exprIsDeadEnd :: CoreExpr -> Bool +-- See Note [Bottoming expressions] +-- This function is, in effect, just a specialised (and hence cheap) +-- version of cheapArityType: +-- exprIsDeadEnd e = case cheapArityType e of +-- AT lams div -> null lams && isDeadEndDiv div +-- See also exprBotStrictness_maybe, which uses cheapArityType +exprIsDeadEnd e + = go 0 e + where + go :: Arity -> CoreExpr -> Bool + -- (go n e) = True <=> expr applied to n value args is bottom + go _ (Lit {}) = False + go _ (Type {}) = False + go _ (Coercion {}) = False + go n (App e a) | isTypeArg a = go n e + | otherwise = go (n+1) e + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go n (Lam v e) | isTyVar v = go n e + | otherwise = False + + go _ (Case _ _ _ alts) = null alts + -- See Note [Empty case alternatives] in GHC.Core + + go n (Var v) | isDeadEndAppSig (idDmdSig v) n = True + | isEmptyTy (idType v) = True + | otherwise = False + +{- Note [Bottoming expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A bottoming expression is guaranteed to diverge, or raise an +exception. We can test for it in two different ways, and exprIsDeadEnd +checks for both of these situations: + +* Visibly-bottom computations. For example + (error Int "Hello") + is visibly bottom. The strictness analyser also finds out if + a function diverges or raises an exception, and puts that info + in its strictness signature. + +* Empty types. If a type is empty, its only inhabitant is bottom. + For example: + data T + f :: T -> Bool + f = \(x:t). case x of Bool {} + Since T has no data constructors, the case alternatives are of course + empty. However note that 'x' is not bound to a visibly-bottom value; + it's the *type* that tells us it's going to diverge. + +A GADT may also be empty even though it has constructors: + data T a where + T1 :: a -> T Bool + T2 :: T Int + ...(case (x::T Char) of {})... +Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), +which is likewise uninhabited. + +Note [No free join points in arityType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (#18328) +Suppose we call arityType on this expression (EX1) + \x . case x of True -> \y. e + False -> $j 3 +where $j is a join point. It really makes no sense to talk of the arity +of this expression, because it has a free join point. In particular, we +can't eta-expand the expression because we'd have do the same thing to the +binding of $j, and we can't see that binding. + +If we had (EX2) + \x. join $j y = blah + case x of True -> \y. e + False -> $j 3 +then it would make perfect sense: we can determine $j's ArityType, and +propagate it to the usage site as usual. + +But how can we get (EX1)? It doesn't make much sense, because $j can't +be a join point under the \x anyway. So we make it a precondition of +arityType that the argument has no free join-point Ids. (This is checked +with an assert in the Var case of arityType.) + +Wrinkles + +* We /do/ allow free join point when doing findRhsArity for join-point + right-hand sides. See Note [Arity for recursive join bindings] + point (5) in GHC.Core.Opt.Simplify.Utils. + +* The invariant (no free join point in arityType) risks being + invalidated by one very narrow special case: runRW# + + join $j y = blah + runRW# (\s. case x of True -> \y. e + False -> $j x) + + We have special magic in OccurAnal, and Simplify to allow continuations to + move into the body of a runRW# call. + + So we are careful never to attempt to eta-expand the (\s.blah) in the + argument to runRW#, at least not when there is a literal lambda there, + so that OccurAnal has seen it and allowed join points bound outside. + See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration. + +Note [arityType for non-recursive let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For non-recursive let-bindings, we just get the arityType of the RHS, +and extend the environment. That works nicely for things like this +(#18793): + go = \ ds. case ds_a2CF of { + [] -> id + : y ys -> case y of { GHC.Types.I# x -> + let acc = go ys in + case x ># 42# of { + __DEFAULT -> acc + 1# -> \x1. acc (negate x2) + +Here we want to get a good arity for `acc`, based on the ArityType +of `go`. + +All this is particularly important for join points. Consider this (#18328) f x = join j y = case y of True -> \a. blah @@ -1486,58 +1651,32 @@ Consider this (#18328) and suppose the join point is too big to inline. Now, what is the arity of f? If we inlined the join point, we'd definitely say "arity 2" because we are prepared to push case-scrutinisation inside a -lambda. But currently the join point totally messes all that up, -because (thought of as a vanilla let-binding) the arity pinned on 'j' -is just 1. - -Why don't we eta-expand j? Because of -Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils - -Even if we don't eta-expand j, why is its arity only 1? -See invariant 2b in Note [Invariants on join points] in GHC.Core. - -So we do this: - -* Treat the RHS of a join-point binding, /after/ stripping off - join-arity lambda-binders, as very like the body of the let. - More precisely, do andArityType with the arityType from the - body of the let. - -* Dually, when we come to a /call/ of a join point, just no-op - by returning ABot, the bottom element of ArityType, - which so that: bot `andArityType` x = x - -* This works if the join point is bound in the expression we are - taking the arityType of. But if it's bound further out, it makes - no sense to say that (say) the arityType of (j False) is ABot. - Bad things happen. So we keep track of the in-scope join-point Ids - in ae_join. - -This will make f, above, have arity 2. Then, we'll eta-expand it thus: - - f x eta = (join j y = ... in case x of ...) eta - -and the Simplify will automatically push that application of eta into -the join points. - -An alternative (roughly equivalent) idea would be to carry an -environment mapping let-bound Ids to their ArityType. +lambda. It's important that we extend the envt with j's ArityType, so +that we can use that information in the A/C branch of the case. + +Note [arityType for recursive let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For /recursive/ bindings it's more difficult, to call arityType +(as we do in Note [arityType for non-recursive let-bindings]) +because we don't have an ArityType to put in the envt for the +recursively bound Ids. So for we satisfy ourselves with whizzing up +up an ArityType from the idArity of the function, via idArityType. + +That is nearly equivalent to deleting the binder from the envt, at +which point we'll call idArityType at the occurrences. But doing it +here means + + (a) we only call idArityType once, no matter how many + occurrences, and + + (b) we can check (in the arityType (Var v) case) that + we don't mention free join-point Ids. See + Note [No free join points in arityType]. + +But see Note [Arity for recursive join bindings] in +GHC.Core.Opt.Simplify.Utils for dark corners. -} -idArityType :: Id -> ArityType -idArityType v - | strict_sig <- idDmdSig v - , not $ isNopSig strict_sig - , (ds, div) <- splitDmdSig strict_sig - , let arity = length ds - -- Every strictness signature admits an arity signature! - = AT (take arity one_shots) div - | otherwise - = AT (take (idArity v) one_shots) topDiv - where - one_shots :: [(Cost,OneShotInfo)] -- One-shot-ness derived from the type - one_shots = repeat IsCheap `zip` typeOneShots (idType v) - {- %************************************************************************ %* * @@ -1782,7 +1921,7 @@ nested newtypes. This is expressed by the EtaInfo type: Note [Check for reflexive casts in eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It turns out that the casts created by teh above mechanism are often Refl. +It turns out that the casts created by the above mechanism are often Refl. When casts are very deeply nested (as happens in #18223), the repetition of types can make the overall term very large. So there is a big payoff in cancelling out casts aggressively wherever possible. diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index c3fd09c6e0..966535897a 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -956,16 +956,15 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $ (final_env, lazy_fv, final_id, final_rhs) where - rhs_arity = idArity id - -- See Note [Demand signatures are computed for a threshold demand based on idArity] + threshold_arity = thresholdArity id rhs - rhs_dmd = mkCalledOnceDmds rhs_arity body_dmd + rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd body_dmd | isJoinId id -- See Note [Demand analysis for join points] -- See Note [Invariants on join points] invariant 2b, in GHC.Core - -- rhs_arity matches the join arity of the join point + -- threshold_arity matches the join arity of the join point -- See Note [Unboxed demand on function bodies returning small products] = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd | otherwise @@ -975,10 +974,10 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty -- See Note [Boxity for bottoming functions] - (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div + (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity rhs' rhs_div `orElse` (rhs_dmds, rhs') - sig = mkDmdSigForArity rhs_arity (DmdType sig_fv final_rhs_dmds rhs_div) + sig = mkDmdSigForArity threshold_arity (DmdType sig_fv final_rhs_dmds rhs_div) final_id = id `setIdDmdSig` sig !final_env = extendAnalEnv top_lvl env final_id sig @@ -1005,6 +1004,13 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs -- See Note [Lazy and unleashable free variables] !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 +thresholdArity :: Id -> CoreExpr -> Arity +-- See Note [Demand signatures are computed for a threshold arity based on idArity] +thresholdArity fn rhs + = case isJoinId_maybe fn of + Just join_arity -> count isId $ fst $ collectNBinders join_arity rhs + Nothing -> idArity fn + -- | The result type after applying 'idArity' many arguments. Returns 'Nothing' -- when the type doesn't have exactly 'idArity' many arrows. resultType_maybe :: Id -> Maybe Type @@ -1137,28 +1143,40 @@ meaning one absent argument, returns bottom. That seems odd because there's a \y inside. But it's right because when consumed in a C1(L) context the RHS of the join point is indeed bottom. -Note [Demand signatures are computed for a threshold demand based on idArity] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We compute demand signatures assuming idArity incoming arguments to approximate -behavior for when we have a call site with at least that many arguments. idArity -is /at least/ the number of manifest lambdas, but might be higher for PAPs and -trivial RHS (see Note [Demand analysis for trivial right-hand sides]). +Note [Demand signatures are computed for a threshold arity based on idArity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Given a binding { f = rhs }, we compute a "theshold arity", and do demand +analysis based on a call with that many value arguments. -Because idArity of a function varies independently of its cardinality -properties (cf. Note [idArity varies independently of dmdTypeDepth]), we -implicitly encode the arity for when a demand signature is sound to unleash -in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and DmdSig] in -GHC.Types.Demand). It is unsound to unleash a demand signature when the -incoming number of arguments is less than that. -See Note [What are demand signatures?] in GHC.Types.Demand for more details -on soundness. +The threshold we use is -Why idArity arguments? Because that's a conservative estimate of how many -arguments we must feed a function before it does anything interesting with them. -Also it elegantly subsumes the trivial RHS and PAP case. +* Ordinary bindings: idArity f. + Why idArity arguments? Because that's a conservative estimate of how many + arguments we must feed a function before it does anything interesting with + them. Also it elegantly subsumes the trivial RHS and PAP case. -There might be functions for which we might want to analyse for more incoming -arguments than idArity. Example: + idArity is /at least/ the number of manifest lambdas, but might be higher for + PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]). + +* Join points: the value-binder subset of the JoinArity. This can + be less than the number of visible lambdas; e.g. + join j x = \y. blah + in ...(jump j 2)....(jump j 3).... + We know that j will never be applied to more than 1 arg (its join + arity, and we don't eta-expand join points, so here a threshold + of 1 is the best we can do. + +Note that the idArity of a function varies independently of its cardinality +properties (cf. Note [idArity varies independently of dmdTypeDepth]), so we +implicitly encode the arity for when a demand signature is sound to unleash +in its 'dmdTypeDepth', not in its idArity (cf. Note [Understanding DmdType +and DmdSig] in GHC.Types.Demand). It is unsound to unleash a demand +signature when the incoming number of arguments is less than that. See +GHC.Types.Demand Note [What are demand signatures?] for more details on +soundness. + +Note that there might, in principle, be functions for which we might want to +analyse for more incoming arguments than idArity. Example: f x = if expensive @@ -1175,6 +1193,7 @@ strictness info for `y` (and more precise info on `x`) and possibly CPR information, but * We would no longer be able to unleash the signature at unary call sites + * Performing the worker/wrapper split based on this information would be implicitly eta-expanding `f`, playing fast and loose with divergence and even being unsound in the presence of newtypes, so we refrain from doing so. diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index 362cab0056..b6ee3691c8 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -15,12 +15,13 @@ import GHC.Prelude import GHC.Core import GHC.Core.Utils import GHC.Core.Make -import GHC.Core.Opt.Arity ( exprArity, etaExpand ) +-- import GHC.Core.Opt.Arity ( exprArity, etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Driver.Flags ( DumpFlag (..) ) import GHC.Utils.Logger -import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, +import GHC.Types.Id ( Id, idType, +-- idArity, isDeadEndId, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Core.Opt.SetLevels @@ -218,14 +219,7 @@ floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind]) -- See Note [Floating out of Rec rhss] for why things get arranged this way. floatBind (NonRec (TB var _) rhs) = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') -> - - -- A tiresome hack: - -- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels - let rhs'' | isDeadEndId var - , exprArity rhs' < idArity var = etaExpand (idArity var) rhs' - | otherwise = rhs' - - in (fs, rhs_floats, [NonRec var rhs'']) } + (fs, rhs_floats, [NonRec var rhs']) } floatBind (Rec pairs) = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 85ac7e2e86..9645a10340 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -104,7 +104,7 @@ import GHC.Types.Unique.DSet ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal ( litIsTrivial ) import GHC.Types.Demand ( DmdSig, prependArgsDmdSig ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) +import GHC.Types.Cpr ( CprSig, prependArgsCprSig ) import GHC.Types.Name ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique ( hasKey ) @@ -659,9 +659,7 @@ lvlMFE env strict_ctxt ann_expr -- No wrapping needed if the type is lifted, or is a literal string -- or if we are wrapping it in one or more value lambdas = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive - (isJust mb_bot_str) - join_arity_maybe - ann_expr + is_bot_lam join_arity_maybe ann_expr -- Treat the expr just like a right-hand side ; var <- newLvlVar expr1 join_arity_maybe is_mk_static ; let var2 = annotateBotStr var float_n_lams mb_bot_str @@ -702,6 +700,7 @@ lvlMFE env strict_ctxt ann_expr fvs = freeVarsOf ann_expr fvs_ty = tyCoVarsOfType expr_ty is_bot = isBottomThunk mb_bot_str + is_bot_lam = isJust mb_bot_str is_function = isFunction ann_expr mb_bot_str = exprBotStrictness_maybe expr -- See Note [Bottoming floats] @@ -750,10 +749,10 @@ hasFreeJoin :: LevelEnv -> DVarSet -> Bool hasFreeJoin env fvs = not (maxFvLevel isJoinId env fvs == tOP_LEVEL) -isBottomThunk :: Maybe (Arity, s) -> Bool +isBottomThunk :: Maybe (Arity, DmdSig, CprSig) -> Bool -- See Note [Bottoming floats] (2) -isBottomThunk (Just (0, _)) = True -- Zero arity -isBottomThunk _ = False +isBottomThunk (Just (0, _, _)) = True -- Zero arity +isBottomThunk _ = False {- Note [Floating to the top] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -977,16 +976,6 @@ Id, *immediately*, for three reasons: thing is based on the cheap-and-cheerful exprIsDeadEnd, I'm not sure that it'll nail all such cases. -Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Tiresomely, though, the simplifier has an invariant that the manifest -arity of the RHS should be the same as the arity; but we can't call -etaExpand during GHC.Core.Opt.SetLevels because it works over a decorated form of -CoreExpr. So we do the eta expansion later, in GHC.Core.Opt.FloatOut. -But we should only eta-expand if the RHS doesn't already have the right -exprArity, otherwise we get unnecessary top-level bindings if the RHS was -trivial after the next run of the Simplifier. - Note [Case MFEs] ~~~~~~~~~~~~~~~~ We don't float a case expression as an MFE from a strict context. Why not? @@ -1008,17 +997,18 @@ answer. -} -annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig) -> Id +annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id -- See Note [Bottoming floats] for why we want to add -- bottoming information right now -- -- n_extra are the number of extra value arguments added during floating -annotateBotStr id n_extra mb_str - = case mb_str of - Nothing -> id - Just (arity, sig) -> id `setIdArity` (arity + n_extra) - `setIdDmdSig` prependArgsDmdSig n_extra sig - `setIdCprSig` mkCprSig (arity + n_extra) botCpr +annotateBotStr id n_extra mb_bot_str + | Just (arity, str_sig, cpr_sig) <- mb_bot_str + = id `setIdArity` (arity + n_extra) + `setIdDmdSig` prependArgsDmdSig n_extra str_sig + `setIdCprSig` prependArgsCprSig n_extra cpr_sig + | otherwise + = id notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by @@ -1127,7 +1117,7 @@ lvlBind env (AnnNonRec bndr rhs) -- bit brutal, but unlifted bindings aren't expensive either = -- No float - do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs + do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs ; let bind_lvl = incMinorLvl (le_ctxt_lvl env) (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr] ; return (NonRec bndr' rhs', env') } @@ -1136,7 +1126,7 @@ lvlBind env (AnnNonRec bndr rhs) | null abs_vars = do { -- No type abstraction; clone existing binder rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive - is_bot mb_join_arity rhs + is_bot_lam mb_join_arity rhs ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr] ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } @@ -1144,7 +1134,7 @@ lvlBind env (AnnNonRec bndr rhs) | otherwise = do { -- Yes, type abstraction; create a new binder, extend substitution, etc rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive - is_bot mb_join_arity rhs + is_bot_lam mb_join_arity rhs ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr] ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') } @@ -1155,11 +1145,12 @@ lvlBind env (AnnNonRec bndr rhs) rhs_fvs = freeVarsOf rhs bind_fvs = rhs_fvs `unionDVarSet` dIdFreeVars bndr abs_vars = abstractVars dest_lvl env bind_fvs - dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join + dest_lvl = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam is_join deann_rhs = deAnnotate rhs mb_bot_str = exprBotStrictness_maybe deann_rhs - is_bot = isJust mb_bot_str + is_bot_lam = isJust mb_bot_str + -- is_bot_lam: looks like (\xy. bot), maybe zero lams -- NB: not isBottomThunk! See Note [Bottoming floats] point (3) n_extra = count isId abs_vars diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs index 7ee623b937..9fea132486 100644 --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -38,8 +38,8 @@ import GHC.Core.Ppr ( pprCoreExpr ) import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils -import GHC.Core.Opt.Arity ( ArityType, exprArity, getBotArity - , pushCoTyArg, pushCoValArg +import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe + , pushCoTyArg, pushCoValArg, exprIsDeadEnd , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo ) @@ -53,7 +53,6 @@ import GHC.Types.Id.Make ( seqId ) import GHC.Types.Id.Info import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS ) import GHC.Types.Demand -import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Unique ( hasKey ) import GHC.Types.Basic import GHC.Types.Tickish @@ -301,8 +300,8 @@ simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs | otherwise = case bind_cxt of - BC_Join cont -> simplTrace "SimplBind:join" (ppr old_bndr) $ - simplJoinBind env cont old_bndr new_bndr rhs env + BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $ + simplJoinBind env is_rec cont old_bndr new_bndr rhs env BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $ simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env @@ -385,16 +384,17 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se -------------------------- simplJoinBind :: SimplEnv + -> RecFlag -> SimplCont -> InId -> OutId -- Binder, both pre-and post simpl -- The OutId has IdInfo, except arity, -- unfolding -> InExpr -> SimplEnv -- The right hand side and its env -> SimplM (SimplFloats, SimplEnv) -simplJoinBind env cont old_bndr new_bndr rhs rhs_se +simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se = do { let rhs_env = rhs_se `setInScopeFromE` env ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont - ; completeBind env (BC_Join cont) old_bndr new_bndr rhs' } + ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' } -------------------------- simplNonRecX :: SimplEnv @@ -982,11 +982,11 @@ addLetBndrInfo new_bndr new_arity_type new_unf = info2 -- Bottoming bindings: see Note [Bottoming bindings] - info4 = case getBotArity new_arity_type of + info4 = case arityTypeBotSigs_maybe new_arity_type of Nothing -> info3 - Just ar -> assert (ar == new_arity) $ - info3 `setDmdSigInfo` mkVanillaDmdSig new_arity botDiv - `setCprSigInfo` mkCprSig new_arity botCpr + Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $ + info3 `setDmdSigInfo` str_sig + `setCprSigInfo` cpr_sig -- Zap call arity info. We have used it by now (via -- `tryEtaExpandRhs`), and the simplifier can invalidate this @@ -1872,8 +1872,8 @@ simplNonRecJoinPoint env bndr rhs body cont ; let mult = contHoleScaling cont res_ty = contResultType cont ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join cont) - ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env + ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) + ; (floats1, env3) <- simplJoinBind env2 NonRecursive cont bndr bndr2 rhs env ; (floats2, body') <- simplExprF env3 body cont ; return (floats1 `addFloats` floats2, body') } @@ -1890,7 +1890,7 @@ simplRecJoinPoint env pairs body cont ; env1 <- simplRecJoinBndrs env bndrs mult res_ty -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down - ; (floats1, env2) <- simplRecBind env1 (BC_Join cont) pairs + ; (floats1, env2) <- simplRecBind env1 (BC_Join Recursive cont) pairs ; (floats2, body') <- simplExprF env2 body cont ; return (floats1 `addFloats` floats2, body') } @@ -2173,19 +2173,32 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_cont = cont, sc_hole_ty = fun_ty }) | fun_id `hasKey` runRWKey - , not (contIsStop cont) -- Don't fiddle around if the continuation is boring , [ TyArg {}, TyArg {} ] <- rev_args - = do { s <- newId (fsLit "s") Many realWorldStatePrimTy - ; let (m,_,_) = splitFunTy fun_ty - env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] + -- Do this even if (contIsStop cont) + -- See Note [No eta-expansion in runRW#] + = do { let arg_env = arg_se `setInScopeFromE` env ty' = contResultType cont - cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s - , sc_env = env', sc_cont = cont - , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } - -- cont' applies to s, then K - ; body' <- simplExprC env' arg cont' - ; let arg' = Lam s body' - rr' = getRuntimeRep ty' + + -- If the argument is a literal lambda already, take a short cut + -- This isn't just efficiency; if we don't do this we get a beta-redex + -- every time, so the simplifier keeps doing more iterations. + ; arg' <- case arg of + Lam s body -> do { (env', s') <- simplBinder arg_env s + ; body' <- simplExprC env' body cont + ; return (Lam s' body') } + -- Important: do not try to eta-expand this lambda + -- See Note [No eta-expansion in runRW#] + _ -> do { s' <- newId (fsLit "s") Many realWorldStatePrimTy + ; let (m,_,_) = splitFunTy fun_ty + env' = arg_env `addNewInScopeIds` [s'] + cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' + , sc_env = env', sc_cont = cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } + -- cont' applies to s', then K + ; body' <- simplExprC env' arg cont' + ; return (Lam s' body') } + + ; let rr' = getRuntimeRep ty' call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] ; return (emptyFloats env, call') } @@ -2292,6 +2305,19 @@ to get the effect that finding (error "foo") in a strict arg position will discard the entire application and replace it with (error "foo"). Getting all this at once is TOO HARD! +Note [No eta-expansion in runRW#] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we see `runRW# (\s. blah)` we must not attempt to eta-expand that +lambda. Why not? Because +* `blah` can mention join points bound outside the runRW# +* eta-expansion uses arityType, and +* `arityType` cannot cope with free join Ids: + +So the simplifier spots the literal lambda, and simplifies inside it. +It's a very special lambda, because it is the one the OccAnal spots and +allows join points bound /outside/ to be called /inside/. + +See Note [No free join points in arityType] in GHC.Core.Opt.Arity ************************************************************************ * * @@ -4126,9 +4152,9 @@ simplStableUnfolding env bind_cxt id rhs_ty id_arity unf CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide } | isStableSource src -> do { expr' <- case bind_cxt of - BC_Join cont -> -- Binder is a join point - -- See Note [Rules and unfolding for join points] - simplJoinRhs unf_env id expr cont + BC_Join _ cont -> -- Binder is a join point + -- See Note [Rules and unfolding for join points] + simplJoinRhs unf_env id expr cont BC_Let _ is_rec -> -- Binder is not a join point do { let cont = mkRhsStop rhs_ty is_rec topDmd -- mkRhsStop: switch off eta-expansion at the top level @@ -4181,6 +4207,7 @@ simplStableUnfolding env bind_cxt id rhs_ty id_arity unf -- See Note [Eta-expand stable unfoldings] -- Use the arity from the main Id (in id_arity), rather than computing it from rhs + -- Not used for join points eta_expand expr | seEtaExpand env , exprArity expr < arityTypeArity id_arity , wantEtaExpansion expr @@ -4219,7 +4246,7 @@ Wrinkles * Don't eta-expand join points; see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point - case (bind_cxt = BC_Join _) doesn't use eta_expand. + case (bind_cxt = BC_Join {}) doesn't use eta_expand. Note [Force bottoming field] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -4292,8 +4319,8 @@ simplRules env mb_new_id rules bind_cxt = do { (env', bndrs') <- simplBinders env bndrs ; let rhs_ty = substTy env' (exprType rhs) rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points] - BC_Let {} -> mkBoringStop rhs_ty - BC_Join cont -> assertPpr join_ok bad_join_msg cont + BC_Let {} -> mkBoringStop rhs_ty + BC_Join _ cont -> assertPpr join_ok bad_join_msg cont lhs_env = updMode updModeForRules env' rhs_env = updMode (updModeForStableUnfoldings act) env' -- See Note [Simplifying the RHS of a RULE] diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index cb99a16acc..b44b195e84 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -95,8 +95,8 @@ data BindContext TopLevelFlag RecFlag | BC_Join -- A join point with continuation k - SimplCont -- See Note [Rules and unfolding for join points] - -- in GHC.Core.Opt.Simplify + RecFlag -- See Note [Rules and unfolding for join points] + SimplCont -- in GHC.Core.Opt.Simplify bindContextLevel :: BindContext -> TopLevelFlag bindContextLevel (BC_Let top_lvl _) = top_lvl @@ -1779,20 +1779,20 @@ tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr -- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then -- (a) rhs' has manifest arity n -- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom -tryEtaExpandRhs _env (BC_Join {}) bndr rhs - | Just join_arity <- isJoinId_maybe bndr - = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs - oss = [idOneShotInfo id | id <- join_bndrs, isId id] - arity_type | exprIsDeadEnd join_body = mkBotArityType oss - | otherwise = mkManifestArityType oss - ; return (arity_type, rhs) } - -- Note [Do not eta-expand join points] - -- But do return the correct arity and bottom-ness, because - -- these are used to set the bndr's IdInfo (#15517) - -- Note [Invariants on join points] invariant 2b, in GHC.Core - - | otherwise - = pprPanic "tryEtaExpandRhs" (ppr bndr) +tryEtaExpandRhs env (BC_Join is_rec _) bndr rhs + = assertPpr (isJoinId bndr) (ppr bndr) $ + return (arity_type, rhs) + -- Note [Do not eta-expand join points] + -- But do return the correct arity and bottom-ness, because + -- these are used to set the bndr's IdInfo (#15517) + -- Note [Invariants on join points] invariant 2b, in GHC.Core + where + -- See Note [Arity for non-recursive join bindings] + -- and Note [Arity for recursive join bindings] + arity_type = case is_rec of + NonRecursive -> cheapArityType rhs + Recursive -> findRhsArity (seArityOpts env) Recursive + bndr rhs (exprArity rhs) tryEtaExpandRhs env (BC_Let _ is_rec) bndr rhs | seEtaExpand env -- Provided eta-expansion is on @@ -1805,8 +1805,8 @@ tryEtaExpandRhs env (BC_Let _ is_rec) bndr rhs = return (arity_type, rhs) where in_scope = getInScope env - arity_opts = seArityOpts env old_arity = exprArity rhs + arity_opts = seArityOpts env arity_type = findRhsArity arity_opts is_rec bndr rhs old_arity new_arity = arityTypeArity arity_type @@ -1933,6 +1933,78 @@ CorePrep comes around, the code is very likely to look more like this: $j2 = if n > 0 then $j1 else (...) eta +Note [Arity for recursive join bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = joinrec j 0 = \ a b c -> (a,x,b) + j n = j (n-1) + in j 20 + +Obviously `f` should get arity 4. But it's a bit tricky: + +1. Remember, we don't eta-expand join points; see + Note [Do not eta-expand join points]. + +2. But even though we aren't going to eta-expand it, we still want `j` to get + idArity=4, via the findRhsArity fixpoint. Then when we are doing findRhsArity + for `f`, we'll call arityType on f's RHS: + - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType + for `j` (See Note [arityType for non-recursive let-bindings] + in GHC.Core.Opt.Arity)b + - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3 + result. + +3. All this, even though j's /join-arity/ (stored in the JoinId) is 1. + This is is the Main Reason that we want the idArity to sometimes be + larger than the join-arity c.f. Note [Invariants on join points] item 2b + in GHC.Core. + +4. Be very careful of things like this (#21755): + g x = let j 0 = \y -> (x,y) + j n = expensive n `seq` j (n-1) + in j x + Here we do /not/ want eta-expand `g`, lest we duplicate all those + (expensive n) calls. + + But it's fine: the findRhsArity fixpoint calculation will compute arity-1 + for `j` (not arity 2); and that's just what we want. But we do need that + fixpoint. + + Historical note: an earlier version of GHC did a hack in which we gave + join points an ArityType of ABot, but that did not work with this #21755 + case. + +5. arityType does not usually expect to encounter free join points; + see GHC.Core.Opt.Arity Note [No free join points in arityType]. + But consider + f x = join j1 y = .... in + joinrec j2 z = ...j1 y... in + j2 v + + When doing findRhsArity on `j2` we'll encounter the free `j1`. + But that is fine, because we aren't going to eta-expand `j2`; + we just want to know its arity. So we have a flag am_no_eta, + switched on when doing findRhsArity on a join point RHS. If + the flag is on, we allow free join points, but not otherwise. + + +Note [Arity for non-recursive join bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Arity for recursive join bindings] deals with recursive join +bindings. But what about /non-recursive/ones? If we just call +findRhsArity, it will call arityType. And that can be expensive when +we have deeply nested join points: + join j1 x1 = join j2 x2 = join j3 x3 = blah3 + in blah2 + in blah1 +(e.g. test T18698b). + +So we call cheapArityType instead. It's good enough for practical +purposes. + +(Side note: maybe we should use cheapArity for the RHS of let bindings +in the main arityType function.) + ************************************************************************ * * diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 8b3e0f0e43..30d4993abc 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -745,11 +745,7 @@ by LitRubbish (see Note [Drop absent bindings]) so there is no great harm. --------------------- splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun ww_opts fn_id rhs - | not (wrap_dmds `lengthIs` count isId arg_vars) - -- See Note [Don't eta expand in w/w] - = return [(fn_id, rhs)] - - | otherwise + | Just (arg_vars, body) <- collectNValBinders_maybe (length wrap_dmds) rhs = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info))) "splitFun" (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $ @@ -772,10 +768,13 @@ splitFun ww_opts fn_id rhs -> do { work_uniq <- getUniqueM ; return (mkWWBindPair ww_opts fn_id fn_info arg_vars body work_uniq div stuff) } } + + | otherwise -- See Note [Don't eta expand in w/w] + = return [(fn_id, rhs)] + where uf_opts = so_uf_opts (wo_simple_opts ww_opts) fn_info = idInfo fn_id - (arg_vars, body) = collectBinders rhs (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index 3f6c212f49..d3cface58c 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -117,8 +117,7 @@ tidyCbvInfoTop boot_exports id rhs -- See Note [CBV Function Ids] tidyCbvInfoLocal :: HasDebugCallStack => Id -> CoreExpr -> Id -tidyCbvInfoLocal id rhs - | otherwise = computeCbvInfo id rhs +tidyCbvInfoLocal id rhs = computeCbvInfo id rhs -- | For a binding we: -- * Look at the args @@ -135,9 +134,9 @@ computeCbvInfo :: HasCallStack -> Id -- computeCbvInfo fun_id rhs = fun_id computeCbvInfo fun_id rhs - | (isWorkerLike || isJoinId fun_id) && (valid_unlifted_worker val_args) - = - -- pprTrace "computeCbvInfo" + | is_wkr_like || isJust mb_join_id + , valid_unlifted_worker val_args + = -- pprTrace "computeCbvInfo" -- (text "fun" <+> ppr fun_id $$ -- text "arg_tys" <+> ppr (map idType val_args) $$ @@ -146,31 +145,48 @@ computeCbvInfo fun_id rhs -- text "cbv_marks" <+> ppr cbv_marks $$ -- text "out_id" <+> ppr cbv_bndr $$ -- ppr rhs) - cbv_bndr + cbv_bndr + | otherwise = fun_id where - val_args = filter isId . fst $ collectBinders rhs - cbv_marks = - -- CBV marks are only set during tidy so none should be present already. - assertPpr (maybe True null $ idCbvMarks_maybe fun_id) (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $ - map mkMark val_args - cbv_bndr - | valid_unlifted_worker val_args - , any isMarkedCbv cbv_marks - -- seqList to avoid retaining the original rhs - = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks - | otherwise = - -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" (ppr fun_id <+> ppr rhs) - asNonWorkerLikeId fun_id - -- We don't set CBV marks on functions which take unboxed tuples or sums as arguments. - -- Doing so would require us to compute the result of unarise here in order to properly determine - -- argument positions at runtime. - -- In practice this doesn't matter much. Most "interesting" functions will get a W/W split which will eliminate - -- unboxed tuple arguments, and unboxed sums are rarely used. But we could change this in the future and support + mb_join_id = isJoinId_maybe fun_id + is_wkr_like = isWorkerLikeId fun_id + + val_args = filter isId lam_bndrs + -- When computing CbvMarks, we limit the arity of join points to + -- the JoinArity, because that's the arity we are going to use + -- when calling it. There may be more lambdas than that on the RHS. + lam_bndrs | Just join_arity <- mb_join_id + = fst $ collectNBinders join_arity rhs + | otherwise + = fst $ collectBinders rhs + + cbv_marks = -- assert: CBV marks are only set during tidy so none should be present already. + assertPpr (maybe True null $ idCbvMarks_maybe fun_id) + (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $ + map mkMark val_args + + cbv_bndr | any isMarkedCbv cbv_marks + = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks + -- seqList: avoid retaining the original rhs + + | otherwise + = -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" + -- (ppr fun_id <+> ppr rhs) + asNonWorkerLikeId fun_id + + -- We don't set CBV marks on functions which take unboxed tuples or sums as + -- arguments. Doing so would require us to compute the result of unarise + -- here in order to properly determine argument positions at runtime. + -- + -- In practice this doesn't matter much. Most "interesting" functions will + -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed + -- sums are rarely used. But we could change this in the future and support -- unboxed sums/tuples as well. valid_unlifted_worker args = -- pprTrace "valid_unlifted" (ppr fun_id $$ ppr args) $ all isSingleUnarisedArg args + isSingleUnarisedArg v | isUnboxedSumType ty = False | isUnboxedTupleType ty = isSimplePrimRep (typePrimRep ty) @@ -188,7 +204,6 @@ computeCbvInfo fun_id rhs , not (isDeadEndId fun_id) = MarkedCbv | otherwise = NotMarkedCbv - isWorkerLike = isWorkerLikeId fun_id ------------ Expressions -------------- tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr @@ -339,7 +354,7 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id new_info = vanillaIdInfo `setOccInfo` occInfo old_info `setArityInfo` arityInfo old_info - `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info) + `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info) `setDemandInfo` demandInfo old_info `setInlinePragInfo` inlinePragInfo old_info `setUnfoldingInfo` new_unf diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 30597dd8e5..57a1ccacc3 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -23,7 +23,7 @@ module GHC.Core.Utils ( -- * Properties of expressions exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, mkFunctionType, - exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd, + exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval, @@ -1073,63 +1073,8 @@ getIdFromTrivialExpr_maybe e go (Var v) = Just v go _ = Nothing -{- -exprIsDeadEnd is a very cheap and cheerful function; it may return -False for bottoming expressions, but it never costs much to ask. See -also GHC.Core.Opt.Arity.exprBotStrictness_maybe, but that's a bit more -expensive. --} -exprIsDeadEnd :: CoreExpr -> Bool --- See Note [Bottoming expressions] -exprIsDeadEnd e - | isEmptyTy (exprType e) - = True - | otherwise - = go 0 e - where - go n (Var v) = isDeadEndAppSig (idDmdSig v) n - go n (App e a) | isTypeArg a = go n e - | otherwise = go (n+1) e - go n (Tick _ e) = go n e - go n (Cast e _) = go n e - go n (Let _ e) = go n e - go n (Lam v e) | isTyVar v = go n e - go _ (Case _ _ _ alts) = null alts - -- See Note [Empty case alternatives] in GHC.Core - go _ _ = False - -{- Note [Bottoming expressions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A bottoming expression is guaranteed to diverge, or raise an -exception. We can test for it in two different ways, and exprIsDeadEnd -checks for both of these situations: - -* Visibly-bottom computations. For example - (error Int "Hello") - is visibly bottom. The strictness analyser also finds out if - a function diverges or raises an exception, and puts that info - in its strictness signature. - -* Empty types. If a type is empty, its only inhabitant is bottom. - For example: - data T - f :: T -> Bool - f = \(x:t). case x of Bool {} - Since T has no data constructors, the case alternatives are of course - empty. However note that 'x' is not bound to a visibly-bottom value; - it's the *type* that tells us it's going to diverge. - -A GADT may also be empty even though it has constructors: - data T a where - T1 :: a -> T Bool - T2 :: T Int - ...(case (x::T Char) of {})... -Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), -which is likewise uninhabited. - - -************************************************************************ +{- ********************************************************************* * * exprIsDupable * * diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index a8529cbff7..76c0a7b2cb 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -53,7 +53,6 @@ import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info import GHC.Types.Demand ( isDeadEndAppSig, isNopSig, nopSig, isDeadEndSig ) -import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set @@ -1275,21 +1274,22 @@ tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unf -- No demand signature, so try a -- cheap-and-cheerful bottom analyser - | Just (_, nsig) <- mb_bot_str - = nsig + | Just (_, bot_str_sig, _) <- mb_bot_str + = bot_str_sig -- No stricness info | otherwise = nopSig cpr = cprSigInfo idinfo - final_cpr | Just _ <- mb_bot_str - = mkCprSig arity botCpr + final_cpr | Just (_, _, bot_cpr_sig) <- mb_bot_str + = bot_cpr_sig | otherwise = cpr - _bottom_hidden id_sig = case mb_bot_str of - Nothing -> False - Just (arity, _) -> not (isDeadEndAppSig id_sig arity) + _bottom_hidden id_sig + = case mb_bot_str of + Nothing -> False + Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity) --------- Unfolding ------------ unf_info = realUnfoldingInfo idinfo diff --git a/testsuite/tests/arityanal/should_compile/T21755.hs b/testsuite/tests/arityanal/should_compile/T21755.hs new file mode 100644 index 0000000000..c21557125c --- /dev/null +++ b/testsuite/tests/arityanal/should_compile/T21755.hs @@ -0,0 +1,11 @@ +module T21755 where + +mySum :: [Int] -> Int +mySum [] = 0 +mySum (x:xs) = x + mySum xs + +f :: Int -> (Int -> Int) -> Int -> Int +f k z = + if even (mySum [0..k]) + then \n -> n + 1 + else \n -> z n diff --git a/testsuite/tests/arityanal/should_compile/T21755.stderr b/testsuite/tests/arityanal/should_compile/T21755.stderr new file mode 100644 index 0000000000..0519ecba6e --- /dev/null +++ b/testsuite/tests/arityanal/should_compile/T21755.stderr @@ -0,0 +1 @@ +
\ No newline at end of file diff --git a/testsuite/tests/arityanal/should_compile/all.T b/testsuite/tests/arityanal/should_compile/all.T index cb962dd32a..6124bf12c9 100644 --- a/testsuite/tests/arityanal/should_compile/all.T +++ b/testsuite/tests/arityanal/should_compile/all.T @@ -21,3 +21,4 @@ test('Arity16', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dn test('T18793', [ only_ways(['optasm']), grep_errmsg('Arity=') ], compile, ['-dno-typeable-binds -ddump-simpl -dppr-cols=99999 -dsuppress-uniques']) test('T18870', [ only_ways(['optasm']) ], compile, ['-ddebug-output']) test('T18937', [ only_ways(['optasm']) ], compile, ['-ddebug-output']) +test('T21755', [ grep_errmsg(r'Arity=') ], compile, ['-O -dno-typeable-binds -fno-worker-wrapper']) diff --git a/testsuite/tests/arityanal/should_run/T21694a.hs b/testsuite/tests/arityanal/should_run/T21694a.hs new file mode 100644 index 0000000000..ca01c1cb92 --- /dev/null +++ b/testsuite/tests/arityanal/should_run/T21694a.hs @@ -0,0 +1,27 @@ +module Main (main) where + +import GHC.Exts +import Control.DeepSeq +import System.Exit + +-- If we eta expand the `False` branch will return +-- a lambda \eta -> z instead of z. +-- This behaves differently if the z argument is a bottom. +-- We used to assume that a oneshot annotation would mean +-- we could eta-expand on *all* branches. But this is clearly +-- not sound in this case. So we test for this here. +{-# NOINLINE f #-} +f :: Bool -> (Int -> Int) -> Int -> Int +f b z = + case b of + True -> oneShot $ \n -> n + 1 + False -> z + + + +main :: IO Int +main = do + return $! force $! f False (error "Urkh! But expected!") + return 0 + + diff --git a/testsuite/tests/arityanal/should_run/T21694a.stderr b/testsuite/tests/arityanal/should_run/T21694a.stderr new file mode 100644 index 0000000000..8a0fd0cc91 --- /dev/null +++ b/testsuite/tests/arityanal/should_run/T21694a.stderr @@ -0,0 +1,3 @@ +T21694a: Urkh! But expected! +CallStack (from HasCallStack): + error, called at T21694a.hs:23:33 in main:Main diff --git a/testsuite/tests/arityanal/should_run/all.T b/testsuite/tests/arityanal/should_run/all.T index a6b06fbb15..c808036854 100644 --- a/testsuite/tests/arityanal/should_run/all.T +++ b/testsuite/tests/arityanal/should_run/all.T @@ -1,2 +1,6 @@ +# "Unit tests" + # Regression tests test('T21652', [ only_ways(['optasm']) ], compile_and_run, ['']) +test('T21694a', [ only_ways(['optasm']), exit_code(1) ], compile_and_run, ['-fpedantic-bottoms']) + diff --git a/testsuite/tests/simplCore/should_compile/T21694.hs b/testsuite/tests/simplCore/should_compile/T21694.hs new file mode 100644 index 0000000000..98c5a55c59 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T21694.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -Wall #-} +module Bug (go_fast_end) where + +import Control.Monad.ST (ST) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Data.ByteString (ByteString) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (plusPtr) +import GHC.Exts ( Int(..), Int#, Ptr(..), Word(..) + , (<#), (>#), indexWord64OffAddr#, isTrue#, orI# + ) +import GHC.Word (Word8(..), Word64(..)) +import System.IO.Unsafe (unsafeDupablePerformIO) + +#if MIN_VERSION_ghc_prim(0,8,0) +import GHC.Exts (word8ToWord#) +#endif + +#if __GLASGOW_HASKELL__ >= 904 +import GHC.Exts (byteSwap64#, int64ToInt#, word64ToInt64#, ltWord64#, wordToWord64#) +#else +import GHC.Exts (byteSwap#, ltWord#, word2Int#) +#endif + +go_fast_end :: ByteString -> DecodeAction s a -> ST s (SlowPath s a) +go_fast_end !bs (ConsumeInt32 k) = + case tryConsumeInt (BS.unsafeHead bs) bs of + DecodeFailure -> return $! SlowFail bs "expected int32" + DecodedToken sz (I# n#) -> + case (n# ># 0x7fffffff#) `orI#` (n# <# -0x80000000#) of + 0# -> k n# >>= go_fast_end (BS.unsafeDrop sz bs) + _ -> return $! SlowFail bs "expected int32" + +data SlowPath s a = SlowFail {-# UNPACK #-} !ByteString String + +data DecodeAction s a = ConsumeInt32 (Int# -> ST s (DecodeAction s a)) + +data DecodedToken a = DecodedToken !Int !a | DecodeFailure + +tryConsumeInt :: Word8 -> ByteString -> DecodedToken Int +tryConsumeInt hdr !bs = case word8ToWord hdr of + 0x17 -> DecodedToken 1 23 + 0x1b -> case word64ToInt (eatTailWord64 bs) of + Just n -> DecodedToken 9 n + Nothing -> DecodeFailure + _ -> DecodeFailure +{-# INLINE tryConsumeInt #-} + +eatTailWord64 :: ByteString -> Word64 +eatTailWord64 xs = withBsPtr grabWord64 (BS.unsafeTail xs) +{-# INLINE eatTailWord64 #-} + +word64ToInt :: Word64 -> Maybe Int +#if __GLASGOW_HASKELL__ >= 904 +word64ToInt (W64# w#) = + case isTrue# (w# `ltWord64#` wordToWord64# 0x80000000##) of + True -> Just (I# (int64ToInt# (word64ToInt64# w#))) + False -> Nothing +#else +word64ToInt (W64# w#) = + case isTrue# (w# `ltWord#` 0x8000000000000000##) of + True -> Just (I# (word2Int# w#)) + False -> Nothing +#endif +{-# INLINE word64ToInt #-} + +withBsPtr :: (Ptr b -> a) -> ByteString -> a +withBsPtr f (BS.PS x off _) = + unsafeDupablePerformIO $ withForeignPtr x $ + \(Ptr addr#) -> return $! (f (Ptr addr# `plusPtr` off)) +{-# INLINE withBsPtr #-} + +grabWord64 :: Ptr () -> Word64 +#if __GLASGOW_HASKELL__ >= 904 +grabWord64 (Ptr ip#) = W64# (byteSwap64# (indexWord64OffAddr# ip# 0#)) +#else +grabWord64 (Ptr ip#) = W64# (byteSwap# (indexWord64OffAddr# ip# 0#)) +#endif +{-# INLINE grabWord64 #-} + +word8ToWord :: Word8 -> Word +#if MIN_VERSION_ghc_prim(0,8,0) +word8ToWord (W8# w#) = W# (word8ToWord# w#) +#else +word8ToWord (W8# w#) = W# w# +#endif +{-# INLINE word8ToWord #-} diff --git a/testsuite/tests/simplCore/should_compile/T21694b.hs b/testsuite/tests/simplCore/should_compile/T21694b.hs new file mode 100644 index 0000000000..68f2bef2df --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T21694b.hs @@ -0,0 +1,6 @@ +module T21694 where + +-- f should get arity 4 +f x = let j 0 = \ a b c -> (a,x,b) + j n = j (n-1 :: Int) + in j 20 diff --git a/testsuite/tests/simplCore/should_compile/T21694b.stderr b/testsuite/tests/simplCore/should_compile/T21694b.stderr new file mode 100644 index 0000000000..2cd41cb17f --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T21694b.stderr @@ -0,0 +1,115 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 44, types: 40, coercions: 0, joins: 2/2} + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T21694.f1 :: Int +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T21694.f1 = GHC.Types.I# 20# + +-- RHS size: {terms: 26, types: 22, coercions: 0, joins: 2/2} +f :: forall {p1} {a} {c} {p2}. p1 -> a -> c -> p2 -> (a, p1, c) +[GblId, + Arity=4, + Str=<L><L><L><A>, + Cpr=1, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=4,unsat_ok=True,boring_ok=False) + Tmpl= \ (@p_ax8) + (@a_aL5) + (@c_aL6) + (@p1_aL7) + (x_agu [Occ=OnceL1] :: p_ax8) + (eta_B0 [Occ=OnceL1] :: a_aL5) + (eta1_B1 [Occ=OnceL1] :: c_aL6) + _ [Occ=Dead] -> + joinrec { + j_sLX [InlPrag=[2], Occ=T[1]] :: Int -> (a_aL5, p_ax8, c_aL6) + [LclId[JoinId(1)(Just [!])], + Arity=1, + Str=<S!P(SL)>, + Unf=Unf{Src=InlineStable, TopLvl=False, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) + Tmpl= \ (ds_sM1 [Occ=Once1!] :: Int) -> + case ds_sM1 of { GHC.Types.I# ww_sM3 [Occ=Once1] -> + jump $wj_sM6 ww_sM3 + }}] + j_sLX (ds_sM1 [Occ=Once1!] :: Int) + = case ds_sM1 of { GHC.Types.I# ww_sM3 [Occ=Once1] -> + jump $wj_sM6 ww_sM3 + }; + $wj_sM6 [InlPrag=[2], Occ=LoopBreakerT[1]] + :: GHC.Prim.Int# -> (a_aL5, p_ax8, c_aL6) + [LclId[JoinId(1)(Nothing)], Arity=1, Str=<SL>, Unf=OtherCon []] + $wj_sM6 (ww_sM3 [Occ=Once1!] :: GHC.Prim.Int#) + = case ww_sM3 of ds_X2 [Occ=Once1] { + __DEFAULT -> jump j_sLX (GHC.Types.I# (GHC.Prim.-# ds_X2 1#)); + 0# -> (eta_B0, x_agu, eta1_B1) + }; } in + jump j_sLX T21694.f1}] +f = \ (@p_ax8) + (@a_aL5) + (@c_aL6) + (@p1_aL7) + (x_agu :: p_ax8) + (eta_B0 :: a_aL5) + (eta1_B1 :: c_aL6) + _ [Occ=Dead] -> + join { + exit_X3 [Dmd=S!P(L,L,L)] :: (a_aL5, p_ax8, c_aL6) + [LclId[JoinId(0)(Nothing)]] + exit_X3 = (eta_B0, x_agu, eta1_B1) } in + joinrec { + $wj_sM6 [InlPrag=[2], Occ=LoopBreaker, Dmd=SCS(!P(L,L,L))] + :: GHC.Prim.Int# -> (a_aL5, p_ax8, c_aL6) + [LclId[JoinId(1)(Nothing)], Arity=1, Str=<1L>, Unf=OtherCon []] + $wj_sM6 (ww_sM3 :: GHC.Prim.Int#) + = case ww_sM3 of ds_X2 { + __DEFAULT -> jump $wj_sM6 (GHC.Prim.-# ds_X2 1#); + 0# -> jump exit_X3 + }; } in + jump $wj_sM6 20# + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T21694.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T21694.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T21694.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T21694.$trModule3 = GHC.Types.TrNameS T21694.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T21694.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T21694.$trModule2 = "T21694"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T21694.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T21694.$trModule1 = GHC.Types.TrNameS T21694.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T21694.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T21694.$trModule + = GHC.Types.Module T21694.$trModule3 T21694.$trModule1 + + + diff --git a/testsuite/tests/simplCore/should_compile/T21948.hs b/testsuite/tests/simplCore/should_compile/T21948.hs new file mode 100644 index 0000000000..5354bd0020 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T21948.hs @@ -0,0 +1,10 @@ +module T21948 where + +import GHC.Int( Int64 ) + +nf' :: (b -> ()) -> (a -> b) -> a -> (Int64 -> IO ()) +nf' reduce f x = go + where + go n | n <= 0 = return () + | otherwise = let !y = f x + in reduce y `seq` go (n-1) diff --git a/testsuite/tests/simplCore/should_compile/T21948.stderr b/testsuite/tests/simplCore/should_compile/T21948.stderr new file mode 100644 index 0000000000..4f68cc5884 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T21948.stderr @@ -0,0 +1,181 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 59, types: 65, coercions: 25, joins: 1/3} + +-- RHS size: {terms: 42, types: 34, coercions: 0, joins: 1/3} +T21948.nf'1 + :: forall {b} {a}. + (b -> ()) + -> (a -> b) + -> a + -> Int64 + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #) +[GblId, + Arity=5, + Str=<MC1(A)><MC1(L)><L><1!P(L)><L>, + Cpr=1(, 1), + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=5,unsat_ok=True,boring_ok=False) + Tmpl= \ (@b_aY7) + (@a_aY8) + (reduce_aBy [Occ=OnceL1!] :: b_aY7 -> ()) + (f_aBz [Occ=Once1!] :: a_aY8 -> b_aY7) + (x_aBA [Occ=Once1] :: a_aY8) + (eta_B0 [Occ=Once1] :: Int64) + (eta1_B1 [Occ=Once1, OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) -> + let { + lvl_s111 [Occ=OnceL1] :: b_aY7 + [LclId] + lvl_s111 = f_aBz x_aBA } in + joinrec { + go_s10Z [InlPrag=[2], Occ=T[2]] + :: Int64 + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #) + [LclId[JoinId(2)(Just [!])], + Arity=2, + Str=<S!P(L)><L>, + Unf=Unf{Src=InlineStable, TopLvl=False, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) + Tmpl= \ (n_s11c [Occ=Once1!] :: Int64) + (eta2_s11g [Occ=Once1, OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case n_s11c of { GHC.Int.I64# ww_s11e [Occ=Once1] -> + jump $wgo_s11i ww_s11e eta2_s11g + }}] + go_s10Z (n_s11c [Occ=Once1!] :: Int64) + (eta2_s11g [Occ=Once1, OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) + = case n_s11c of { GHC.Int.I64# ww_s11e [Occ=Once1] -> + jump $wgo_s11i ww_s11e eta2_s11g + }; + $wgo_s11i [InlPrag=[2], Occ=LoopBreakerT[2]] + :: GHC.Prim.Int64# + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #) + [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>, Unf=OtherCon []] + $wgo_s11i (ww_s11e :: GHC.Prim.Int64#) + (eta2_s11g [Occ=Once2, OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) + = case GHC.Prim.leInt64# ww_s11e 0#64 of { + __DEFAULT -> + case lvl_s111 of y_aNQ [Occ=Once1] { __DEFAULT -> + case reduce_aBy y_aNQ of { () -> + jump go_s10Z + (GHC.Int.I64# (GHC.Prim.subInt64# ww_s11e 1#64)) eta2_s11g + } + }; + 1# -> (# eta2_s11g, GHC.Tuple.() #) + }; } in + jump go_s10Z eta_B0 eta1_B1}] +T21948.nf'1 + = \ (@b_aY7) + (@a_aY8) + (reduce_aBy :: b_aY7 -> ()) + (f_aBz [OS=OneShot] :: a_aY8 -> b_aY7) + (x_aBA [OS=OneShot] :: a_aY8) + (eta_B0 [OS=OneShot] :: Int64) + (eta1_B1 [OS=OneShot] :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case eta_B0 of { GHC.Int.I64# ww_s11e -> + let { + lvl_s111 :: b_aY7 + [LclId] + lvl_s111 = f_aBz x_aBA } in + let { + lvl1_s11A [Dmd=LA] :: () + [LclId] + lvl1_s11A = reduce_aBy lvl_s111 } in + joinrec { + $wgo_s11i [InlPrag=[2], Occ=LoopBreaker, Dmd=SCS(C1(!P(L,L)))] + :: GHC.Prim.Int64# + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #) + [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>, Unf=OtherCon []] + $wgo_s11i (ww1_X3 :: GHC.Prim.Int64#) + (eta2_s11g [OS=OneShot] :: GHC.Prim.State# GHC.Prim.RealWorld) + = case GHC.Prim.leInt64# ww1_X3 0#64 of { + __DEFAULT -> + case lvl_s111 of { __DEFAULT -> + case lvl1_s11A of { () -> + jump $wgo_s11i (GHC.Prim.subInt64# ww1_X3 1#64) eta2_s11g + } + }; + 1# -> (# eta2_s11g, GHC.Tuple.() #) + }; } in + jump $wgo_s11i ww_s11e eta1_B1 + } + +-- RHS size: {terms: 1, types: 0, coercions: 25, joins: 0/0} +nf' :: forall b a. (b -> ()) -> (a -> b) -> a -> Int64 -> IO () +[GblId, + Arity=5, + Str=<MC1(A)><MC1(L)><L><1!P(L)><L>, + Cpr=1(, 1), + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] +nf' + = T21948.nf'1 + `cast` (forall (b :: <*>_N) (a :: <*>_N). + <(b |> <*>_N) -> ()>_R + %<'Many>_N ->_R <(a |> <*>_N) -> (b |> <*>_N)>_R + %<'Many>_N ->_R <(a |> <*>_N)>_R + %<'Many>_N ->_R <Int64>_R + %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] <()>_R) + :: (forall {b} {a}. + ((b |> <*>_N) -> ()) + -> ((a |> <*>_N) -> (b |> <*>_N)) + -> (a |> <*>_N) + -> Int64 + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)) + ~R# (forall {b} {a}. + ((b |> <*>_N) -> ()) + -> ((a |> <*>_N) -> (b |> <*>_N)) + -> (a |> <*>_N) + -> Int64 + -> IO ())) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T21948.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T21948.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T21948.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T21948.$trModule3 = GHC.Types.TrNameS T21948.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T21948.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T21948.$trModule2 = "T21948"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T21948.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T21948.$trModule1 = GHC.Types.TrNameS T21948.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T21948.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T21948.$trModule + = GHC.Types.Module T21948.$trModule3 T21948.$trModule1 + + + diff --git a/testsuite/tests/simplCore/should_compile/T21960.hs b/testsuite/tests/simplCore/should_compile/T21960.hs new file mode 100644 index 0000000000..d014a968e9 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T21960.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, MagicHash, + UnliftedFFITypes #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Text.Encoding +-- Copyright : (c) 2009, 2010, 2011 Bryan O'Sullivan, +-- (c) 2009 Duncan Coutts, +-- (c) 2008, 2009 Tom Harper +-- (c) 2021 Andrew Lelechenko +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Portability : portable +-- +-- Functions for converting 'Text' values to and from 'ByteString', +-- using several standard encodings. +-- +-- To gain access to a much larger family of encodings, use the +-- <http://hackage.haskell.org/package/text-icu text-icu package>. + +module Data.Text.Encoding + ( + encodeUtf8BuilderEscaped + ) where + +import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) + +import Control.Exception (evaluate, try) +import Control.Monad.ST (runST, ST) +import Data.Bits (shiftR, (.&.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Short.Internal as SBS +import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode, lenientDecode) +import Data.Text.Internal (Text(..), safe, empty, append) +import Data.Text.Internal.Unsafe (unsafeWithForeignPtr) +import Data.Text.Internal.Unsafe.Char (unsafeWrite) +import Data.Text.Unsafe (unsafeDupablePerformIO) +import Data.Word (Word8) +import Foreign.C.Types (CSize(..)) +import Foreign.Ptr (Ptr, minusPtr, plusPtr) +import Foreign.Storable (poke, peekByteOff) +import GHC.Exts (byteArrayContents#, unsafeCoerce#) +import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(PlainPtr)) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Internal as B hiding (empty, append) +import qualified Data.ByteString.Builder.Prim as BP +import qualified Data.ByteString.Builder.Prim.Internal as BP +import Data.Text.Internal.Encoding.Utf8 (utf8DecodeStart, utf8DecodeContinue, DecoderResult(..)) +import qualified Data.Text.Array as A +import qualified Data.Text.Internal.Encoding.Fusion as E +import qualified Data.Text.Internal.Fusion as F +import Data.Text.Internal.ByteStringCompat + + + +-- | Encode text using UTF-8 encoding and escape the ASCII characters using +-- a 'BP.BoundedPrim'. +-- +-- Use this function is to implement efficient encoders for text-based formats +-- like JSON or HTML. +-- +-- @since 1.1.0.0 +{-# INLINE encodeUtf8BuilderEscaped #-} +-- TODO: Extend documentation with references to source code in @blaze-html@ +-- or @aeson@ that uses this function. +encodeUtf8BuilderEscaped :: BP.BoundedPrim Word8 -> Text -> B.Builder +encodeUtf8BuilderEscaped be = + -- manual eta-expansion to ensure inlining works as expected + \txt -> B.builder (mkBuildstep txt) + where + bound = max 4 $ BP.sizeBound be + + mkBuildstep (Text arr off len) !k = + outerLoop off + where + iend = off + len + + outerLoop !i0 !br@(B.BufferRange op0 ope) + | i0 >= iend = k br + | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining) + -- TODO: Use a loop with an integrated bound's check if outRemaining + -- is smaller than 8, as this will save on divisions. + | otherwise = return $ B.bufferFull bound op0 (outerLoop i0) + where + outRemaining = (ope `minusPtr` op0) `quot` bound + inpRemaining = iend - i0 + + goPartial !iendTmp = go i0 op0 + where + go !i !op + | i < iendTmp = do + let w = A.unsafeIndex arr i + if w < 0x80 + then BP.runB be w op >>= go (i + 1) + else poke op w >> go (i + 1) (op `plusPtr` 1) + | otherwise = outerLoop i (B.BufferRange op ope) + diff --git a/testsuite/tests/simplCore/should_compile/T21960.stderr b/testsuite/tests/simplCore/should_compile/T21960.stderr new file mode 100644 index 0000000000..aec9866e46 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T21960.stderr @@ -0,0 +1,2095 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 1,176, types: 773, coercions: 114, joins: 25/45} + +-- RHS size: {terms: 1,161, + types: 764, + coercions: 114, + joins: 25/45} +encodeUtf8BuilderEscaped [InlPrag=INLINE (sat-args=1)] + :: BP.BoundedPrim Word8 -> Text -> B.Builder +[GblId, + Arity=5, + Str=<M!P(L,LCS(C1(C1(!P(L,1L)))))><1!P(L,L,L)><1CL(C1(L))><1L><L>, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= (\ (be_a1kE :: BP.BoundedPrim Word8) + (eta_B0 [Occ=Once1!] :: Text) + (@r_a238) + (eta1_B1 [Occ=Once1] :: B.BuildStep r_a238) + (eta2_B2 [Occ=Once1] :: B.BufferRange) + (eta3_B3 [Occ=Once1, OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) -> + let { + bound_a1kF :: Int + [LclId] + bound_a1kF + = case be_a1kE of + { Data.ByteString.Builder.Prim.Internal.BP bx_a27M _ [Occ=Dead] -> + case GHC.Prim.<=# 4# bx_a27M of { + __DEFAULT -> GHC.Types.I# 4#; + 1# -> GHC.Types.I# bx_a27M + } + } } in + case eta_B0 of + { Text bx_d22M [Occ=OnceL1] bx1_d22N bx2_d22O [Occ=Once1] -> + case eta1_B1 of k_X2 [Occ=OnceL1!] { __DEFAULT -> + let { + iend_s26Z :: GHC.Prim.Int# + [LclId] + iend_s26Z = GHC.Prim.+# bx1_d22N bx2_d22O } in + let { + iend1_a1wD [Occ=OnceL1] :: Int + [LclId, Unf=OtherCon []] + iend1_a1wD = GHC.Types.I# iend_s26Z } in + letrec { + outerLoop_a1TC [Occ=LoopBreaker] + :: Int -> B.BufferRange -> IO (B.BuildSignal r_a238) + [LclId, Arity=3, Unf=OtherCon []] + outerLoop_a1TC + = \ (i0_a1z3 [Occ=Once1!] :: Int) + (br_a1z4 [Occ=Once1!] :: B.BufferRange) -> + case i0_a1z3 of i1_X3 { GHC.Types.I# ipv_s270 -> + case br_a1z4 of wild1_X4 [Occ=Once1] + { B.BufferRange bx3_d22P bx4_d22Q -> + let { + ope_a1z6 [Occ=OnceL1] :: Ptr Word8 + [LclId, Unf=OtherCon []] + ope_a1z6 = GHC.Ptr.Ptr @Word8 bx4_d22Q } in + let { + outRemaining_a1z7 :: Int + [LclId] + outRemaining_a1z7 + = let { + a_s272 :: GHC.Prim.Int# + [LclId] + a_s272 = GHC.Prim.minusAddr# bx4_d22Q bx3_d22P } in + case GHC.Classes.eqInt bound_a1kF (GHC.Types.I# 0#) of { + False -> + join { + $j_a23n [Occ=Once2T[0]] :: Int + [LclId[JoinId(0)(Nothing)]] + $j_a23n + = case bound_a1kF of { GHC.Types.I# y_a23P [Occ=Once1] -> + case GHC.Prim.quotInt# a_s272 y_a23P + of ds2_a23R [Occ=Once1] + { __DEFAULT -> + GHC.Types.I# ds2_a23R + } + } } in + case GHC.Classes.eqInt bound_a1kF (GHC.Types.I# -1#) of { + False -> jump $j_a23n; + True -> + case GHC.Classes.eqInt (GHC.Types.I# a_s272) GHC.Base.minInt + of { + False -> jump $j_a23n; + True -> GHC.Real.overflowError @Int + } + }; + True -> GHC.Real.divZeroError @Int + } } in + case GHC.Classes.geInt i1_X3 iend1_a1wD of { + False -> + case GHC.Classes.gtInt outRemaining_a1z7 (GHC.Types.I# 0#) of { + False -> + (\ (s_a244 [Occ=Once1] :: GHC.Prim.State# GHC.Prim.RealWorld) -> + (# s_a244, + Data.ByteString.Builder.Internal.$WBufferFull + @r_a238 + bound_a1kF + (GHC.Ptr.Ptr @Word8 bx3_d22P) + (outerLoop_a1TC i1_X3) #)) + `cast` (Sym (GHC.Types.N:IO[0] <B.BuildSignal r_a238>_R) + :: (GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #)) + ~R# IO (B.BuildSignal r_a238)); + True -> + case outRemaining_a1z7 of { GHC.Types.I# x1_a24o -> + let { + y1_a24r :: GHC.Prim.Int# + [LclId] + y1_a24r = GHC.Prim.-# iend_s26Z ipv_s270 } in + join { + $j_s27Q [Occ=Once2!T[1]] + :: GHC.Prim.Int# -> IO (B.BuildSignal r_a238) + [LclId[JoinId(1)(Nothing)], Arity=1, Unf=OtherCon []] + $j_s27Q (y_a23f [Occ=Once1, OS=OneShot] :: GHC.Prim.Int#) + = let { + iendTmp_s273 [Occ=OnceL1] :: GHC.Prim.Int# + [LclId] + iendTmp_s273 = GHC.Prim.+# ipv_s270 y_a23f } in + let { + iendTmp1_X7 [Occ=OnceL1] :: Int + [LclId, Unf=OtherCon []] + iendTmp1_X7 = GHC.Types.I# iendTmp_s273 } in + letrec { + go_a1U2 [Occ=LoopBreaker] + :: Int -> Ptr Word8 -> IO (B.BuildSignal r_a238) + [LclId, Arity=3, Unf=OtherCon []] + go_a1U2 + = \ (i_a1ED [Occ=Once1!] :: Int) + (op_a1EE [Occ=Once1!] :: Ptr Word8) -> + case i_a1ED of i2_X9 { GHC.Types.I# ipv1_s274 -> + case op_a1EE of op1_Xa [Occ=Once2] + { GHC.Ptr.Ptr ipv2_s276 -> + case GHC.Classes.ltInt i2_X9 iendTmp1_X7 of { + False -> + outerLoop_a1TC + i2_X9 + (Data.ByteString.Builder.Internal.$WBufferRange + op1_Xa ope_a1z6); + True -> + let { + w_a1EF :: Word8 + [LclId] + w_a1EF + = case GHC.Prim.indexWord8Array# + bx_d22M ipv1_s274 + of r#_a24P [Occ=Once1] + { __DEFAULT -> + GHC.Word.W8# r#_a24P + } } in + case GHC.Word.ltWord8 + w_a1EF (GHC.Word.W8# 128##8) + of { + False -> + (\ (s_a25B [Occ=Once1] + :: GHC.Prim.State# + GHC.Prim.RealWorld) -> + case w_a1EF of + { GHC.Word.W8# x_a26s [Occ=Once1] -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + ipv2_s276 + 0# + x_a26s + s_a25B + of s2_a26u [Occ=Once1] + { __DEFAULT -> + ((go_a1U2 + (GHC.Types.I# + (GHC.Prim.+# ipv1_s274 1#)) + (GHC.Ptr.Ptr + @Word8 + (GHC.Prim.plusAddr# + ipv2_s276 1#))) + `cast` (GHC.Types.N:IO[0] + <B.BuildSignal r_a238>_R + :: IO (B.BuildSignal r_a238) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)))) + s2_a26u + } + }) + `cast` (Sym (GHC.Types.N:IO[0] + <B.BuildSignal r_a238>_R) + :: (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal r_a238 #)) + ~R# IO (B.BuildSignal r_a238)); + True -> + (\ (s_a26J [Occ=Once1] + :: GHC.Prim.State# + GHC.Prim.RealWorld) -> + case be_a1kE of + { Data.ByteString.Builder.Prim.Internal.BP _ [Occ=Dead] + io_a26V [Occ=Once1!] -> + case ((io_a26V w_a1EF op1_Xa) + `cast` (GHC.Types.N:IO[0] + <Ptr Word8>_R + :: IO (Ptr Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + s_a26J + of + { (# ipv3_a26L [Occ=Once1], + ipv4_a26M [Occ=Once1] #) -> + ((go_a1U2 + (GHC.Types.I# + (GHC.Prim.+# ipv1_s274 1#)) + ipv4_a26M) + `cast` (GHC.Types.N:IO[0] + <B.BuildSignal r_a238>_R + :: IO (B.BuildSignal r_a238) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)))) + ipv3_a26L + } + }) + `cast` (Sym (GHC.Types.N:IO[0] + <B.BuildSignal r_a238>_R) + :: (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal r_a238 #)) + ~R# IO (B.BuildSignal r_a238)) + } + } + } + }; } in + go_a1U2 i1_X3 (GHC.Ptr.Ptr @Word8 bx3_d22P) } in + case GHC.Prim.<=# x1_a24o y1_a24r of { + __DEFAULT -> jump $j_s27Q y1_a24r; + 1# -> jump $j_s27Q x1_a24o + } + } + }; + True -> k_X2 wild1_X4 + } + } + }; } in + ((outerLoop_a1TC (GHC.Types.I# bx1_d22N) eta2_B2) + `cast` (GHC.Types.N:IO[0] <B.BuildSignal r_a238>_R + :: IO (B.BuildSignal r_a238) + ~R# (GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #)))) + eta3_B3 + } + }) + `cast` (<BP.BoundedPrim Word8>_R + %<'Many>_N ->_R <Text>_R + %<'Many>_N ->_R forall (r :: <*>_N). + <B.BuildStep (r |> <*>_N)>_R + %<'Many>_N ->_R <B.BufferRange>_R + %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] + <B.BuildSignal (r |> <*>_N)>_R) + ; Sym (Data.ByteString.Builder.Internal.N:Builder[0]) + :: (BP.BoundedPrim Word8 + -> Text + -> forall {r}. + B.BuildStep (r |> <*>_N) + -> B.BufferRange + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal (r |> <*>_N) #)) + ~R# (BP.BoundedPrim Word8 -> Text -> B.Builder))}] +encodeUtf8BuilderEscaped + = (\ (be_a1kE :: BP.BoundedPrim Word8) + (eta_B0 :: Text) + (@r_a238) + (eta1_B1 :: B.BuildStep r_a238) + (eta2_B2 :: B.BufferRange) + (eta3_B3 [OS=OneShot] :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case eta_B0 of { Text bx_d22M bx1_d22N bx2_d22O -> + case eta1_B1 of k_X2 { __DEFAULT -> + let { + iend_s27f :: GHC.Prim.Int# + [LclId] + iend_s27f = GHC.Prim.+# bx1_d22N bx2_d22O } in + case eta2_B2 of wild1_X5 { B.BufferRange bx3_d22P bx4_d22Q -> + case GHC.Prim.>=# bx1_d22N iend_s27f of { + __DEFAULT -> + case be_a1kE of + { Data.ByteString.Builder.Prim.Internal.BP bx5_a27M ds1_a27N -> + join { + $j_s28Z [Dmd=1C1(L)] + :: GHC.Prim.Int# + -> (# GHC.Prim.State# GHC.Prim.RealWorld, B.BuildSignal r_a238 #) + [LclId[JoinId(1)(Nothing)], Arity=1, Str=<1L>, Unf=OtherCon []] + $j_s28Z (x_a27U [OS=OneShot] :: GHC.Prim.Int#) + = case x_a27U of wild3_X6 { + __DEFAULT -> + let { + a_s27n :: GHC.Prim.Int# + [LclId] + a_s27n = GHC.Prim.minusAddr# bx4_d22Q bx3_d22P } in + join { + $j1_s27p [Dmd=1!P(L,L)] + :: (# GHC.Prim.State# GHC.Prim.RealWorld, B.BuildSignal r_a238 #) + [LclId[JoinId(0)(Nothing)]] + $j1_s27p + = case GHC.Prim.quotInt# a_s27n wild3_X6 of ds2_a23R { __DEFAULT -> + case GHC.Prim.># ds2_a23R 0# of { + __DEFAULT -> + (# eta3_B3, + Data.ByteString.Builder.Internal.BufferFull + @r_a238 + wild3_X6 + bx3_d22P + ((\ (br_X7 :: B.BufferRange) + (eta4_X8 [OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) -> + letrec { + $s$wouterLoop_s29Y [Occ=LoopBreaker, + Dmd=LCS(C1(C1(C1(!P(L,L)))))] + :: GHC.Prim.Addr# + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId, Arity=4, Str=<L><L><L><L>, Unf=OtherCon []] + $s$wouterLoop_s29Y + = \ (sc_s29V :: GHC.Prim.Addr#) + (sc1_s29W :: GHC.Prim.Addr#) + (sc2_s29U :: GHC.Prim.Int#) + (eta5_s28W [OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case GHC.Prim.>=# sc2_s29U iend_s27f of { + __DEFAULT -> + let { + a1_Xe :: GHC.Prim.Int# + [LclId] + a1_Xe + = GHC.Prim.minusAddr# sc1_s29W sc_s29V } in + join { + $j2_Xf [Dmd=1!P(L,L)] + :: (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(0)(Nothing)]] + $j2_Xf + = case GHC.Prim.quotInt# a1_Xe wild3_X6 + of ds4_Xg + { __DEFAULT -> + case GHC.Prim.># ds4_Xg 0# of { + __DEFAULT -> + (# eta5_s28W, + Data.ByteString.Builder.Internal.BufferFull + @r_a238 + wild3_X6 + sc_s29V + ((\ (br1_Xi :: B.BufferRange) + (eta6_Xj [OS=OneShot] + :: GHC.Prim.State# + GHC.Prim.RealWorld) -> + $wouterLoop_s28Y + sc2_s29U br1_Xi eta6_Xj) + `cast` (<B.BufferRange>_R + %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] + <B.BuildSignal + r_a238>_R) + :: (B.BufferRange + -> GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)) + ~R# (B.BufferRange + -> IO + (B.BuildSignal + r_a238)))) #); + 1# -> + let { + y1_s27t :: GHC.Prim.Int# + [LclId] + y1_s27t + = GHC.Prim.-# + iend_s27f sc2_s29U } in + join { + $j3_s27P [Dmd=1C1(!P(L,L))] + :: GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(1)(Nothing)], + Arity=1, + Str=<L>, + Unf=OtherCon []] + $j3_s27P (y_a23f [OS=OneShot] + :: GHC.Prim.Int#) + = let { + iendTmp_s27v :: GHC.Prim.Int# + [LclId] + iendTmp_s27v + = GHC.Prim.+# + sc2_s29U y_a23f } in + joinrec { + $s$wgo_s2ai [Occ=LoopBreaker, + Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.State# + GHC.Prim.RealWorld + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<L><L><L>, + Unf=OtherCon []] + $s$wgo_s2ai (sc3_s2ah + :: GHC.Prim.State# + GHC.Prim.RealWorld) + (sc4_s2ag + :: GHC.Prim.Addr#) + (sc5_s2af + :: GHC.Prim.Int#) + = case GHC.Prim.<# + sc5_s2af + iendTmp_s27v + of { + __DEFAULT -> + $s$wouterLoop_s29Y + sc4_s2ag + sc1_s29W + sc5_s2af + sc3_s2ah; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + sc5_s2af + of r#_a24P + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#_a24P 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + sc4_s2ag + 0# + r#_a24P + sc3_s2ah + of s2_a26u + { __DEFAULT -> + jump $s$wgo_s2ai + s2_a26u + (GHC.Prim.plusAddr# + sc4_s2ag 1#) + (GHC.Prim.+# + sc5_s2af 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#_a24P) + (GHC.Ptr.Ptr + @Word8 + sc4_s2ag)) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + sc3_s2ah + of + { (# ipv_a26L, + ipv1_a26M #) -> + joinrec { + $wgo_Xk [InlPrag=[2], + Occ=LoopBreaker, + Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.Int# + -> Ptr + Word8 + -> GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Just [~, + !])], + Arity=3, + Str=<L><1L><L>, + Unf=OtherCon []] + $wgo_Xk (ww_Xl + :: GHC.Prim.Int#) + (op_Xm + :: Ptr + Word8) + (eta6_Xn [OS=OneShot] + :: GHC.Prim.State# + GHC.Prim.RealWorld) + = case op_Xm + of op1_Xo + { GHC.Ptr.Ptr ipv2_Xp -> + case GHC.Prim.<# + ww_Xl + iendTmp_s27v + of { + __DEFAULT -> + $s$wouterLoop_s29Y + ipv2_Xp + sc1_s29W + ww_Xl + eta6_Xn; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + ww_Xl + of r#1_Xr + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#1_Xr + 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + ipv2_Xp + 0# + r#1_Xr + eta6_Xn + of s2_a26u + { __DEFAULT -> + jump $wgo_Xk + (GHC.Prim.+# + ww_Xl + 1#) + (GHC.Ptr.Ptr + @Word8 + (GHC.Prim.plusAddr# + ipv2_Xp + 1#)) + s2_a26u + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#1_Xr) + op1_Xo) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + eta6_Xn + of + { (# ipv3_Xu, + ipv4_Xv #) -> + jump $wgo_Xk + (GHC.Prim.+# + ww_Xl + 1#) + ipv4_Xv + ipv3_Xu + } + } + } + } + }; } in + jump $wgo_Xk + (GHC.Prim.+# + sc5_s2af 1#) + ipv1_a26M + ipv_a26L + } + } + } + }; } in + jump $s$wgo_s2ai + eta5_s28W + sc_s29V + sc2_s29U } in + case GHC.Prim.<=# ds4_Xg y1_s27t of { + __DEFAULT -> jump $j3_s27P y1_s27t; + 1# -> jump $j3_s27P ds4_Xg + } + } + } } in + case wild3_X6 of { + __DEFAULT -> jump $j2_Xf; + -1# -> + case a1_Xe of { + __DEFAULT -> jump $j2_Xf; + -9223372036854775808# -> + case GHC.Real.overflowError + of wild6_00 { + } + } + }; + 1# -> + ((k_X2 + (Data.ByteString.Builder.Internal.BufferRange + sc_s29V sc1_s29W)) + `cast` (GHC.Types.N:IO[0] + <B.BuildSignal r_a238>_R + :: IO (B.BuildSignal r_a238) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)))) + eta5_s28W + }; + $wouterLoop_s28Y [InlPrag=[2], + Occ=LoopBreaker, + Dmd=SCS(C1(C1(L)))] + :: GHC.Prim.Int# + -> B.BufferRange + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[StrictWorker([~, !])], + Arity=3, + Str=<L><1L><L>, + Unf=OtherCon []] + $wouterLoop_s28Y + = \ (ww_s28T :: GHC.Prim.Int#) + (br1_s28V :: B.BufferRange) + (eta5_s28W [OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case br1_s28V of wild4_X9 + { B.BufferRange bx6_Xa bx7_Xb -> + case GHC.Prim.>=# ww_s28T iend_s27f of { + __DEFAULT -> + let { + a1_Xe :: GHC.Prim.Int# + [LclId] + a1_Xe = GHC.Prim.minusAddr# bx7_Xb bx6_Xa } in + join { + $j2_Xf [Dmd=1!P(L,L)] + :: (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(0)(Nothing)]] + $j2_Xf + = case GHC.Prim.quotInt# a1_Xe wild3_X6 + of ds4_Xg + { __DEFAULT -> + case GHC.Prim.># ds4_Xg 0# of { + __DEFAULT -> + (# eta5_s28W, + Data.ByteString.Builder.Internal.BufferFull + @r_a238 + wild3_X6 + bx6_Xa + ((\ (br2_Xi :: B.BufferRange) + (eta6_Xj [OS=OneShot] + :: GHC.Prim.State# + GHC.Prim.RealWorld) -> + $wouterLoop_s28Y + ww_s28T br2_Xi eta6_Xj) + `cast` (<B.BufferRange>_R + %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] + <B.BuildSignal + r_a238>_R) + :: (B.BufferRange + -> GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)) + ~R# (B.BufferRange + -> IO + (B.BuildSignal + r_a238)))) #); + 1# -> + let { + y1_s27t :: GHC.Prim.Int# + [LclId] + y1_s27t + = GHC.Prim.-# + iend_s27f ww_s28T } in + join { + $j3_s27P [Dmd=1C1(!P(L,L))] + :: GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(1)(Nothing)], + Arity=1, + Str=<L>, + Unf=OtherCon []] + $j3_s27P (y_a23f [OS=OneShot] + :: GHC.Prim.Int#) + = let { + iendTmp_s27v :: GHC.Prim.Int# + [LclId] + iendTmp_s27v + = GHC.Prim.+# + ww_s28T y_a23f } in + joinrec { + $s$wgo_s29j [Occ=LoopBreaker, + Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.State# + GHC.Prim.RealWorld + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<L><L><L>, + Unf=OtherCon []] + $s$wgo_s29j (sc_s29i + :: GHC.Prim.State# + GHC.Prim.RealWorld) + (sc1_s29h + :: GHC.Prim.Addr#) + (sc2_s29g + :: GHC.Prim.Int#) + = case GHC.Prim.<# + sc2_s29g + iendTmp_s27v + of { + __DEFAULT -> + $s$wouterLoop_s29Y + sc1_s29h + bx7_Xb + sc2_s29g + sc_s29i; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + sc2_s29g + of r#_a24P + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#_a24P 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + sc1_s29h + 0# + r#_a24P + sc_s29i + of s2_a26u + { __DEFAULT -> + jump $s$wgo_s29j + s2_a26u + (GHC.Prim.plusAddr# + sc1_s29h 1#) + (GHC.Prim.+# + sc2_s29g 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#_a24P) + (GHC.Ptr.Ptr + @Word8 + sc1_s29h)) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + sc_s29i + of + { (# ipv_a26L, + ipv1_a26M #) -> + joinrec { + $s$wgo1_s29t [Occ=LoopBreaker, + Dmd=LCS(C1(C1(!P(L,L))))] + :: GHC.Prim.State# + GHC.Prim.RealWorld + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<L><L><L>, + Unf=OtherCon []] + $s$wgo1_s29t (sc3_s29p + :: GHC.Prim.State# + GHC.Prim.RealWorld) + (sc4_s29o + :: GHC.Prim.Addr#) + (sc5_s29n + :: GHC.Prim.Int#) + = case GHC.Prim.<# + sc5_s29n + iendTmp_s27v + of { + __DEFAULT -> + $s$wouterLoop_s29Y + sc4_s29o + bx7_Xb + sc5_s29n + sc3_s29p; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + sc5_s29n + of r#1_Xr + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#1_Xr + 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + sc4_s29o + 0# + r#1_Xr + sc3_s29p + of s2_a26u + { __DEFAULT -> + jump $s$wgo1_s29t + s2_a26u + (GHC.Prim.plusAddr# + sc4_s29o + 1#) + (GHC.Prim.+# + sc5_s29n + 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#1_Xr) + (GHC.Ptr.Ptr + @Word8 + sc4_s29o)) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + sc3_s29p + of + { (# ipv2_Xu, + ipv3_Xv #) -> + jump $wgo_Xk + (GHC.Prim.+# + sc5_s29n + 1#) + ipv3_Xv + ipv2_Xu + } + } + } + }; + $wgo_Xk [InlPrag=[2], + Occ=LoopBreaker, + Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.Int# + -> Ptr + Word8 + -> GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Just [~, + !])], + Arity=3, + Str=<L><1L><L>, + Unf=OtherCon []] + $wgo_Xk (ww1_Xl + :: GHC.Prim.Int#) + (op_Xm + :: Ptr + Word8) + (eta6_Xn [OS=OneShot] + :: GHC.Prim.State# + GHC.Prim.RealWorld) + = case op_Xm + of op1_Xo + { GHC.Ptr.Ptr ipv2_Xp -> + case GHC.Prim.<# + ww1_Xl + iendTmp_s27v + of { + __DEFAULT -> + $s$wouterLoop_s29Y + ipv2_Xp + bx7_Xb + ww1_Xl + eta6_Xn; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + ww1_Xl + of r#1_Xr + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#1_Xr + 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + ipv2_Xp + 0# + r#1_Xr + eta6_Xn + of s2_a26u + { __DEFAULT -> + jump $s$wgo1_s29t + s2_a26u + (GHC.Prim.plusAddr# + ipv2_Xp + 1#) + (GHC.Prim.+# + ww1_Xl + 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#1_Xr) + op1_Xo) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + eta6_Xn + of + { (# ipv3_Xu, + ipv4_Xv #) -> + jump $wgo_Xk + (GHC.Prim.+# + ww1_Xl + 1#) + ipv4_Xv + ipv3_Xu + } + } + } + } + }; } in + jump $wgo_Xk + (GHC.Prim.+# + sc2_s29g 1#) + ipv1_a26M + ipv_a26L + } + } + } + }; } in + jump $s$wgo_s29j + eta5_s28W bx6_Xa ww_s28T } in + case GHC.Prim.<=# ds4_Xg y1_s27t of { + __DEFAULT -> jump $j3_s27P y1_s27t; + 1# -> jump $j3_s27P ds4_Xg + } + } + } } in + case wild3_X6 of { + __DEFAULT -> jump $j2_Xf; + -1# -> + case a1_Xe of { + __DEFAULT -> jump $j2_Xf; + -9223372036854775808# -> + case GHC.Real.overflowError + of wild7_00 { + } + } + }; + 1# -> + ((k_X2 wild4_X9) + `cast` (GHC.Types.N:IO[0] + <B.BuildSignal r_a238>_R + :: IO (B.BuildSignal r_a238) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)))) + eta5_s28W + } + }; } in + $wouterLoop_s28Y bx1_d22N br_X7 eta4_X8) + `cast` (<B.BufferRange>_R + %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] + <B.BuildSignal r_a238>_R) + :: (B.BufferRange + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #)) + ~R# (B.BufferRange + -> IO (B.BuildSignal r_a238)))) #); + 1# -> + let { + y1_s27t :: GHC.Prim.Int# + [LclId] + y1_s27t = GHC.Prim.-# iend_s27f bx1_d22N } in + join { + $j2_s27P [Dmd=1C1(!P(L,L))] + :: GHC.Prim.Int# + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []] + $j2_s27P (y_a23f [OS=OneShot] :: GHC.Prim.Int#) + = let { + iendTmp_s27v :: GHC.Prim.Int# + [LclId] + iendTmp_s27v = GHC.Prim.+# bx1_d22N y_a23f } in + join { + exit_Xc [Dmd=LCS(C1(C1(!P(L,L))))] + :: GHC.Prim.Int# + -> GHC.Prim.State# GHC.Prim.RealWorld + -> GHC.Prim.Addr# + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<L><L><L>, + Unf=OtherCon []] + exit_Xc (ww_s28F [OS=OneShot] :: GHC.Prim.Int#) + (eta4_s28I [OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) + (ipv_s24F [OS=OneShot] :: GHC.Prim.Addr#) + = letrec { + $s$wouterLoop_s2bC [Occ=LoopBreaker, + Dmd=SCS(C1(C1(C1(!P(L,L)))))] + :: GHC.Prim.Addr# + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId, Arity=4, Str=<L><L><L><L>, Unf=OtherCon []] + $s$wouterLoop_s2bC + = \ (sc_s2bz :: GHC.Prim.Addr#) + (sc1_s2bA :: GHC.Prim.Addr#) + (sc2_s2by :: GHC.Prim.Int#) + (eta5_s28W [OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case GHC.Prim.>=# sc2_s2by iend_s27f of { + __DEFAULT -> + let { + a1_Xi :: GHC.Prim.Int# + [LclId] + a1_Xi + = GHC.Prim.minusAddr# + sc1_s2bA sc_s2bz } in + join { + $j3_Xj [Dmd=1!P(L,L)] + :: (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(0)(Nothing)]] + $j3_Xj + = case GHC.Prim.quotInt# a1_Xi wild3_X6 + of ds4_Xk + { __DEFAULT -> + case GHC.Prim.># ds4_Xk 0# of { + __DEFAULT -> + (# eta5_s28W, + Data.ByteString.Builder.Internal.BufferFull + @r_a238 + wild3_X6 + sc_s2bz + ((\ (br_X7 :: B.BufferRange) + (eta6_X8 [OS=OneShot] + :: GHC.Prim.State# + GHC.Prim.RealWorld) -> + $wouterLoop_s28Y + sc2_s2by br_X7 eta6_X8) + `cast` (<B.BufferRange>_R + %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] + <B.BuildSignal + r_a238>_R) + :: (B.BufferRange + -> GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)) + ~R# (B.BufferRange + -> IO + (B.BuildSignal + r_a238)))) #); + 1# -> + let { + y2_Xm :: GHC.Prim.Int# + [LclId] + y2_Xm + = GHC.Prim.-# + iend_s27f sc2_s2by } in + join { + $j4_Xn [Dmd=1C1(!P(L,L))] + :: GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(1)(Nothing)], + Arity=1, + Str=<L>, + Unf=OtherCon []] + $j4_Xn (y3_Xo [OS=OneShot] + :: GHC.Prim.Int#) + = let { + iendTmp1_Xp + :: GHC.Prim.Int# + [LclId] + iendTmp1_Xp + = GHC.Prim.+# + sc2_s2by y3_Xo } in + joinrec { + $s$wgo_s2bW [Occ=LoopBreaker, + Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.State# + GHC.Prim.RealWorld + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<L><L><L>, + Unf=OtherCon []] + $s$wgo_s2bW (sc3_s2bV + :: GHC.Prim.State# + GHC.Prim.RealWorld) + (sc4_s2bU + :: GHC.Prim.Addr#) + (sc5_s2bT + :: GHC.Prim.Int#) + = case GHC.Prim.<# + sc5_s2bT + iendTmp1_Xp + of { + __DEFAULT -> + $s$wouterLoop_s2bC + sc4_s2bU + sc1_s2bA + sc5_s2bT + sc3_s2bV; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + sc5_s2bT + of r#_a24P + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#_a24P + 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + sc4_s2bU + 0# + r#_a24P + sc3_s2bV + of s2_a26u + { __DEFAULT -> + jump $s$wgo_s2bW + s2_a26u + (GHC.Prim.plusAddr# + sc4_s2bU + 1#) + (GHC.Prim.+# + sc5_s2bT + 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#_a24P) + (GHC.Ptr.Ptr + @Word8 + sc4_s2bU)) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + sc3_s2bV + of + { (# ipv1_a26L, + ipv2_a26M #) -> + joinrec { + $wgo_Xu [InlPrag=[2], + Occ=LoopBreaker, + Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.Int# + -> Ptr + Word8 + -> GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Just [~, + !])], + Arity=3, + Str=<L><1L><L>, + Unf=OtherCon []] + $wgo_Xu (ww1_Xv + :: GHC.Prim.Int#) + (op_Xw + :: Ptr + Word8) + (eta6_Xx [OS=OneShot] + :: GHC.Prim.State# + GHC.Prim.RealWorld) + = case op_Xw + of op1_Xy + { GHC.Ptr.Ptr ipv3_Xz -> + case GHC.Prim.<# + ww1_Xv + iendTmp1_Xp + of { + __DEFAULT -> + $s$wouterLoop_s2bC + ipv3_Xz + sc1_s2bA + ww1_Xv + eta6_Xx; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + ww1_Xv + of r#1_XB + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#1_XB + 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + ipv3_Xz + 0# + r#1_XB + eta6_Xx + of s2_a26u + { __DEFAULT -> + jump $wgo_Xu + (GHC.Prim.+# + ww1_Xv + 1#) + (GHC.Ptr.Ptr + @Word8 + (GHC.Prim.plusAddr# + ipv3_Xz + 1#)) + s2_a26u + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#1_XB) + op1_Xy) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + eta6_Xx + of + { (# ipv4_XE, + ipv5_XF #) -> + jump $wgo_Xu + (GHC.Prim.+# + ww1_Xv + 1#) + ipv5_XF + ipv4_XE + } + } + } + } + }; } in + jump $wgo_Xu + (GHC.Prim.+# + sc5_s2bT + 1#) + ipv2_a26M + ipv1_a26L + } + } + } + }; } in + jump $s$wgo_s2bW + eta5_s28W + sc_s2bz + sc2_s2by } in + case GHC.Prim.<=# ds4_Xk y2_Xm of { + __DEFAULT -> jump $j4_Xn y2_Xm; + 1# -> jump $j4_Xn ds4_Xk + } + } + } } in + case wild3_X6 of { + __DEFAULT -> jump $j3_Xj; + -1# -> + case a1_Xi of { + __DEFAULT -> jump $j3_Xj; + -9223372036854775808# -> + case GHC.Real.overflowError + of wild6_00 { + } + } + }; + 1# -> + ((k_X2 + (Data.ByteString.Builder.Internal.BufferRange + sc_s2bz sc1_s2bA)) + `cast` (GHC.Types.N:IO[0] + <B.BuildSignal r_a238>_R + :: IO (B.BuildSignal r_a238) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)))) + eta5_s28W + }; + $wouterLoop_s28Y [InlPrag=[2], + Occ=LoopBreaker, + Dmd=LCS(C1(C1(L)))] + :: GHC.Prim.Int# + -> B.BufferRange + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[StrictWorker([~, !])], + Arity=3, + Str=<L><1L><L>, + Unf=OtherCon []] + $wouterLoop_s28Y + = \ (ww1_s28T :: GHC.Prim.Int#) + (br_s28V :: B.BufferRange) + (eta5_s28W [OS=OneShot] + :: GHC.Prim.State# GHC.Prim.RealWorld) -> + case br_s28V of wild4_Xd + { B.BufferRange bx6_Xe bx7_Xf -> + case GHC.Prim.>=# ww1_s28T iend_s27f of { + __DEFAULT -> + let { + a1_Xi :: GHC.Prim.Int# + [LclId] + a1_Xi + = GHC.Prim.minusAddr# bx7_Xf bx6_Xe } in + join { + $j3_Xj [Dmd=1!P(L,L)] + :: (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(0)(Nothing)]] + $j3_Xj + = case GHC.Prim.quotInt# a1_Xi wild3_X6 + of ds4_Xk + { __DEFAULT -> + case GHC.Prim.># ds4_Xk 0# of { + __DEFAULT -> + (# eta5_s28W, + Data.ByteString.Builder.Internal.BufferFull + @r_a238 + wild3_X6 + bx6_Xe + ((\ (br1_X7 :: B.BufferRange) + (eta6_X8 [OS=OneShot] + :: GHC.Prim.State# + GHC.Prim.RealWorld) -> + $wouterLoop_s28Y + ww1_s28T br1_X7 eta6_X8) + `cast` (<B.BufferRange>_R + %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] + <B.BuildSignal + r_a238>_R) + :: (B.BufferRange + -> GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)) + ~R# (B.BufferRange + -> IO + (B.BuildSignal + r_a238)))) #); + 1# -> + let { + y2_Xm :: GHC.Prim.Int# + [LclId] + y2_Xm + = GHC.Prim.-# + iend_s27f ww1_s28T } in + join { + $j4_Xn [Dmd=1C1(!P(L,L))] + :: GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(1)(Nothing)], + Arity=1, + Str=<L>, + Unf=OtherCon []] + $j4_Xn (y3_Xo [OS=OneShot] + :: GHC.Prim.Int#) + = let { + iendTmp1_Xp + :: GHC.Prim.Int# + [LclId] + iendTmp1_Xp + = GHC.Prim.+# + ww1_s28T y3_Xo } in + joinrec { + $s$wgo_s2b3 [Occ=LoopBreaker, + Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.State# + GHC.Prim.RealWorld + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<L><L><L>, + Unf=OtherCon []] + $s$wgo_s2b3 (sc_s2b2 + :: GHC.Prim.State# + GHC.Prim.RealWorld) + (sc1_s2b1 + :: GHC.Prim.Addr#) + (sc2_s2b0 + :: GHC.Prim.Int#) + = case GHC.Prim.<# + sc2_s2b0 + iendTmp1_Xp + of { + __DEFAULT -> + $s$wouterLoop_s2bC + sc1_s2b1 + bx7_Xf + sc2_s2b0 + sc_s2b2; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + sc2_s2b0 + of r#_a24P + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#_a24P + 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + sc1_s2b1 + 0# + r#_a24P + sc_s2b2 + of s2_a26u + { __DEFAULT -> + jump $s$wgo_s2b3 + s2_a26u + (GHC.Prim.plusAddr# + sc1_s2b1 + 1#) + (GHC.Prim.+# + sc2_s2b0 + 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#_a24P) + (GHC.Ptr.Ptr + @Word8 + sc1_s2b1)) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + sc_s2b2 + of + { (# ipv1_a26L, + ipv2_a26M #) -> + joinrec { + $s$wgo1_s2bd [Occ=LoopBreaker, + Dmd=LCS(C1(C1(!P(L,L))))] + :: GHC.Prim.State# + GHC.Prim.RealWorld + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<L><L><L>, + Unf=OtherCon []] + $s$wgo1_s2bd (sc3_s2b9 + :: GHC.Prim.State# + GHC.Prim.RealWorld) + (sc4_s2b8 + :: GHC.Prim.Addr#) + (sc5_s2b7 + :: GHC.Prim.Int#) + = case GHC.Prim.<# + sc5_s2b7 + iendTmp1_Xp + of { + __DEFAULT -> + $s$wouterLoop_s2bC + sc4_s2b8 + bx7_Xf + sc5_s2b7 + sc3_s2b9; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + sc5_s2b7 + of r#1_XB + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#1_XB + 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + sc4_s2b8 + 0# + r#1_XB + sc3_s2b9 + of s2_a26u + { __DEFAULT -> + jump $s$wgo1_s2bd + s2_a26u + (GHC.Prim.plusAddr# + sc4_s2b8 + 1#) + (GHC.Prim.+# + sc5_s2b7 + 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#1_XB) + (GHC.Ptr.Ptr + @Word8 + sc4_s2b8)) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + sc3_s2b9 + of + { (# ipv3_XE, + ipv4_XF #) -> + jump $wgo_Xu + (GHC.Prim.+# + sc5_s2b7 + 1#) + ipv4_XF + ipv3_XE + } + } + } + }; + $wgo_Xu [InlPrag=[2], + Occ=LoopBreaker, + Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.Int# + -> Ptr + Word8 + -> GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #) + [LclId[JoinId(3)(Just [~, + !])], + Arity=3, + Str=<L><1L><L>, + Unf=OtherCon []] + $wgo_Xu (ww2_Xv + :: GHC.Prim.Int#) + (op_Xw + :: Ptr + Word8) + (eta6_Xx [OS=OneShot] + :: GHC.Prim.State# + GHC.Prim.RealWorld) + = case op_Xw + of op1_Xy + { GHC.Ptr.Ptr ipv3_Xz -> + case GHC.Prim.<# + ww2_Xv + iendTmp1_Xp + of { + __DEFAULT -> + $s$wouterLoop_s2bC + ipv3_Xz + bx7_Xf + ww2_Xv + eta6_Xx; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M + ww2_Xv + of r#1_XB + { __DEFAULT -> + case GHC.Prim.ltWord8# + r#1_XB + 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + ipv3_Xz + 0# + r#1_XB + eta6_Xx + of s2_a26u + { __DEFAULT -> + jump $s$wgo1_s2bd + s2_a26u + (GHC.Prim.plusAddr# + ipv3_Xz + 1#) + (GHC.Prim.+# + ww2_Xv + 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# + r#1_XB) + op1_Xy) + `cast` (GHC.Types.N:IO[0] + <Ptr + Word8>_R + :: IO + (Ptr + Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + eta6_Xx + of + { (# ipv4_XE, + ipv5_XF #) -> + jump $wgo_Xu + (GHC.Prim.+# + ww2_Xv + 1#) + ipv5_XF + ipv4_XE + } + } + } + } + }; } in + jump $wgo_Xu + (GHC.Prim.+# + sc2_s2b0 + 1#) + ipv2_a26M + ipv1_a26L + } + } + } + }; } in + jump $s$wgo_s2b3 + eta5_s28W + bx6_Xe + ww1_s28T } in + case GHC.Prim.<=# ds4_Xk y2_Xm of { + __DEFAULT -> jump $j4_Xn y2_Xm; + 1# -> jump $j4_Xn ds4_Xk + } + } + } } in + case wild3_X6 of { + __DEFAULT -> jump $j3_Xj; + -1# -> + case a1_Xi of { + __DEFAULT -> jump $j3_Xj; + -9223372036854775808# -> + case GHC.Real.overflowError + of wild7_00 { + } + } + }; + 1# -> + ((k_X2 wild4_Xd) + `cast` (GHC.Types.N:IO[0] + <B.BuildSignal r_a238>_R + :: IO (B.BuildSignal r_a238) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + B.BuildSignal + r_a238 #)))) + eta5_s28W + } + }; } in + $s$wouterLoop_s2bC + ipv_s24F bx4_d22Q ww_s28F eta4_s28I } in + joinrec { + $s$wgo_s2cO [Occ=LoopBreaker, Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.State# GHC.Prim.RealWorld + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<L><L><L>, + Unf=OtherCon []] + $s$wgo_s2cO (sc_s2cN :: GHC.Prim.State# GHC.Prim.RealWorld) + (sc1_s2cM :: GHC.Prim.Addr#) + (sc2_s2cL :: GHC.Prim.Int#) + = case GHC.Prim.<# sc2_s2cL iendTmp_s27v of { + __DEFAULT -> jump exit_Xc sc2_s2cL sc_s2cN sc1_s2cM; + 1# -> + case GHC.Prim.indexWord8Array# bx_d22M sc2_s2cL + of r#_a24P + { __DEFAULT -> + case GHC.Prim.ltWord8# r#_a24P 128##8 of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + sc1_s2cM + 0# + r#_a24P + sc_s2cN + of s2_a26u + { __DEFAULT -> + jump $s$wgo_s2cO + s2_a26u + (GHC.Prim.plusAddr# sc1_s2cM 1#) + (GHC.Prim.+# sc2_s2cL 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# r#_a24P) + (GHC.Ptr.Ptr @Word8 sc1_s2cM)) + `cast` (GHC.Types.N:IO[0] <Ptr Word8>_R + :: IO (Ptr Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr Word8 #)))) + sc_s2cN + of + { (# ipv_a26L, ipv1_a26M #) -> + joinrec { + $s$wgo1_s2cY [Occ=LoopBreaker, + Dmd=LCS(C1(C1(!P(L,L))))] + :: GHC.Prim.State# GHC.Prim.RealWorld + -> GHC.Prim.Addr# + -> GHC.Prim.Int# + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(3)(Nothing)], + Arity=3, + Str=<L><L><L>, + Unf=OtherCon []] + $s$wgo1_s2cY (sc3_s2cU + :: GHC.Prim.State# + GHC.Prim.RealWorld) + (sc4_s2cT :: GHC.Prim.Addr#) + (sc5_s2cS :: GHC.Prim.Int#) + = case GHC.Prim.<# sc5_s2cS iendTmp_s27v of { + __DEFAULT -> + jump exit_Xc + sc5_s2cS sc3_s2cU sc4_s2cT; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M sc5_s2cS + of r#1_Xk + { __DEFAULT -> + case GHC.Prim.ltWord8# r#1_Xk 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + sc4_s2cT + 0# + r#1_Xk + sc3_s2cU + of s2_a26u + { __DEFAULT -> + jump $s$wgo1_s2cY + s2_a26u + (GHC.Prim.plusAddr# sc4_s2cT 1#) + (GHC.Prim.+# sc5_s2cS 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# r#1_Xk) + (GHC.Ptr.Ptr + @Word8 sc4_s2cT)) + `cast` (GHC.Types.N:IO[0] + <Ptr Word8>_R + :: IO (Ptr Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + sc3_s2cU + of + { (# ipv2_Xn, ipv3_Xo #) -> + jump $wgo_Xd + (GHC.Prim.+# sc5_s2cS 1#) + ipv3_Xo + ipv2_Xn + } + } + } + }; + $wgo_Xd [InlPrag=[2], + Occ=LoopBreaker, + Dmd=SCS(C1(C1(!P(L,L))))] + :: GHC.Prim.Int# + -> Ptr Word8 + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #) + [LclId[JoinId(3)(Just [~, !])], + Arity=3, + Str=<L><1L><L>, + Unf=OtherCon []] + $wgo_Xd (ww_Xe :: GHC.Prim.Int#) + (op_Xf :: Ptr Word8) + (eta4_Xg [OS=OneShot] + :: GHC.Prim.State# + GHC.Prim.RealWorld) + = case op_Xf of op1_Xh + { GHC.Ptr.Ptr ipv2_Xi -> + case GHC.Prim.<# ww_Xe iendTmp_s27v of { + __DEFAULT -> + jump exit_Xc ww_Xe eta4_Xg ipv2_Xi; + 1# -> + case GHC.Prim.indexWord8Array# + bx_d22M ww_Xe + of r#1_Xk + { __DEFAULT -> + case GHC.Prim.ltWord8# r#1_Xk 128##8 + of { + __DEFAULT -> + case GHC.Prim.writeWord8OffAddr# + @GHC.Prim.RealWorld + ipv2_Xi + 0# + r#1_Xk + eta4_Xg + of s2_a26u + { __DEFAULT -> + jump $s$wgo1_s2cY + s2_a26u + (GHC.Prim.plusAddr# ipv2_Xi 1#) + (GHC.Prim.+# ww_Xe 1#) + }; + 1# -> + case ((ds1_a27N + (GHC.Word.W8# r#1_Xk) + op1_Xh) + `cast` (GHC.Types.N:IO[0] + <Ptr Word8>_R + :: IO (Ptr Word8) + ~R# (GHC.Prim.State# + GHC.Prim.RealWorld + -> (# GHC.Prim.State# + GHC.Prim.RealWorld, + Ptr + Word8 #)))) + eta4_Xg + of + { (# ipv3_Xn, ipv4_Xo #) -> + jump $wgo_Xd + (GHC.Prim.+# ww_Xe 1#) + ipv4_Xo + ipv3_Xn + } + } + } + } + }; } in + jump $wgo_Xd + (GHC.Prim.+# sc2_s2cL 1#) ipv1_a26M ipv_a26L + } + } + } + }; } in + jump $s$wgo_s2cO eta3_B3 bx3_d22P bx1_d22N } in + case GHC.Prim.<=# ds2_a23R y1_s27t of { + __DEFAULT -> jump $j2_s27P y1_s27t; + 1# -> jump $j2_s27P ds2_a23R + } + } + } } in + case wild3_X6 of { + __DEFAULT -> jump $j1_s27p; + -1# -> + case a_s27n of { + __DEFAULT -> jump $j1_s27p; + -9223372036854775808# -> + case GHC.Real.overflowError of wild6_00 { } + } + }; + 0# -> case GHC.Real.divZeroError of wild4_00 { } + } } in + case GHC.Prim.<=# 4# bx5_a27M of { + __DEFAULT -> jump $j_s28Z 4#; + 1# -> jump $j_s28Z bx5_a27M + } + }; + 1# -> + ((k_X2 wild1_X5) + `cast` (GHC.Types.N:IO[0] <B.BuildSignal r_a238>_R + :: IO (B.BuildSignal r_a238) + ~R# (GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal r_a238 #)))) + eta3_B3 + } + } + } + }) + `cast` (<BP.BoundedPrim Word8>_R + %<'Many>_N ->_R <Text>_R + %<'Many>_N ->_R forall (r :: <*>_N). + <B.BuildStep (r |> <*>_N)>_R + %<'Many>_N ->_R <B.BufferRange>_R + %<'Many>_N ->_R Sym (GHC.Types.N:IO[0] + <B.BuildSignal (r |> <*>_N)>_R) + ; Sym (Data.ByteString.Builder.Internal.N:Builder[0]) + :: (BP.BoundedPrim Word8 + -> Text + -> forall {r}. + B.BuildStep (r |> <*>_N) + -> B.BufferRange + -> GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, + B.BuildSignal (r |> <*>_N) #)) + ~R# (BP.BoundedPrim Word8 -> Text -> B.Builder)) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +Data.Text.Encoding.$trModule4 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +Data.Text.Encoding.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +Data.Text.Encoding.$trModule3 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +Data.Text.Encoding.$trModule3 + = GHC.Types.TrNameS Data.Text.Encoding.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +Data.Text.Encoding.$trModule2 :: GHC.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 60 0}] +Data.Text.Encoding.$trModule2 = "Data.Text.Encoding"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +Data.Text.Encoding.$trModule1 :: GHC.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +Data.Text.Encoding.$trModule1 + = GHC.Types.TrNameS Data.Text.Encoding.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +Data.Text.Encoding.$trModule :: GHC.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +Data.Text.Encoding.$trModule + = GHC.Types.Module + Data.Text.Encoding.$trModule3 Data.Text.Encoding.$trModule1 + + + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 1450a43932..012150b21e 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -295,6 +295,7 @@ test('T16348', normal, compile, ['-O']) test('T16918', normal, compile, ['-O']) test('T16918a', normal, compile, ['-O']) test('T16978a', normal, compile, ['-O']) +test('T21694', [ req_profiling ] , compile, ['-O -prof -fprof-auto -funfolding-use-threshold=50 ']) test('T16978b', normal, compile, ['-O']) test('T16979a', normal, compile, ['-O']) test('T16979b', normal, compile, ['-O']) @@ -420,3 +421,6 @@ test('T21392', [ grep_errmsg(r'sat.* :: \[\(.*Unique, .*Int\)\]'), expect_broken test('T21689', [extra_files(['T21689a.hs'])], multimod_compile, ['T21689', '-v0 -O']) test('T21801', normal, compile, ['-O -dcore-lint']) test('T21848', [grep_errmsg(r'SPEC wombat') ], compile, ['-O -ddump-spec']) +test('T21694b', [grep_errmsg(r'Arity=4') ], compile, ['-O -ddump-simpl']) +test('T21960', [grep_errmsg(r'^ Arity=5') ], compile, ['-O2 -ddump-simpl']) +test('T21948', [grep_errmsg(r'^ Arity=5') ], compile, ['-O -ddump-simpl']) |