[Git][ghc/ghc][wip/T22227] 4 commits: Denest NonRecs in SpecConstr for more specialisation (#22277)
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Wed Oct 12 11:26:18 UTC 2022
Sebastian Graf pushed to branch wip/T22227 at Glasgow Haskell Compiler / GHC
Commits:
f4bfd14b by Sebastian Graf at 2022-10-12T13:15:31+02:00
Denest NonRecs in SpecConstr for more specialisation (#22277)
See Note [Denesting non-recursive let bindings].
Fixes #22277. It is also related to #14951 and #14844 in that it
fixes a very specific case of looking through a non-recursive let binding in
SpecConstr.
- - - - -
1b814e02 by Sebastian Graf at 2022-10-12T13:15:32+02:00
Loopification in OccurAnal (#22227, #14068)
- - - - -
b00847e9 by Sebastian Graf at 2022-10-12T13:15:32+02:00
Do join point loopification only pre-simplification
- - - - -
31c14aed by Sebastian Graf at 2022-10-12T13:15:32+02:00
DmdAnal: Look through DataConWrappers (#22241)
- - - - -
15 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- testsuite/tests/linear/should_compile/LinearLetRec.hs
- + testsuite/tests/simplCore/should_compile/T14951.hs
- + testsuite/tests/simplCore/should_compile/T22227.hs
- + testsuite/tests/simplCore/should_compile/T22227.stderr
- + testsuite/tests/simplCore/should_compile/T22277.hs
- + testsuite/tests/simplCore/should_compile/T22277.stderr
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/stranal/sigs/T22241.hs
- + testsuite/tests/stranal/sigs/T22241.stderr
- testsuite/tests/stranal/sigs/T5075.hs
- testsuite/tests/stranal/sigs/all.T
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -41,7 +41,7 @@ module GHC.Core (
isId, cmpAltCon, cmpAlt, ltAlt,
-- ** Simple 'Expr' access functions and predicates
- bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
+ bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectLets,
collectBinders, collectTyBinders, collectTyAndValBinders,
collectNBinders, collectNValBinders_maybe,
collectArgs, stripNArgs, collectArgsTicks, flattenBinds,
@@ -1940,6 +1940,15 @@ flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
flattenBinds [] = []
+-- | We often want to strip off leading 'Let's before getting down to
+-- business. The inverse of 'mkLets'.
+collectLets :: Expr b -> ([Bind b], Expr b)
+collectLets expr
+ = go [] expr
+ where
+ go bs (Let b e) = go (b:bs) e
+ go bs e = (reverse bs, e)
+
-- | We often want to strip off leading lambdas before getting down to
-- business. Variants are 'collectTyBinders', 'collectValBinders',
-- and 'collectTyAndValBinders'
@@ -1957,7 +1966,7 @@ collectBinders expr
= go [] expr
where
go bs (Lam b e) = go (b:bs) e
- go bs e = (reverse bs, e)
+ go bs e = (reverse bs, e)
collectTyBinders expr
= go [] expr
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -985,6 +985,9 @@ dmdTransform env var sd
| isDataConWorkId var
= -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr var $$ ppr sd $$ ppr ty) $
dmdTransformDataConSig (idArity var) sd
+ | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var)
+ , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs
+ = dmd_ty
-- Dictionary component selectors
-- Used to be controlled by a flag.
-- See #18429 for some perf measurements.
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -58,7 +58,44 @@ import GHC.Utils.Trace
import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
-import Data.List (mapAccumL, mapAccumR)
+import Data.List (mapAccumL, mapAccumR, find)
+
+{-
+************************************************************************
+* *
+ OccurAnalConfig
+* *
+************************************************************************
+-}
+
+data OccurAnalConfig
+ = OAC { oac_unf_act :: !(Id -> Bool) -- ^ Which Id unfoldings are active
+ , oac_rule_act :: !(Activation -> Bool) -- ^ Which rules are active
+ -- See Note [Finding rule RHS free vars]
+ , oac_loopify :: !Bool -- ^ Do loopification?
+ -- See Note [Join point loopification]
+ }
+
+pureOccurAnalConfig :: OccurAnalConfig
+pureOccurAnalConfig
+ -- Used in the pure 'occurAnalyseExpr'.
+ -- To be conservative, we say that all
+ -- inlines and rules are active and that
+ -- loopification is deactivated
+ = OAC { oac_unf_act = \_ -> True
+ , oac_rule_act = \_ -> True
+ , oac_loopify = False
+ }
+
+fullOccurAnalConfig :: (Id -> Bool) -> (Activation -> Bool) -> OccurAnalConfig
+fullOccurAnalConfig active_unf active_rule
+ -- Used in the full, pre-Simplification 'occurAnalysePgm'.
+ -- There we know the precise unfolding and rule activation
+ -- and we want loopification to happen.
+ = OAC { oac_unf_act = active_unf
+ , oac_rule_act = active_rule
+ , oac_loopify = True
+ }
{-
************************************************************************
@@ -74,7 +111,7 @@ Here's the externally-callable interface:
occurAnalyseExpr :: CoreExpr -> CoreExpr
occurAnalyseExpr expr = expr'
where
- (WithUsageDetails _ expr') = occAnal initOccEnv expr
+ (WithUsageDetails _ expr') = occAnal (initOccEnv pureOccurAnalConfig) expr
occurAnalysePgm :: Module -- Used only in debug output
-> (Id -> Bool) -- Active unfoldings
@@ -89,8 +126,7 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
= warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))
occ_anald_glommed_binds
where
- init_env = initOccEnv { occ_rule_act = active_rule
- , occ_unf_act = active_unf }
+ init_env = initOccEnv (fullOccurAnalConfig active_unf active_rule)
(WithUsageDetails final_usage occ_anald_binds) = go init_env binds
(WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel
@@ -856,15 +892,33 @@ occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs
-- See Note [Recursive bindings: the grand plan]
-- See Note [Loop breaking]
occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails body_uds binds)
- | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds
+ | null used_bndrs
= WithUsageDetails body_uds binds -- See Note [Dead code]
+ | oac_loopify (occ_config env) -- Check for Note [Join point loopification]
+ , [loop_entry] <- used_bndrs
+ , not (isJoinId loop_entry)
+ , let loop_occ = lookupDetails body_uds loop_entry
+ , NoTailCallInfo <- tailCallInfo loop_occ -- otherwise turn it into a joinrec rightaway
+ , case loop_occ of OneOcc{occ_int_cxt=int} -> int == IsInteresting; _ -> True -- otherwise loop_entry is not applied and there is no point. also trouble with CorePrep in andy_cherry: f (letrec match ... in match)
+ , let unadj_uds = foldr (andUDs . nd_uds) emptyDetails details_s
+ , decideJoinPointHood lvl unadj_uds bndrs
+ , AlwaysTailCalled arity <- tailCallInfo $ lookupDetails unadj_uds loop_entry
+ , Just loop_nds <- find ((== loop_entry) . nd_bndr) details_s
+ , (!lam_bndrs,_) <- collectNBinders arity (nd_rhs loop_nds)
+ , let !loop_body_uds = mkOneOcc loop_entry IsInteresting arity
+ , WithUsageDetails new_rhs_uds loop_binds <- occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails loop_body_uds [])
+ , (body_uds',loop_entry') <- tagNonRecBinder lvl body_uds loop_entry
+ , let new_bind = NonRec loop_entry' (mkLams lam_bndrs (mkLets loop_binds (mkVarApps (Var loop_entry') lam_bndrs)))
+ = WithUsageDetails (markAllNonTail new_rhs_uds `andUDs` body_uds') (new_bind : binds)
+
| otherwise -- At this point we always build a single Rec
= -- pprTrace "occAnalRec" (ppr loop_breaker_nodes)
WithUsageDetails final_uds (Rec pairs : binds)
where
bndrs = map nd_bndr details_s
+ used_bndrs = filter (`usedIn` body_uds) bndrs -- NB: look at body_uds, not total_uds
all_simple = all nd_simple details_s
------------------------------
@@ -1433,7 +1487,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
(WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env Recursive mb_join_arity unf
--------- IMP-RULES --------
- is_active = occ_rule_act env :: Activation -> Bool
+ is_active = oac_rule_act (occ_config env) :: Activation -> Bool
imp_rule_info = lookupImpRules imp_rule_edges bndr
imp_rule_uds = impRulesScopeUsage imp_rule_info
imp_rule_fvs = impRulesActiveFvs is_active bndr_set imp_rule_info
@@ -1487,7 +1541,7 @@ mkLoopBreakerNodes !env lvl body_uds details_s
-- Note [Deterministic SCC] in GHC.Data.Graph.Directed.
where
new_nd = nd { nd_bndr = new_bndr, nd_score = score }
- score = nodeScore env new_bndr lb_deps nd
+ score = nodeScore (occ_config env) new_bndr lb_deps nd
lb_deps = extendFvs_ rule_fv_env inl_fvs
-- See Note [Loop breaker dependencies]
@@ -1519,12 +1573,12 @@ group { f1 = e1; ...; fn = en } are:
-}
------------------------------------------
-nodeScore :: OccEnv
+nodeScore :: OccurAnalConfig
-> Id -- Binder with new occ-info
-> VarSet -- Loop-breaker dependencies
-> Details
-> NodeScore
-nodeScore !env new_bndr lb_deps
+nodeScore !cfg new_bndr lb_deps
(ND { nd_bndr = old_bndr, nd_rhs = bind_rhs })
| not (isId old_bndr) -- A type or coercion variable is never a loop breaker
@@ -1533,7 +1587,7 @@ nodeScore !env new_bndr lb_deps
| old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers
= (0, 0, True) -- See Note [Self-recursion and loop breakers]
- | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has
+ | not (oac_unf_act cfg old_bndr) -- A binder whose inlining is inactive (e.g. has
= (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker
| exprIsTrivial rhs
@@ -2454,12 +2508,9 @@ scrutinised y).
-}
data OccEnv
- = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
+ = OccEnv { occ_config :: !OccurAnalConfig
+ , occ_encl :: !OccEncl -- Enclosing context information
, occ_one_shots :: !OneShots -- See Note [OneShots]
- , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active
- , occ_rule_act :: Activation -> Bool -- Which rules are active
- -- See Note [Finding rule RHS free vars]
-
-- See Note [The binder-swap substitution]
-- If x :-> (y, co) is in the env,
-- then please replace x by (y |> sym mco)
@@ -2500,18 +2551,13 @@ instance Outputable OccEncl where
-- See Note [OneShots]
type OneShots = [OneShotInfo]
-initOccEnv :: OccEnv
-initOccEnv
- = OccEnv { occ_encl = OccVanilla
+initOccEnv :: OccurAnalConfig -> OccEnv
+initOccEnv cfg
+ = OccEnv { occ_config = cfg
+ , occ_encl = OccVanilla
, occ_one_shots = []
-
- -- To be conservative, we say that all
- -- inlines and rules are active
- , occ_unf_act = \_ -> True
- , occ_rule_act = \_ -> True
-
- , occ_bs_env = emptyVarEnv
- , occ_bs_rng = emptyVarSet }
+ , occ_bs_env = emptyVarEnv
+ , occ_bs_rng = emptyVarSet }
noBinderSwaps :: OccEnv -> Bool
noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.Core
import GHC.Core.Subst
import GHC.Core.Utils
import GHC.Core.Unfold
-import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars )
+import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars, exprsFreeVars, exprSomeFreeVarsList )
import GHC.Core.Opt.Monad
import GHC.Core.Opt.WorkWrap.Utils
import GHC.Core.DataCon
@@ -52,6 +52,7 @@ import GHC.Unit.Module.ModGuts
import GHC.Types.Literal ( litIsLifted )
import GHC.Types.Id
import GHC.Types.Id.Info ( IdDetails(..) )
+import GHC.Types.Var ( setIdDetails )
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Name
@@ -80,10 +81,11 @@ import GHC.Exts( SpecConstrAnnotation(..) )
import GHC.Serialized ( deserializeWithData )
import Control.Monad ( zipWithM )
-import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
+import Data.List ( nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
import Data.Maybe( mapMaybe )
import Data.Ord( comparing )
import Data.Tuple
+import Data.Bifunctor ( first )
{-
-----------------------------------------------------
@@ -773,10 +775,21 @@ specConstrProgram guts
; return (guts { mg_binds = binds' }) }
scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind])
-scTopBinds _env [] = return (nullUsage, [])
-scTopBinds env (b:bs) = do { (usg, b', bs') <- scBind TopLevel env b $
- (\env -> scTopBinds env bs)
- ; return (usg, b' ++ bs') }
+scTopBinds env bs = do
+ (usg, bs, ()) <- scBinds TopLevel env bs (\_env -> return (nullUsage, ()))
+ return (usg, bs)
+
+scBinds :: TopLevelFlag -> ScEnv -> [InBind]
+ -> (ScEnv -> UniqSM (ScUsage, a)) -- Specialise the scope of the bindings
+ -> UniqSM (ScUsage, [OutBind], a)
+scBinds _lvl env [] k = do
+ (usg, a) <- k env
+ return (usg, [], a)
+scBinds lvl env (b:bs) k = do
+ (usg, b', (bs', a)) <- scBind lvl env b $ \env -> do
+ (usg, bs', a) <- scBinds lvl env bs k
+ return (usg, (bs',a))
+ return (usg, b' ++ bs', a)
{-
************************************************************************
@@ -1018,6 +1031,9 @@ extendScInScope env qvars
extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
+extendScSubstPre :: ScEnv -> Var -> InExpr -> ScEnv
+extendScSubstPre env var expr = extendScSubst env var (substExpr (sc_subst env) expr)
+
extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
@@ -1330,6 +1346,15 @@ creates specialised versions of functions.
scBind :: TopLevelFlag -> ScEnv -> InBind
-> (ScEnv -> UniqSM (ScUsage, a)) -- Specialise the scope of the binding
-> UniqSM (ScUsage, [OutBind], a)
+scBind NotTopLevel env (NonRec bndr rhs) do_body
+ | Just (app, binds) <- denest_nonrec_let (getSubstInScope (sc_subst env)) bndr rhs
+ -- See Note [Denesting non-recursive let bindings]
+ -- We don't denest at the top-level, because we will extend the substitution
+ -- and top-level binders have already been put into scope and (had their
+ -- unfoldings!) substituted due to Note [Glomming], so we wouldn't be able
+ -- to discard the NonRec.
+ -- , pprTrace "denest" (ppr bndr <+> ppr app $$ ppr binds) True
+ = scBinds NotTopLevel env binds (\env -> do_body $ extendScSubstPre env bndr app)
scBind top_lvl env (NonRec bndr rhs) do_body
| isTyVar bndr -- Type-lets may be created by doBeta
= do { (final_usage, body') <- do_body (extendScSubst env bndr rhs)
@@ -1424,8 +1449,88 @@ scBind top_lvl env (Rec prs) do_body
rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
-{- Note [Specialising local let bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- | Implements Note [Denesting non-recursive let bindings].
+--
+-- The call `denest_nonrec_let in_scope f (\xs -> let binds in g ys)` returns
+-- `Just (\xs -> g' ys, binds')`, where `g'` and `binds'` were stripped of their
+-- join-point-ness (if `f` was not a join point itself).
+-- The function returns `Nothing` if the code does not match.
+--
+-- The `InScopeSet` makes sure that `binds` do not shadow existing bindings
+-- that are used in ..., in which case this function will return `Nothing`, too.
+denest_nonrec_let :: InScopeSet -> InId -> InExpr -> Maybe (InExpr, [InBind])
+denest_nonrec_let in_scope f rhs
+ | (xs@(_:_), body) <- collectBinders rhs
+ , (binds@(_:_), call) <- collectLets body
+ , (Var g, args) <- collectArgs call
+ , let bndrs = bindersOfBinds binds
+ , (g', binds') <- need_zap_join_point_hood f g binds `orElse` (g, binds)
+ -- expensive tests last:
+ , bndrs `dont_shadow` in_scope -- floating binds out may not shadow bindings already in scope
+ , args `exprs_dont_mention` bndrs -- args may not mention binds
+ , binds `binds_dont_mention` xs -- binds may not mention xs
+ = Just (mkLams xs $ mkApps (Var g') args, binds')
+ | otherwise
+ = Nothing
+ where
+ dont_shadow :: [Var] -> InScopeSet -> Bool
+ dont_shadow bndrs in_scope =
+ disjointVarSet (getInScopeVars in_scope) (mkVarSet bndrs)
+
+ exprs_dont_mention :: [CoreExpr] -> [Var] -> Bool
+ exprs_dont_mention exprs vs =
+ disjointVarSet (exprsFreeVars exprs) (mkVarSet vs)
+
+ binds_dont_mention :: [CoreBind] -> [Var] -> Bool
+ binds_dont_mention binds vs =
+ let some_var = head (bindersOfBinds binds)
+ vs_set = mkVarSet vs
+ in null $ exprSomeFreeVarsList (`elemVarSet` vs_set) (mkLets binds (Var some_var))
+
+ need_zap_join_point_hood :: Id -> Id -> [CoreBind] -> Maybe (Id, [CoreBind])
+ need_zap_join_point_hood f g binds
+ | isJoinId f = Nothing -- `f` and `g` share tail context
+ | not (isJoinId g) = Nothing -- `g` and thus `binds` never were joinpoints to begin with
+ | otherwise = Just (mark_non_join g, map (map_binders mark_non_join) binds)
+
+ map_binders :: (b -> b) -> Bind b -> Bind b
+ map_binders f (NonRec b rhs) = NonRec (f b) rhs
+ map_binders f (Rec prs) = Rec (map (first f) prs)
+
+ mark_non_join :: Id -> Id
+ mark_non_join id = case idDetails id of
+ JoinId _ Nothing -> id `setIdDetails` VanillaId
+ JoinId _ (Just cbv_marks) -> id `setIdDetails` WorkerLikeId cbv_marks
+ _ -> id
+
+{- Note [Denesting non-recursive let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we see (local or at top-level)
+
+ f xs = let binds in g as;
+ rest
+
+where `xs` don't occur in `binds` and `as` do not mention `binds` and `xs` is
+not empty. It might be interesting to specialise `f` and `g` for call patterns
+in `rest`, but it is difficult to do it in this nested form, because
+
+ 1. We only get to see `ScrutOcc`s on `g`, in its RHS
+ 2. The interesting call patterns in `rest` apply only to `f` (hence `xs` non-empty)
+ 3. Specialising `f` and `g` for those call patterns duplicates `binds` twice:
+ We keep one copy of `bind` in the original `f`, one copy of `bind` in `$sf`
+ and another specialised copy `$sbind` (containing `$sg`) in `$sf`.
+
+So for SpecConstr, we float out `binds` (removing potential join-point-ness)
+
+ binds;
+ rest[f:=\xs -> g as]
+
+Because now all call patterns of `f` directly apply to `g` and might match up
+with one of the `ScrutOcc`s in its RHS, while only needing a single duplicate of
+`bind`.
+
+Note [Specialising local let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is not uncommon to find this
let $j = \x. <blah> in ...$j True...$j True...
=====================================
testsuite/tests/linear/should_compile/LinearLetRec.hs
=====================================
@@ -8,4 +8,13 @@ extendOrigNameCache _ _ = Name
initNameCache :: Int -> [Name] -> NameCache
initNameCache us names
- = NameCache us (foldl extendOrigNameCache Name names)
+ = NameCache us (go Name names)
+ where
+ -- go will become a join point once $WNameCache inlines. That join point
+ -- has a nullary exit join point with a problematic linearity.
+ -- The NOINLINE makes sure that call-site loopification doesn't turn go into
+ -- a joinrec before $WNameCache inlines
+ go acc [] = acc
+ -- head names `seq` ... so that `go` doesn't float to top-level
+ go acc (n:ns) = head names `seq` go (extendOrigNameCache acc n) ns
+ {-# NOINLINE go #-} -- see above comment
=====================================
testsuite/tests/simplCore/should_compile/T14951.hs
=====================================
@@ -0,0 +1,24 @@
+-- {-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-}
+-- {-# OPTIONS_GHC -O2 -fforce-recomp #-}
+-- {-# LANGUAGE PatternSynonyms #-}
+-- {-# LANGUAGE BangPatterns #-}
+-- {-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+module T14844Example (topLvl) where
+
+topLvl large = (bar1, bar2, foo)
+ where
+ foo :: Integer -> (a -> b -> Bool) -> (a,b) -> Bool
+ foo 0 _ _ = False
+ foo s f t = l s' t
+ where
+ l 0 t = False
+ l 1 t = case t of (x,y) -> f x y
+ l n (x,y) = l (n-1) (x,y)
+ s' = large s
+
+ bar1 :: Integer -> (a -> b -> Bool) -> a -> b -> Bool
+ bar1 s f x y = foo s f (x,y)
+
+ bar2 :: Integer -> (a -> b -> Bool) -> a -> b -> Bool
+ bar2 s f x y = foo (s + 1) f (x,y)
=====================================
testsuite/tests/simplCore/should_compile/T22227.hs
=====================================
@@ -0,0 +1,39 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Unboxed (test) where
+
+import GHC.Exts
+import GHC.IO
+
+data Step s a = Yield a s | Done
+
+uninitialised = undefined
+
+test :: Int# -> Int# -> Array# Double -> (# Int#, Int#, Array# Double #)
+test off n oldArr = runRW# $ \s0 ->
+ case newArray# n uninitialised s0
+ of { (# s1, newArr #) ->
+ let
+ step' i
+ | isTrue# (i >=# n) = Done
+ | otherwise =
+ let (# D# x #) = indexArray# oldArr (off +# i) in
+ if isTrue# (x >## 10.0##)
+ then Yield (D# x) (I# (i +# 1#))
+ else step' (i +# 1#)
+ loop i j s2 =
+ case step' i of
+ Yield x (I# s') ->
+ case writeArray# newArr j (x + 1) s2
+ of { s3 ->
+ loop s' (j +# 1#) s3
+ }
+ Done ->
+ case unsafeFreezeArray# newArr s2
+ of { (# s3, out #) ->
+ (# 0#, j, out #)
+ }
+ in
+ loop 0# 0# s1
+ }
=====================================
testsuite/tests/simplCore/should_compile/T22227.stderr
=====================================
@@ -0,0 +1,310 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 213, types: 211, coercions: 4, joins: 5/5}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+lvl :: Addr#
+[GblId, Unf=OtherCon []]
+lvl = "undefined"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl1 :: [Char]
+[GblId]
+lvl1 = unpackCString# lvl
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule4 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Unboxed.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl2 :: [Char]
+[GblId]
+lvl2 = unpackCString# Unboxed.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule2 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unboxed.$trModule2 = "Unboxed"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl3 :: [Char]
+[GblId]
+lvl3 = unpackCString# Unboxed.$trModule2
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+lvl4 :: Addr#
+[GblId, Unf=OtherCon []]
+lvl4 = "T22227.hs"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl5 :: [Char]
+[GblId]
+lvl5 = unpackCString# lvl4
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl6 :: Int
+[GblId, Unf=OtherCon []]
+lvl6 = GHC.Types.I# 11#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl7 :: Int
+[GblId, Unf=OtherCon []]
+lvl7 = GHC.Types.I# 17#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl8 :: Int
+[GblId, Unf=OtherCon []]
+lvl8 = GHC.Types.I# 26#
+
+-- RHS size: {terms: 8, types: 0, coercions: 0, joins: 0/0}
+lvl9 :: GHC.Stack.Types.SrcLoc
+[GblId, Unf=OtherCon []]
+lvl9 = GHC.Stack.Types.SrcLoc lvl2 lvl3 lvl5 lvl6 lvl7 lvl6 lvl8
+
+-- RHS size: {terms: 4, types: 0, coercions: 0, joins: 0/0}
+lvl10 :: GHC.Stack.Types.CallStack
+[GblId, Unf=OtherCon []]
+lvl10
+ = GHC.Stack.Types.PushCallStack
+ lvl1 lvl9 GHC.Stack.Types.EmptyCallStack
+
+-- RHS size: {terms: 3, types: 3, coercions: 4, joins: 0/0}
+uninitialised :: forall {a}. a
+[GblId, Str=b, Cpr=b]
+uninitialised
+ = \ (@a) ->
+ undefined
+ @LiftedRep
+ @a
+ (lvl10
+ `cast` (Sym (GHC.Classes.N:IP[0]
+ <"callStack">_N <GHC.Stack.Types.CallStack>_N)
+ :: GHC.Stack.Types.CallStack
+ ~R# (?callStack::GHC.Stack.Types.CallStack)))
+
+-- RHS size: {terms: 90, types: 151, coercions: 0, joins: 5/5}
+test
+ :: Int# -> Int# -> Array# Double -> (# Int#, Int#, Array# Double #)
+[GblId,
+ Arity=3,
+ Str=<L><L><L>,
+ Cpr=1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0 0] 137 0}]
+test
+ = \ (off :: Int#) (n :: Int#) (oldArr :: Array# Double) ->
+ runRW#
+ @('TupleRep '[ 'IntRep, 'IntRep, UnliftedRep])
+ @(# Int#, Int#, Array# Double #)
+ (\ (s [OS=OneShot] :: State# RealWorld) ->
+ case newArray#
+ @'Lifted @Double @RealWorld n (uninitialised @Double) s
+ of
+ { (# ipv, ipv1 #) ->
+ join {
+ exit [Dmd=SC(S,C(1,L))]
+ :: Int# -> State# RealWorld -> (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>]
+ exit (j [OS=OneShot] :: Int#) (s2 [OS=OneShot] :: State# RealWorld)
+ = case unsafeFreezeArray# @'Lifted @RealWorld @Double ipv1 s2 of
+ { (# ipv2, ipv3 #) ->
+ (# 0#, j, ipv3 #)
+ } } in
+ joinrec {
+ loop [Occ=LoopBreaker, Dmd=SC(S,C(1,C(1,L)))]
+ :: Int#
+ -> Int# -> State# RealWorld -> (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(3)(Nothing)],
+ Arity=3,
+ Str=<L><L><L>,
+ Unf=OtherCon []]
+ loop (i :: Int#) (j :: Int#) (s2 :: State# RealWorld)
+ = join {
+ exit1 [Dmd=LC(S,C(1,!P(L,L,L)))]
+ :: Int# -> Double# -> (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(2)(Nothing)], Arity=2, Str=<L><L>]
+ exit1 (i1 [OS=OneShot] :: Int#) (x [OS=OneShot] :: Double#)
+ = case writeArray#
+ @'Lifted @RealWorld @Double ipv1 j (GHC.Types.D# (+## x 1.0##)) s2
+ of s3
+ { __DEFAULT ->
+ jump loop (+# i1 1#) (+# j 1#) s3
+ } } in
+ join {
+ $j [Dmd=L!P(L,L,L)] :: (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(0)(Nothing)]]
+ $j = jump exit j s2 } in
+ joinrec {
+ step' [Occ=LoopBreaker, Dmd=SC(S,!P(L,L,L))]
+ :: Int# -> (# Int#, Int#, Array# Double #)
+ [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>, Unf=OtherCon []]
+ step' (i1 :: Int#)
+ = case >=# i1 n of {
+ __DEFAULT ->
+ case indexArray# @'Lifted @Double oldArr (+# off i1) of
+ { (# ipv2 #) ->
+ case ipv2 of { D# x ->
+ case >## x 10.0## of {
+ __DEFAULT -> jump step' (+# i1 1#);
+ 1# -> jump exit1 i1 x
+ }
+ }
+ };
+ 1# -> jump $j
+ }; } in
+ jump step' i; } in
+ jump loop 0# 0# ipv
+ })
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$trModule3 = GHC.Types.TrNameS Unboxed.$trModule4
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$trModule1 = GHC.Types.TrNameS Unboxed.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$trModule
+ = GHC.Types.Module Unboxed.$trModule3 Unboxed.$trModule1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep = GHC.Types.KindRepVar 1#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$krep1 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep1 = GHC.Types.KindRepVar 0#
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tcStep2 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Unboxed.$tcStep2 = "Step"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tcStep1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tcStep1 = GHC.Types.TrNameS Unboxed.$tcStep2
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tcStep :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tcStep
+ = GHC.Types.TyCon
+ 9345441458829744813##64
+ 15928240119707513573##64
+ Unboxed.$trModule
+ Unboxed.$tcStep1
+ 0#
+ GHC.Types.krep$*->*->*
+
+-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0}
+$krep2 :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep2
+ = GHC.Types.:
+ @GHC.Types.KindRep $krep (GHC.Types.[] @GHC.Types.KindRep)
+
+-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0}
+$krep3 :: [GHC.Types.KindRep]
+[GblId, Unf=OtherCon []]
+$krep3 = GHC.Types.: @GHC.Types.KindRep $krep1 $krep2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Done1 [InlPrag=[~]] :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+Unboxed.$tc'Done1
+ = GHC.Types.KindRepTyConApp Unboxed.$tcStep $krep3
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Done3 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unboxed.$tc'Done3 = "'Done"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Done2 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tc'Done2 = GHC.Types.TrNameS Unboxed.$tc'Done3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Done :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tc'Done
+ = GHC.Types.TyCon
+ 12965714903249458155##64
+ 720712123234526269##64
+ Unboxed.$trModule
+ Unboxed.$tc'Done2
+ 2#
+ Unboxed.$tc'Done1
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+$krep4 :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+$krep4 = GHC.Types.KindRepFun $krep1 Unboxed.$tc'Done1
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Yield1 [InlPrag=[~]] :: GHC.Types.KindRep
+[GblId, Unf=OtherCon []]
+Unboxed.$tc'Yield1 = GHC.Types.KindRepFun $krep $krep4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Yield3 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Unboxed.$tc'Yield3 = "'Yield"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Yield2 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tc'Yield2 = GHC.Types.TrNameS Unboxed.$tc'Yield3
+
+-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0}
+Unboxed.$tc'Yield :: GHC.Types.TyCon
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Unboxed.$tc'Yield
+ = GHC.Types.TyCon
+ 16456917800457442198##64
+ 7357499335137316903##64
+ Unboxed.$trModule
+ Unboxed.$tc'Yield2
+ 2#
+ Unboxed.$tc'Yield1
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/T22277.hs
=====================================
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+
+module T22277 where
+
+entry :: Int -> Int
+entry n = case n of
+ 0 -> f n (13,24)
+ _ -> f n (n,n)
+ where
+ f :: Int -> (Int,Int) -> Int
+ f m x = g m x
+ where
+ exit m = (length $ reverse $ reverse $ reverse $ reverse $ [0..m]) + n
+ g n p | even n = exit n
+ | n > 43 = g (n-1) p
+ | otherwise = fst p
=====================================
testsuite/tests/simplCore/should_compile/T22277.stderr
=====================================
@@ -0,0 +1,132 @@
+[1 of 1] Compiling T22277 ( T22277.hs, T22277.o )
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 110, types: 49, coercions: 0, joins: 3/4}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T22277.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.$trModule3 = GHC.Types.TrNameS T22277.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T22277.$trModule2 = "T22277"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.$trModule1 = GHC.Types.TrNameS T22277.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T22277.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.$trModule
+ = GHC.Types.Module T22277.$trModule3 T22277.$trModule1
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22277.entry2 :: Int
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.entry2 = GHC.Types.I# 13#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T22277.entry1 :: Int
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T22277.entry1 = GHC.Types.I# 24#
+
+-- RHS size: {terms: 89, types: 40, coercions: 0, joins: 3/4}
+entry :: Int -> Int
+[GblId,
+ Arity=1,
+ Str=<1P(SL)>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [20] 403 0}]
+entry
+ = \ (n :: Int) ->
+ case n of wild { GHC.Types.I# ds ->
+ join {
+ $w$sexit [InlPrag=[2], Dmd=LC(S,!P(L))] :: GHC.Prim.Int# -> Int
+ [LclId[JoinId(1)(Nothing)], Arity=1, Str=<L>]
+ $w$sexit (ww [OS=OneShot] :: GHC.Prim.Int#)
+ = join {
+ $j [Dmd=1C(1,!P(L))] :: [Int] -> Int
+ [LclId[JoinId(1)(Just [!])], Arity=1, Str=<1L>, Unf=OtherCon []]
+ $j (arg [OS=OneShot] :: [Int])
+ = case GHC.List.$wlenAcc
+ @Int
+ (GHC.List.reverse1
+ @Int
+ (GHC.List.reverse1
+ @Int
+ (GHC.List.reverse1
+ @Int
+ (GHC.List.reverse1 @Int arg (GHC.Types.[] @Int))
+ (GHC.Types.[] @Int))
+ (GHC.Types.[] @Int))
+ (GHC.Types.[] @Int))
+ 0#
+ of ww1
+ { __DEFAULT ->
+ GHC.Types.I# (GHC.Prim.+# ww1 ds)
+ } } in
+ case GHC.Prim.># 0# ww of {
+ __DEFAULT ->
+ letrec {
+ go3 [Occ=LoopBreaker, Dmd=SC(S,L)] :: GHC.Prim.Int# -> [Int]
+ [LclId, Arity=1, Str=<L>, Unf=OtherCon []]
+ go3
+ = \ (x :: GHC.Prim.Int#) ->
+ GHC.Types.:
+ @Int
+ (GHC.Types.I# x)
+ (case GHC.Prim.==# x ww of {
+ __DEFAULT -> go3 (GHC.Prim.+# x 1#);
+ 1# -> GHC.Types.[] @Int
+ }); } in
+ jump $j (go3 0#);
+ 1# -> jump $j (GHC.Types.[] @Int)
+ } } in
+ joinrec {
+ $s$wg [Occ=LoopBreaker, Dmd=SC(S,C(1,C(1,!P(L))))]
+ :: Int -> Int -> GHC.Prim.Int# -> Int
+ [LclId[JoinId(3)(Nothing)],
+ Arity=3,
+ Str=<ML><A><L>,
+ Unf=OtherCon []]
+ $s$wg (sc :: Int) (sc1 :: Int) (sc2 :: GHC.Prim.Int#)
+ = case GHC.Prim.remInt# sc2 2# of {
+ __DEFAULT ->
+ case GHC.Prim.># sc2 43# of {
+ __DEFAULT -> sc;
+ 1# -> jump $s$wg sc sc1 (GHC.Prim.-# sc2 1#)
+ };
+ 0# -> jump $w$sexit sc2
+ }; } in
+ case ds of ds1 {
+ __DEFAULT -> jump $s$wg wild wild ds1;
+ 0# -> jump $s$wg T22277.entry2 T22277.entry1 0#
+ }
+ }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -273,6 +273,9 @@ test('T14152a', [extra_files(['T14152.hs']), pre_cmd('cp T14152.hs T14152a.hs'),
compile, ['-fno-exitification -ddump-simpl'])
test('T13990', normal, compile, ['-dcore-lint -O'])
test('T14650', normal, compile, ['-O2'])
+
+# SpecConstr should specialise `l` here:
+test('T14951', [expect_broken(14591), grep_errmsg(r'\$sl') ], compile, ['-O2 -dsuppress-uniques -ddump-simpl'])
test('T14959', normal, compile, ['-O'])
test('T14978',
normal,
@@ -428,9 +431,13 @@ test('T21763', only_ways(['optasm']), compile, ['-O2 -ddump-rules'])
test('T21763a', only_ways(['optasm']), compile, ['-O2 -ddump-rules'])
test('T22028', normal, compile, ['-O -ddump-rule-firings'])
test('T22114', normal, compile, ['-O'])
-test('T21286', normal, multimod_compile, ['T21286', '-O -ddump-rule-firings'])
+test('T21286', normal, multimod_compile, ['T21286', '-O -ddump-rule-firings'])
+# step should be loopified and turned into a join point
+test('T22227', [grep_errmsg(r'jump \S*step') ], compile, ['-O -dsuppress-uniques -ddump-simpl'])
# One module, T21851.hs, has OPTIONS_GHC -ddump-simpl
test('T21851', [grep_errmsg(r'case.*w\$sf') ], multimod_compile, ['T21851', '-O -dno-typeable-binds -dsuppress-uniques'])
# One module, T22097.hs, has OPTIONS_GHC -ddump-simpl
test('T22097', [grep_errmsg(r'case.*wgoEven') ], multimod_compile, ['T22097', '-O -dno-typeable-binds -dsuppress-uniques'])
+# SpecConstr should be able to specialise `go` for the pair
+test('T22277', [grep_errmsg(r'\$s\$wgo') ], compile, ['-O2 -ddump-simpl -dsuppress-uniques'])
=====================================
testsuite/tests/stranal/sigs/T22241.hs
=====================================
@@ -0,0 +1,12 @@
+module T22241 where
+
+data D = D !Int
+
+-- We should unbox y here, which only happens if DmdAnal sees that $WD will
+-- unbox it.
+f :: Bool -> Int -> D
+f x y = D (go x)
+ where
+ go False = y
+ go True = go False
+{-# NOINLINE f #-}
=====================================
testsuite/tests/stranal/sigs/T22241.stderr
=====================================
@@ -0,0 +1,15 @@
+
+==================== Strictness signatures ====================
+T22241.f: <1L><S!P(L)>
+
+
+
+==================== Cpr signatures ====================
+T22241.f: 1
+
+
+
+==================== Strictness signatures ====================
+T22241.f: <1L><1!P(SL)>
+
+
=====================================
testsuite/tests/stranal/sigs/T5075.hs
=====================================
@@ -17,10 +17,10 @@ g x y = go x
True -> Just x
False -> go (x*2)
--- Here, go is not a join point, but still should be WW'd for Just.
--- Unfortunately, CPR can't see that (+?) returns Just, so h won't get the CPR
--- property. It probably could by only considering the @Just@ case of the
--- inlined (+?).
+-- Here, go is not a join point (call-site loopification doesn't trigger because
+-- it is marked NOINLINE), but still should be WW'd for Just. Unfortunately,
+-- CPR can't see that (+?) returns Just, so h won't get the CPR property. It
+-- probably could by only considering the @Just@ case of the inlined (+?).
h :: Int -> Maybe Int
h x = go x +? go (x+1)
where
@@ -29,3 +29,4 @@ h x = go x +? go (x+1)
go z
| z > 10 = Just (x + z)
| otherwise = go (z*2)
+ {-# NOINLINE go #-}
=====================================
testsuite/tests/stranal/sigs/all.T
=====================================
@@ -37,3 +37,4 @@ test('T21717', normal, compile, [''])
test('T21754', normal, compile, [''])
test('T21888', normal, compile, [''])
test('T21888a', normal, compile, [''])
+test('T22241', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6dbf837a217705c787c2fdbc9194d3b3c5aefe34...31c14aedc1c58e6be0f6ff29f51ca782f5930f8a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6dbf837a217705c787c2fdbc9194d3b3c5aefe34...31c14aedc1c58e6be0f6ff29f51ca782f5930f8a
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/20221012/191e9e03/attachment-0001.html>
More information about the ghc-commits
mailing list