[Git][ghc/ghc][wip/T24251a] Wibbles, and add test
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Mar 22 17:09:02 UTC 2024
Simon Peyton Jones pushed to branch wip/T24251a at Glasgow Haskell Compiler / GHC
Commits:
91f2e3fc by Simon Peyton Jones at 2024-03-22T17:08:48+00:00
Wibbles, and add test
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/CSE.hs
- + testsuite/tests/simplCore/should_compile/T24251a.hs
- + testsuite/tests/simplCore/should_compile/T24251a.stderr
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -15,12 +15,12 @@ import GHC.Types.Id ( Id, idType, idHasRules, zapStableUnfolding
, idInlineActivation, setInlineActivation
, zapIdOccInfo, zapIdUsageInfo, idInlinePragma
, isJoinId, idJoinPointHood, idUnfolding, isDeadBinder )
-import GHC.Core.Utils ( mkAltExpr, exprIsTrivial
- , exprIsTickedString
+import GHC.Core.Utils ( mkAltExpr, exprIsTickedString
, stripTicksE, stripTicksT, mkTicks )
import GHC.Core.FVs ( exprFreeVars )
import GHC.Core.Type ( tyConAppArgs )
import GHC.Core
+import GHC.Core.Opt.OccurAnal( scrutBinderSwap_maybe )
import GHC.Utils.Outputable
import GHC.Types.Basic
import GHC.Types.Tickish
@@ -714,25 +714,31 @@ cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
cseCase env scrut bndr ty alts
- = mkCase scrut1 bndr3 ty' $
- combineAlts (map cse_alt alts)
+ | Just body' <- caseElim scrut' bndr' alts'
+ = Let (NonRec bndr' scrut') body'
+
+ | otherwise
+ = Case scrut' bndr' ty' alts'
+
where
ty' = substTyUnchecked (csEnvSubst env) ty
- (cse_done, scrut1) = try_for_cse env scrut
+ (cse_done, scrut') = try_for_cse env scrut
bndr1 = zapIdOccInfo bndr
-- Zapping the OccInfo is needed because the extendCSEnv
-- in cse_alt may mean that a dead case binder
-- becomes alive, and Lint rejects that
(env1, bndr2) = addBinder env bndr1
- (alt_env, bndr3) = extendCSEnvWithBinding env1 bndr bndr2 scrut1 cse_done
+ (alt_env, bndr') = extendCSEnvWithBinding env1 bndr bndr2 scrut' cse_done
-- extendCSEnvWithBinding: see Note [CSE for case expressions]
+ alts' = combineAlts (map cse_alt alts)
+
con_target :: OutExpr
con_target = lookupSubst alt_env bndr
arg_tys :: [OutType]
- arg_tys = tyConAppArgs (idType bndr3)
+ arg_tys = tyConAppArgs (idType bndr')
-- See Note [CSE for case alternatives]
cse_alt (Alt (DataAlt con) args rhs)
@@ -747,36 +753,43 @@ cseCase env scrut bndr ty alts
where
(env', args') = addBinders alt_env args
-mkCase :: OutExpr -> OutId -> OutType -> [OutAlt] -> OutExpr
--- Smart constructor for Case; see
+caseElim :: OutExpr -> OutId -> [OutAlt] -> Maybe OutExpr
+-- Can we eliminate the case altogether? If so return the body.
-- Note [Eliminating redundant cases]
-mkCase scrut bndr ty alts
+caseElim scrut case_bndr alts
| [Alt _ bndrs rhs] <- alts
- , exprIsTrivial scrut
+ , Just (scrut_var, _) <- scrutBinderSwap_maybe scrut
, all isDeadBinder bndrs
- , isEvaldSoon bndr rhs
- = Let (NonRec bndr scrut) rhs
+ , isEvaldSoon (scrut_var, case_bndr) rhs
+ = Just rhs
| otherwise
- = Case scrut bndr ty alts
+ = Nothing
-isEvaldSoon :: InId -> InExpr -> Bool
--- (isEvaldSoon b e) is True is evaluated soon by e
-isEvaldSoon bndr expr
+isEvaldSoon :: (OutId, OutId) -> OutExpr -> Bool
+-- (isEvaldSoon (v1,v2) e) is True if either v1 or v2 is evaluated "soon" by e
+isEvaldSoon (v1,v2) expr
= go expr
where
- go (Var v) = v==bndr
- go (Case scrut cb _ alts)
- | Var v <- scrut, v==bndr = True
- | otherwise = all go_alt alts && cb /= bndr && all ok_alt alts
- -- ok_alt only runs if things look good
+ hit :: Var -> Bool
+ hit v = v==v1 || v==v2
+
+ go (Var v) = hit v
go (Let _ e) = go e
go (Tick _ e) = go e
go (Cast e _) = go e
- go _ = False
+
+ go (Case scrut cb _ alts)
+ = go scrut ||
+ (all go_alt alts &&
+ not (hit cb) && -- Check for
+ all ok_alt alts) -- shadowing
+ -- ok_alt only runs if things look good
+
+ go _ = False -- Lit, App, Lam, Coercion, Type
go_alt (Alt _ _ rhs) = go rhs
- ok_alt (Alt _ cbs _) = not (bndr `elem` cbs)
+ ok_alt (Alt _ cbs _) = not (any hit cbs)
combineAlts :: [OutAlt] -> [OutAlt]
-- See Note [Combine case alternatives]
=====================================
testsuite/tests/simplCore/should_compile/T24251a.hs
=====================================
@@ -0,0 +1,9 @@
+module T24251a where
+
+f xs = xs `seq`
+ (let t = reverse (reverse (reverse (reverse xs))) in
+ case xs of
+ [] -> (t,True)
+ (_:_) -> (t,False))
+
+-- We start with an eval of xs, but that should disappear.
=====================================
testsuite/tests/simplCore/should_compile/T24251a.stderr
=====================================
@@ -0,0 +1,18 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 33, types: 60, coercions: 0, joins: 0/1}
+
+$wf
+ = \ @a xs ->
+ let {
+ t = reverse1 (reverse1 (reverse1 (reverse1 xs []) []) []) [] } in
+ case xs of {
+ [] -> (# t, True #);
+ : ds ds1 -> (# t, False #)
+ }
+
+f = \ @a xs -> case $wf xs of { (# ww, ww1 #) -> (ww, ww1) }
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -515,3 +515,4 @@ test('T24229a', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typea
test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques -dppr-cols=99999'])
test('T24370', normal, compile, ['-O'])
test('T24551', normal, compile, ['-O -dcore-lint'])
+test('T24251a', normal, compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds -dsuppress-all'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91f2e3fc4de5305ef45c74e960fdd3331e00afc2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/91f2e3fc4de5305ef45c74e960fdd3331e00afc2
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/20240322/343e78d8/attachment-0001.html>
More information about the ghc-commits
mailing list