[Git][ghc/ghc][wip/simplifier-tweaks] More small improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Mar 27 16:39:41 UTC 2024
Simon Peyton Jones pushed to branch wip/simplifier-tweaks at Glasgow Haskell Compiler / GHC
Commits:
1b1281ef by Simon Peyton Jones at 2024-03-27T16:39:08+00:00
More small improvements
1. use `isBetterUnfoldingThan` in join-point inlinint
2. In Inline, some_benefit is only true for RhsCtxt when UnfWhen
c.f. seqIsBoring and #22317
3. Simplify StrictArgCtxt... not sure here
4. Add tagToEnum# to CaseMerge. Good for
case (case f x of r -> tagToEnum# r) of alts
Avoids danger that we make a join point
$j r -> case tagToEnum# r of alts
which involves a test we don't have to do.
- - - - -
15 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Inline.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Utils.hs
- testsuite/tests/cpranal/should_compile/T18401.stderr
- testsuite/tests/dmdanal/sigs/T21081.stderr
- testsuite/tests/driver/inline-check.stderr
- testsuite/tests/numeric/should_compile/T19641.stderr
- + testsuite/tests/perf/compiler/T18730.hs
- + testsuite/tests/perf/compiler/T18730.stderr
- + testsuite/tests/perf/compiler/T18730_A.hs
- testsuite/tests/simplCore/should_compile/T15631.stdout
- testsuite/tests/simplCore/should_compile/T22317.hs
- testsuite/tests/simplCore/should_compile/T22428.stderr
- testsuite/tests/simplCore/should_compile/spec-inline.stderr
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -64,7 +64,7 @@ module GHC.Core (
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding,
- isInlineUnfolding, isBootUnfolding,
+ isInlineUnfolding, isBootUnfolding, isBetterUnfoldingThan,
hasCoreUnfolding, hasSomeUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
@@ -1640,6 +1640,23 @@ canUnfold :: Unfolding -> Bool
canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
canUnfold _ = False
+isBetterUnfoldingThan :: Unfolding -> Unfolding -> Bool
+-- Used in inlining checks
+isBetterUnfoldingThan NoUnfolding _ = False
+isBetterUnfoldingThan BootUnfolding _ = False
+
+isBetterUnfoldingThan (CoreUnfolding {}) (CoreUnfolding {}) = False
+isBetterUnfoldingThan (CoreUnfolding {}) _ = True
+
+isBetterUnfoldingThan (DFunUnfolding {}) (DFunUnfolding {}) = False
+isBetterUnfoldingThan (DFunUnfolding {}) _ = True
+
+isBetterUnfoldingThan (OtherCon cs) (OtherCon cs') = not (null cs) && null cs' -- A bit crude
+isBetterUnfoldingThan (OtherCon {}) (CoreUnfolding {}) = False
+isBetterUnfoldingThan (OtherCon {}) (DFunUnfolding {}) = False
+isBetterUnfoldingThan (OtherCon {}) NoUnfolding = True
+isBetterUnfoldingThan (OtherCon {}) BootUnfolding = True
+
{- Note [Fragile unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
An unfolding is "fragile" if it mentions free variables (and hence would
=====================================
compiler/GHC/Core/Opt/Simplify/Inline.hs
=====================================
@@ -314,7 +314,7 @@ tryUnfolding env logger id lone_variable arg_infos
| otherwise
-> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing
where
- some_benefit = calc_some_benefit uf_arity
+ some_benefit = calc_some_benefit uf_arity True
enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)
UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }
@@ -326,7 +326,7 @@ tryUnfolding env logger id lone_variable arg_infos
yes = traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)
no = traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing
- some_benefit = calc_some_benefit (length arg_discounts)
+ some_benefit = calc_some_benefit (length arg_discounts) False
-- depth_penalty: see Note [Avoid inlining into deeply nested cases]
depth_threshold = unfoldingCaseThreshold opts
@@ -389,9 +389,9 @@ tryUnfolding env logger id lone_variable arg_infos
-- arguments (ie n_val_args >= arity). But there must
-- be *something* interesting about some argument, or the
-- result context, to make it worth inlining
- calc_some_benefit :: Arity -> Bool -- The Arity is the number of args
+ calc_some_benefit :: Arity -> Bool -> Bool -- The Arity is the number of args
-- expected by the unfolding
- calc_some_benefit uf_arity
+ calc_some_benefit uf_arity is_inline
| not saturated = interesting_args -- Under-saturated
-- Note [Unsaturated applications]
| otherwise = interesting_args -- Saturated or over-saturated
@@ -413,7 +413,7 @@ tryUnfolding env logger id lone_variable arg_infos
ValAppCtxt -> True -- Note [Cast then apply]
RuleArgCtxt -> uf_arity > 0 -- See Note [RHS of lets]
DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt]
- RhsCtxt NonRecursive
+ RhsCtxt NonRecursive | is_inline
-> uf_arity > 0 -- See Note [RHS of lets]
_other -> False -- See Note [Nested functions]
@@ -424,9 +424,8 @@ vselems s = nonDetStrictFoldVarSet (\v vs -> v : vs) [] s
is_more_evald :: InScopeSet -> Id -> Bool
-- See Note [Inlining join points]
is_more_evald in_scope v
- | not (isEvaldUnfolding (idUnfolding v))
- , Just v' <- lookupInScope in_scope v
- , isEvaldUnfolding (idUnfolding v')
+ | Just v1 <- lookupInScope in_scope v
+ , idUnfolding v1 `isBetterUnfoldingThan` idUnfolding v
= True
| otherwise
= False
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -888,20 +888,22 @@ lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })
| otherwise = BoringCtxt -- Nothing interesting
strictArgContext :: ArgInfo -> CallCtxt
-strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })
--- Use this for strict arguments
- | encl_rules = RuleArgCtxt
- | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here
- | otherwise = RhsCtxt NonRecursive
- -- Why RhsCtxt? if we see f (g x), and f is strict, we
- -- want to be a bit more eager to inline g, because it may
- -- expose an eval (on x perhaps) that can be eliminated or
- -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1
- -- It's worth an 18% improvement in allocation for this
- -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'
- --
- -- Why NonRecursive? Becuase it's a bit like
- -- let a = g x in f a
+strictArgContext _ = DiscArgCtxt
+ -- XXXX TODO TODO c.f. Seq is boring
+ -- Why RhsCtxt? if we see f (g x), and f is strict, we
+ -- want to be a bit more eager to inline g, because it may
+ -- expose an eval (on x perhaps) that can be eliminated or
+ -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1
+ -- It's worth an 18% improvement in allocation for this
+ -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'
+ --
+ -- Why NonRecursive? Becuase it's a bit like
+ -- let a = g x in f a
+
+-- (ArgInfo { ai_encl = encl_rules, ai_discs = discs })
+-- | encl_rules = RuleArgCtxt
+-- | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here
+-- | otherwise = RhsCtxt NonRecursive
interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
-- See Note [Interesting call context]
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -16,7 +16,7 @@ module GHC.Core.Utils (
-- * Taking expressions apart
findDefault, addDefault, findAlt, isDefaultAlt,
- mergeAlts, mergeCaseAlts, trimConArgs,
+ mergeAlts, mergeCaseAlts, trimConArgs,
filterAlts, combineIdenticalAlts, refineDefaultAlt,
scaleAltsBy,
@@ -674,8 +674,7 @@ mergeCaseAlts outer_bndr alts
-- duplication we are prepared to put up with.
go 0 _ _ _ = Nothing
- go n wrap free_bndrs (Tick t rhs)
- = go n (wrap . Tick t) free_bndrs rhs
+ -- Whizzo: we can merge!
go _ wrap free_bndrs (Case (Var inner_scrut_var) inner_bndr _ inner_alts)
| inner_scrut_var == outer_bndr
, let wrap_let rhs' = Let (NonRec inner_bndr (Var outer_bndr)) rhs'
@@ -686,6 +685,26 @@ mergeCaseAlts outer_bndr alts
| any (`elemVarSet` free_bndrs') bndrs = Nothing
| otherwise = Just (Alt con bndrs (wrap (wrap_let rhs)))
= mapM do_one inner_alts
+
+ -- Deal with tagToEnum# See See Note [Merge Nested Cases] wrinkle (MNC1)
+ go _ wrap _ (App (App (Var f) (Type type_arg)) (Var v))
+ | v == outer_bndr
+ , Just TagToEnumOp <- isPrimOpId_maybe f
+ , Just tc <- tyConAppTyCon_maybe type_arg
+ , Just (dc:dcs) <- tyConDataCons_maybe tc
+ , dcs `lengthAtMost` 3 -- Arbitrary
+ = Just ( Alt DEFAULT [] (mk_rhs dc)
+ : [Alt (LitAlt (mk_lit dc)) [] (mk_rhs dc) | dc <- dcs] )
+
+ where
+ mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc
+ mk_rhs dc = wrap $ Var (dataConWorkId dc)
+
+ -- Look past ticks
+ go n wrap free_bndrs (Tick t rhs)
+ = go n (wrap . Tick t) free_bndrs rhs
+
+ -- Look past cases on another variable
go n wrap free_bndrs (Case (Var inner_scrut) inner_bndr ty inner_alts)
| [Alt con bndrs rhs] <- inner_alts -- Wrinkle (MC1)
, not (outer_bndr `elem` (inner_bndr : bndrs))
=====================================
testsuite/tests/cpranal/should_compile/T18401.stderr
=====================================
@@ -4,34 +4,34 @@ Result size of Tidy Core = {terms: 58, types: 93, coercions: 0, joins: 1/1}
Rec {
-- RHS size: {terms: 18, types: 24, coercions: 0, joins: 0/0}
-T18401.$w$spoly_$wgo2 :: forall a. a -> [a] -> (# [a] #)
-T18401.$w$spoly_$wgo2
- = \ (@a_s1dv) (sc_s1dw :: a_s1dv) (sc1_s1dx :: [a_s1dv]) ->
- case sc1_s1dx of {
- [] -> (# GHC.Types.[] @a_s1dv #);
- : y_a1ct ys_a1cu -> (# GHC.Types.: @a_s1dv sc_s1dw (case T18401.$w$spoly_$wgo2 @a_s1dv y_a1ct ys_a1cu of { (# ww_s1dC #) -> ww_s1dC }) #)
+T18401.$w$spoly_$wgo1 :: forall a. a -> [a] -> (# [a] #)
+T18401.$w$spoly_$wgo1
+ = \ (@a_s1eu) (sc_s1ev :: a_s1eu) (sc1_s1ew :: [a_s1eu]) ->
+ case sc1_s1ew of {
+ [] -> (# GHC.Types.[] @a_s1eu #);
+ : y_a1dy ys_a1dz -> (# GHC.Types.: @a_s1eu sc_s1ev (case T18401.$w$spoly_$wgo1 @a_s1eu y_a1dy ys_a1dz of { (# ww_s1eA #) -> ww_s1eA }) #)
}
end Rec }
-- RHS size: {terms: 23, types: 29, coercions: 0, joins: 1/1}
si :: forall a. [a] -> (Bool, [a])
si
- = \ (@a_s1cD) (xs0_s1cE :: [a_s1cD]) ->
+ = \ (@a_s1dI) (xs0_s1dJ :: [a_s1dI]) ->
join {
- $j_s1dr :: Bool %1 -> [a_s1cD] %1 -> (Bool, [a_s1cD])
- $j_s1dr (ww_s1cS :: Bool) (ww1_s1cT :: [a_s1cD]) = (ww_s1cS, ww1_s1cT) } in
- case xs0_s1cE of {
- [] -> jump $j_s1dr GHC.Types.False (GHC.Types.[] @a_s1cD);
- : y_a1ct ys_a1cu -> jump $j_s1dr GHC.Types.True (case T18401.$w$spoly_$wgo2 @a_s1cD y_a1ct ys_a1cu of { (# ww_s1dC #) -> ww_s1dC })
+ $j_s1eq :: Bool %1 -> [a_s1dI] %1 -> (Bool, [a_s1dI])
+ $j_s1eq (ww_s1dX :: Bool) (ww1_s1dY :: [a_s1dI]) = (ww_s1dX, ww1_s1dY) } in
+ case xs0_s1dJ of {
+ [] -> jump $j_s1eq GHC.Types.False (GHC.Types.[] @a_s1dI);
+ : y_a1dy ys_a1dz -> jump $j_s1eq GHC.Types.True (case T18401.$w$spoly_$wgo1 @a_s1dI y_a1dy ys_a1dz of { (# ww_s1eA #) -> ww_s1eA })
}
-- RHS size: {terms: 14, types: 19, coercions: 0, joins: 0/0}
safeInit :: forall a. [a] -> Maybe [a]
safeInit
- = \ (@a_aR8) (xs_awS :: [a_aR8]) ->
- case xs_awS of {
- [] -> GHC.Maybe.Nothing @[a_aR8];
- : y_a1ct ys_a1cu -> GHC.Maybe.Just @[a_aR8] (case T18401.$w$spoly_$wgo2 @a_aR8 y_a1ct ys_a1cu of { (# ww_s1dC #) -> ww_s1dC })
+ = \ (@a_aQY) (xs_awU :: [a_aQY]) ->
+ case xs_awU of {
+ [] -> GHC.Internal.Maybe.Nothing @[a_aQY];
+ : y_a1dy ys_a1dz -> GHC.Internal.Maybe.Just @[a_aQY] (case T18401.$w$spoly_$wgo1 @a_aQY y_a1dy ys_a1dz of { (# ww_s1eA #) -> ww_s1eA })
}
=====================================
testsuite/tests/dmdanal/sigs/T21081.stderr
=====================================
@@ -15,7 +15,7 @@ T21081.fst': <1!P(1L,A)>
T21081.g: <ML>
T21081.h: <MP(ML,ML)><1!P(1L)>
T21081.h2: <L><S!P(SL)>
-T21081.i: <1L><1L><LP(ML,ML)>
+T21081.i: <1L><1L><MP(ML,ML)>
T21081.j: <S!P(1L,1L)>
T21081.myfoldl: <LC(S,C(1,L))><1L><1L>
T21081.snd': <1!P(A,1L)>
@@ -61,7 +61,7 @@ T21081.fst': <1!P(1L,A)>
T21081.g: <ML>
T21081.h: <MP(ML,ML)><1!P(1L)>
T21081.h2: <L><1!P(SL)>
-T21081.i: <1L><1L><LP(ML,ML)>
+T21081.i: <1L><1L><MP(ML,ML)>
T21081.j: <1!P(1L,1L)>
T21081.myfoldl: <LC(S,C(1,L))><1L><1L>
T21081.snd': <1!P(A,1L)>
=====================================
testsuite/tests/driver/inline-check.stderr
=====================================
@@ -8,7 +8,7 @@ Considering inlining: foo
case depth = 0
inline depth = 0
depth based penalty = 0
- discounted size = 10
+ adjusted size = 10
ANSWER = YES
Inactive unfolding: foo1
Inactive unfolding: foo1
@@ -28,6 +28,6 @@ Considering inlining: foo
case depth = 0
inline depth = 0
depth based penalty = 0
- discounted size = 20
+ adjusted size = 20
ANSWER = NO
Inactive unfolding: foo1
=====================================
testsuite/tests/numeric/should_compile/T19641.stderr
=====================================
@@ -13,9 +13,9 @@ natural_to_word
integer_to_int
= \ eta ->
case eta of {
- IS x1 -> Just (I# x1);
- IP ipv -> Nothing;
- IN ds1 -> Nothing
+ IS ipv -> Just (I# ipv);
+ IP x -> Nothing;
+ IN ds2 -> Nothing
}
=====================================
testsuite/tests/perf/compiler/T18730.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -funfolding-case-scaling=5 #-}
+
+module T18730 where
+
+import T18730_A (Gen)
+
+genFields :: Gen [(String, Int)]
+genFields =
+ mapM
+ (\(f, g) -> (f,) <$> g)
+ [ ("field", genIntField)
+ , ("field_10", genIntField)
+ , ("field_10", genIntField)
+ , ("field_10", genIntField)
+ , ("field_10", genIntField)
+ , ("field_10", genIntField)
+ , ("field_10", genIntField)
+ , ("field_10", genIntField)
+ , ("field_10", genIntField)
+ , ("field_10", genIntField)
+ , ("field_10", genIntField)
+ ]
+
+genIntField :: Gen Int
+genIntField = pure 0
=====================================
testsuite/tests/perf/compiler/T18730.stderr
=====================================
@@ -0,0 +1 @@
+
=====================================
testsuite/tests/perf/compiler/T18730_A.hs
=====================================
@@ -0,0 +1,50 @@
+module T18730_A where
+
+import Control.Monad (ap)
+import Data.Word
+import Data.Bits
+
+newtype Gen a = MkGen
+ { -- | Run the generator on a particular seed.
+ -- If you just want to get a random value out, consider using 'generate'.
+ unGen :: QCGen -> Int -> a
+ }
+
+instance Functor Gen where
+ fmap f (MkGen h) =
+ MkGen (\r n -> f (h r n))
+
+instance Applicative Gen where
+ pure x =
+ MkGen (\_ _ -> x)
+ (<*>) = ap
+
+instance Monad Gen where
+ return = pure
+
+ MkGen m >>= k =
+ MkGen
+ ( \r n ->
+ case split r of
+ (r1, r2) ->
+ let MkGen m' = k (m r1 n)
+ in m' r2 n
+ )
+
+ (>>) = (*>)
+
+data QCGen = QCGen !Word64 !Word64
+
+split :: QCGen -> (QCGen, QCGen)
+split (QCGen seed gamma) =
+ (QCGen seed'' gamma, QCGen seed' (mixGamma seed''))
+ where
+ seed' = seed + gamma
+ seed'' = seed' + gamma
+
+-- This piece appears to be critical
+mixGamma :: Word64 -> Word64
+mixGamma z0 =
+ if z0 >= 24
+ then z0
+ else z0 `xor` 0xaaaaaaaaaaaaaaaa
=====================================
testsuite/tests/simplCore/should_compile/T15631.stdout
=====================================
@@ -1,5 +1,6 @@
- case GHC.List.$wlenAcc @a xs 0# of ww1 { __DEFAULT ->
- = case GHC.List.$wlenAcc
- case GHC.List.reverse1 @a xs (GHC.Types.[] @a) of {
+ case reverse @a xs of ys { __DEFAULT ->
+ case GHC.Internal.List.$wlenAcc @a xs 0# of ww1 { __DEFAULT ->
+ = case GHC.Internal.List.$wlenAcc
+ case ys of {
case Foo.$wf @a xs of ww [Occ=Once1] { __DEFAULT ->
case Foo.$wf @a xs of ww { __DEFAULT -> GHC.Types.I# ww }
=====================================
testsuite/tests/simplCore/should_compile/T22317.hs
=====================================
@@ -6,9 +6,9 @@ data T = T (Maybe Bool) (Maybe Bool) (Maybe Bool) (Maybe Bool)
m :: Maybe a -> Maybe a -> Maybe a
+-- Don't make this INLINE; if you do, ,it's not unreasonable to inline it
m (Just v1) Nothing = Just v1
m _ mb = mb
-{-# INLINE m #-}
f :: T -> T -> T
f (T a1 b1 c1 d1) (T a2 b2 c2 d2)
=====================================
testsuite/tests/simplCore/should_compile/T22428.stderr
=====================================
@@ -1,7 +1,7 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 28, types: 15, coercions: 0, joins: 2/2}
+ = {terms: 32, types: 14, coercions: 0, joins: 1/1}
-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
T22428.f1 :: Integer
@@ -11,36 +11,37 @@ T22428.f1 :: Integer
Guidance=IF_ARGS [] 10 10}]
T22428.f1 = GHC.Num.Integer.IS 1#
--- RHS size: {terms: 24, types: 11, coercions: 0, joins: 2/2}
+-- RHS size: {terms: 28, types: 10, coercions: 0, joins: 1/1}
f :: Integer -> Integer -> Integer
[GblId,
Arity=2,
- Str=<SL><SL>,
+ Str=<SL><1L>,
Unf=Unf{Src=<vanilla>, TopLvl=True,
Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [0 0] 94 0}]
+ Guidance=IF_ARGS [0 0] 140 0}]
f = \ (x :: Integer) (y :: Integer) ->
joinrec {
go [InlPrag=INLINE (sat-args=1), Occ=LoopBreaker, Dmd=SC(S,L)]
:: Integer -> Integer
[LclId[JoinId(1)(Just [!])],
Arity=1,
- Str=<SL>,
+ Str=<1L>,
Unf=Unf{Src=StableUser, TopLvl=False,
Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False)}]
go (ds :: Integer)
- = join {
- $j [Dmd=ML] :: Integer
- [LclId[JoinId(0)(Nothing)]]
- $j = jump go (GHC.Num.Integer.integerSub ds T22428.f1) } in
- case ds of {
- GHC.Num.Integer.IS x1 ->
- case x1 of {
- __DEFAULT -> jump $j;
+ = case ds of x1 {
+ GHC.Num.Integer.IS x2 ->
+ case x2 of {
+ __DEFAULT -> jump go (GHC.Num.Integer.integerSub x1 T22428.f1);
0# -> x
};
- GHC.Num.Integer.IP x1 -> jump $j;
- GHC.Num.Integer.IN x1 -> jump $j
+ GHC.Num.Integer.IP x2 ->
+ jump go (GHC.Num.Integer.integerSub x1 T22428.f1);
+ GHC.Num.Integer.IN x2 ->
+ jump go (GHC.Num.Integer.integerSub x1 T22428.f1)
}; } in
jump go y
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/spec-inline.stderr
=====================================
@@ -1,41 +1,114 @@
==================== Tidy Core ====================
Result size of Tidy Core
- = {terms: 57, types: 17, coercions: 0, joins: 1/1}
+ = {terms: 136, types: 55, coercions: 0, joins: 0/0}
--- RHS size: {terms: 48, types: 11, coercions: 0, joins: 1/1}
-Roman.$wfoo [InlPrag=[2]] :: Int -> GHC.Prim.Int#
-[GblId[StrictWorker([!])],
- Arity=1,
- Str=<1L>,
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+lvl :: GHC.Prim.Addr#
+[GblId, Unf=OtherCon []]
+lvl = "spec-inline.hs:(19,5)-(29,25)|function go"#
+
+-- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0}
+Roman.foo3 :: ()
+[GblId, Str=b, Cpr=b]
+Roman.foo3
+ = GHC.Internal.Control.Exception.Base.patError
+ @GHC.Types.LiftedRep @() lvl
+
+Rec {
+-- RHS size: {terms: 40, types: 5, coercions: 0, joins: 0/0}
+Roman.foo_$s$wgo [Occ=LoopBreaker]
+ :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int#
+[GblId, Arity=2, Str=<A><L>, Unf=OtherCon []]
+Roman.foo_$s$wgo
+ = \ (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#) ->
+ case GHC.Prim.<=# sc1 0# of {
+ __DEFAULT ->
+ case GHC.Prim.<# sc1 100# of {
+ __DEFAULT ->
+ case GHC.Prim.<# sc1 500# of {
+ __DEFAULT ->
+ Roman.foo_$s$wgo (GHC.Prim.*# 14# sc) (GHC.Prim.-# sc1 1#);
+ 1# -> Roman.foo_$s$wgo (GHC.Prim.*# 7# sc) (GHC.Prim.-# sc1 3#)
+ };
+ 1# -> Roman.foo_$s$wgo sc (GHC.Prim.-# sc1 2#)
+ };
+ 1# -> 0#
+ }
+end Rec }
+
+-- RHS size: {terms: 61, types: 18, coercions: 0, joins: 0/0}
+Roman.$wgo [InlPrag=[2]] :: Maybe Int -> Maybe Int -> GHC.Prim.Int#
+[GblId[StrictWorker([!, !])],
+ Arity=2,
+ Str=<1L><1L>,
Unf=Unf{Src=<vanilla>, TopLvl=True,
Value=True, ConLike=True, WorkFree=True, Expandable=True,
- Guidance=IF_ARGS [20] 78 0}]
-Roman.$wfoo
- = \ (n :: Int) ->
- case n of { GHC.Types.I# ipv ->
- joinrec {
- $sgo [Occ=LoopBreaker, Dmd=SC(S,C(1,L))]
- :: GHC.Prim.Int# -> GHC.Prim.Int# -> GHC.Prim.Int#
- [LclId[JoinId(2)(Nothing)], Arity=2, Str=<A><L>, Unf=OtherCon []]
- $sgo (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#)
- = case GHC.Prim.<=# sc1 0# of {
- __DEFAULT ->
- case GHC.Prim.<# sc1 100# of {
- __DEFAULT ->
- case GHC.Prim.<# sc1 500# of {
- __DEFAULT -> jump $sgo (GHC.Prim.*# 14# sc) (GHC.Prim.-# sc1 1#);
- 1# -> jump $sgo (GHC.Prim.*# 7# sc) (GHC.Prim.-# sc1 3#)
- };
- 1# -> jump $sgo sc (GHC.Prim.-# sc1 2#)
- };
- 1# -> 0#
- }; } in
- jump $sgo 6# ipv
+ Guidance=IF_ARGS [61 30] 249 0}]
+Roman.$wgo
+ = \ (u :: Maybe Int) (ds :: Maybe Int) ->
+ case ds of {
+ Nothing -> case Roman.foo3 of {};
+ Just x ->
+ case x of { GHC.Types.I# ipv ->
+ case u of {
+ Nothing -> Roman.foo_$s$wgo (GHC.Prim.*# 7# ipv) 10#;
+ Just n ->
+ case n of { GHC.Types.I# x2 ->
+ case GHC.Prim.<=# x2 0# of {
+ __DEFAULT ->
+ case GHC.Prim.<# x2 100# of {
+ __DEFAULT ->
+ case GHC.Prim.<# x2 500# of {
+ __DEFAULT ->
+ Roman.foo_$s$wgo (GHC.Prim.*# 14# ipv) (GHC.Prim.-# x2 1#);
+ 1# -> Roman.foo_$s$wgo (GHC.Prim.*# 7# ipv) (GHC.Prim.-# x2 3#)
+ };
+ 1# -> Roman.foo_$s$wgo ipv (GHC.Prim.-# x2 2#)
+ };
+ 1# -> 0#
+ }
+ }
+ }
+ }
}
--- RHS size: {terms: 7, types: 2, coercions: 0, joins: 0/0}
-foo [InlPrag=[2]] :: Int -> Int
+-- RHS size: {terms: 9, types: 5, coercions: 0, joins: 0/0}
+Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int
+[GblId[StrictWorker([!, !])],
+ Arity=2,
+ Str=<1L><1L>,
+ Cpr=1,
+ Unf=Unf{Src=StableSystem, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (u [Occ=Once1] :: Maybe Int)
+ (ds [Occ=Once1] :: Maybe Int) ->
+ case Roman.$wgo u ds of ww [Occ=Once1] { __DEFAULT ->
+ GHC.Types.I# ww
+ }}]
+Roman.foo_go
+ = \ (u :: Maybe Int) (ds :: Maybe Int) ->
+ case Roman.$wgo u ds of ww { __DEFAULT -> GHC.Types.I# ww }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Roman.foo2 :: Int
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
+Roman.foo2 = GHC.Types.I# 6#
+
+-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0}
+Roman.foo1 :: Maybe Int
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True,
+ Value=True, ConLike=True, WorkFree=True, Expandable=True,
+ Guidance=IF_ARGS [] 10 10}]
+Roman.foo1 = GHC.Internal.Maybe.Just @Int Roman.foo2
+
+-- RHS size: {terms: 11, types: 4, coercions: 0, joins: 0/0}
+foo :: Int -> Int
[GblId,
Arity=1,
Str=<1L>,
@@ -43,11 +116,22 @@ foo [InlPrag=[2]] :: Int -> Int
Unf=Unf{Src=StableSystem, TopLvl=True,
Value=True, ConLike=True, WorkFree=True, Expandable=True,
Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
- Tmpl= \ (n [Occ=Once1] :: Int) ->
- case Roman.$wfoo n of ww [Occ=Once1] { __DEFAULT ->
- GHC.Types.I# ww
+ Tmpl= \ (n [Occ=Once1!] :: Int) ->
+ case n of n1 [Occ=Once1] { GHC.Types.I# _ [Occ=Dead] ->
+ Roman.foo_go (GHC.Internal.Maybe.Just @Int n1) Roman.foo1
}}]
foo
= \ (n :: Int) ->
- case Roman.$wfoo n of ww { __DEFAULT -> GHC.Types.I# ww }
+ case n of { GHC.Types.I# ipv ->
+ case Roman.foo_$s$wgo 6# ipv of ww { __DEFAULT -> GHC.Types.I# ww }
+ }
+
+
+------ Local rules for imported ids --------
+"SC:$wgo0" [2]
+ forall (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#).
+ Roman.$wgo (GHC.Internal.Maybe.Just @Int (GHC.Types.I# sc1))
+ (GHC.Internal.Maybe.Just @Int (GHC.Types.I# sc))
+ = Roman.foo_$s$wgo sc sc1
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b1281efbe996f81653cf82735f44452ec10d5db
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1b1281efbe996f81653cf82735f44452ec10d5db
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240327/5e3836d1/attachment-0001.html>
More information about the ghc-commits
mailing list