summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2021-03-23 22:44:12 +0000
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-03-24 23:31:44 -0400
commitaa99f516431745c5b9261db56a5ef4a3b333ce8c (patch)
treeb4bb0dfefec61b4471d0797a860c5ea55252f852
parent5483b1a4f183026aab475da59d010d579c036592 (diff)
downloadhaskell-aa99f516431745c5b9261db56a5ef4a3b333ce8c.tar.gz
Fix the binder-swap transformation in OccurAnal
The binder-swap transformation needs to be iterated, as shown by #19581. The fix is pretty simple, and is explained in point (BS2) of Note [The binder-swap substitution]. Net effect: - sometimes, fewer simplifier iterations - sometimes, more case merging
-rw-r--r--compiler/GHC/Core/Opt/OccurAnal.hs163
-rw-r--r--compiler/GHC/Core/TyCo/FVs.hs6
-rw-r--r--testsuite/tests/simplCore/should_compile/T19581.hs38
-rw-r--r--testsuite/tests/simplCore/should_compile/T19581.stderr77
-rw-r--r--testsuite/tests/simplCore/should_compile/all.T3
5 files changed, 234 insertions, 53 deletions
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index d8796caa6e..3861b3e462 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -37,6 +37,7 @@ import GHC.Types.Tickish
import GHC.Unit.Module( Module )
import GHC.Core.Coercion
import GHC.Core.Type
+import GHC.Core.TyCo.FVs( tyCoVarsOfMCo )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
@@ -50,7 +51,7 @@ import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Utils.Misc
-import GHC.Data.Maybe( orElse, isJust )
+import GHC.Data.Maybe( isJust )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.List (mapAccumL, mapAccumR)
@@ -2073,14 +2074,15 @@ occAnalApp env (Var fun, args, ticks)
, let (usage, arg') = occAnalRhs env NonRecursive (Just 1) arg
= (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])
-occAnalApp env (Var fun, args, ticks)
+occAnalApp env (Var fun_id, args, ticks)
= (all_uds, mkTicks ticks $ mkApps fun' args')
where
- (fun', fun_id') = lookupVarEnv (occ_bs_env env) fun
- `orElse` (Var fun, fun)
- -- See Note [The binder-swap substitution]
+ (fun', fun_id') = lookupBndrSwap env fun_id
fun_uds = mkOneOcc fun_id' int_cxt n_args
+ -- NB: fun_uds is computed for fun_id', not fun_id
+ -- See (BS1) in Note [The binder-swap substitution]
+
all_uds = fun_uds `andUDs` final_args_uds
!(args_uds, args') = occAnalArgs env args one_shots
@@ -2104,11 +2106,11 @@ occAnalApp env (Var fun, args, ticks)
_other | n_val_args > 0 -> IsInteresting
| otherwise -> NotInteresting
- is_exp = isExpandableApp fun n_val_args
+ is_exp = isExpandableApp fun_id n_val_args
-- See Note [CONLIKE pragma] in GHC.Types.Basic
-- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs
- one_shots = argsOneShots (idStrictness fun) guaranteed_val_args
+ one_shots = argsOneShots (idStrictness fun_id) guaranteed_val_args
guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo
(occ_one_shots env))
-- See Note [Sources of one-shot information], bullet point A']
@@ -2267,7 +2269,10 @@ data OccEnv
-- See Note [Finding rule RHS free vars]
-- See Note [The binder-swap substitution]
- , occ_bs_env :: VarEnv (OutExpr, OutId)
+ -- If x :-> (y, co) is in the env,
+ -- then please replace x by (y |> sym mco)
+ -- Invariant of course: idType x = exprType (y |> sym mco)
+ , occ_bs_env :: VarEnv (OutId, MCoercion)
, occ_bs_rng :: VarSet -- Vars free in the range of occ_bs_env
-- Domain is Global and Local Ids
-- Range is just Local Ids
@@ -2515,46 +2520,76 @@ I think this is just too bad. CSE will recover some of it.
Note [The binder-swap substitution]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The binder-swap is implemented by the occ_bs_env field of OccEnv.
-Given case x |> co of b { alts }
-we add [x :-> (b |> sym co)] to the occ_bs_env environment; this is
-done by addBndrSwap. Then, at an occurrence of a variable, we look
-up in the occ_bs_env to perform the swap. See occAnalApp.
-
-Some tricky corners:
-
-* We do the substitution before gathering occurrence info. So in
- the above example, an occurrence of x turns into an occurrence
- of b, and that's what we gather in the UsageDetails. It's as
- if the binder-swap occurred before occurrence analysis.
-
-* We need care when shadowing. Suppose [x :-> b] is in occ_bs_env,
- and we encounter:
- - \x. blah
- Here we want to delete the x-binding from occ_bs_env
-
- - \b. blah
- This is harder: we really want to delete all bindings that
- have 'b' free in the range. That is a bit tiresome to implement,
- so we compromise. We keep occ_bs_rng, which is the set of
- free vars of rng(occc_bs_env). If a binder shadows any of these
- variables, we discard all of occ_bs_env. Safe, if a bit
- brutal. NB, however: the simplifer de-shadows the code, so the
- next time around this won't happen.
+There are two main pieces:
- These checks are implemented in addInScope.
+* Given case x |> co of b { alts }
+ we add [x :-> (b, co)] to the occ_bs_env environment; this is
+ done by addBndrSwap.
-* The occurrence analyser itself does /not/ do cloning. It could, in
- principle, but it'd make it a bit more complicated and there is no
- great benefit. The simplifer uses cloning to get a no-shadowing
- situation, the care-when-shadowing behaviour above isn't needed for
- long.
+* Then, at an occurrence of a variable, we look up in the occ_bs_env
+ to perform the swap. This is done by lookupBndrSwap.
-* The domain of occ_bs_env can include GlobaIds. Eg
- case M.foo of b { alts }
- We extend occ_bs_env with [M.foo :-> b]. That's fine.
+Some tricky corners:
-* We have to apply the substitution uniformly, including to rules and
- unfoldings.
+(BS1) We do the substitution before gathering occurrence info. So in
+ the above example, an occurrence of x turns into an occurrence
+ of b, and that's what we gather in the UsageDetails. It's as
+ if the binder-swap occurred before occurrence analysis. See
+ the computation of fun_uds in occAnalApp.
+
+(BS2) When doing a lookup in occ_bs_env, we may need to iterate,
+ as you can see implemented in lookupBndrSwap. Why?
+ Consider case x of a { 1# -> e1; DEFAULT ->
+ case x of b { 2# -> e2; DEFAULT ->
+ case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}}
+ At the first case addBndrSwap will extend occ_bs_env with
+ [x :-> a]
+ At the second case we occ-anal the scrutinee 'x', which looks up
+ 'x in occ_bs_env, returning 'a', as it should.
+ Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding
+ occ_bs_env = [x :-> a, a :-> b]
+ At the third case we'll again look up 'x' which returns 'a'.
+ But we don't want to stop the lookup there, else we'll end up with
+ case x of a { 1# -> e1; DEFAULT ->
+ case a of b { 2# -> e2; DEFAULT ->
+ case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}}
+ Instead, we want iterate the lookup in addBndrSwap, to give
+ case x of a { 1# -> e1; DEFAULT ->
+ case a of b { 2# -> e2; DEFAULT ->
+ case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}}
+ This makes a particular difference for case-merge, which works
+ only if the scrutinee is the case-binder of the immediately enclosing
+ case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils
+ See #19581 for the bug report that showed this up.
+
+(BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env,
+ and we encounter:
+ - \x. blah
+ Here we want to delete the x-binding from occ_bs_env
+
+ - \b. blah
+ This is harder: we really want to delete all bindings that
+ have 'b' free in the range. That is a bit tiresome to implement,
+ so we compromise. We keep occ_bs_rng, which is the set of
+ free vars of rng(occc_bs_env). If a binder shadows any of these
+ variables, we discard all of occ_bs_env. Safe, if a bit
+ brutal. NB, however: the simplifer de-shadows the code, so the
+ next time around this won't happen.
+
+ These checks are implemented in addInScope.
+
+ The occurrence analyser itself does /not/ do cloning. It could, in
+ principle, but it'd make it a bit more complicated and there is no
+ great benefit. The simplifer uses cloning to get a no-shadowing
+ situation, the care-when-shadowing behaviour above isn't needed for
+ long.
+
+(BS4) The domain of occ_bs_env can include GlobaIds. Eg
+ case M.foo of b { alts }
+ We extend occ_bs_env with [M.foo :-> b]. That's fine.
+
+(BS5) We have to apply the occ_bs_env substitution uniformly,
+ including to (local) rules and unfoldings.
Historical note
---------------
@@ -2669,22 +2704,46 @@ addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv
-- See Note [The binder-swap substitution]
addBndrSwap scrut case_bndr
env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })
- | Just (v, rhs) <- try_swap (stripTicksTopE (const True) scrut)
- = env { occ_bs_env = extendVarEnv swap_env v (rhs, case_bndr')
- , occ_bs_rng = rng_vars `unionVarSet` exprFreeVars rhs }
+ | Just (scrut_var, mco) <- get_scrut_var (stripTicksTopE (const True) scrut)
+ , scrut_var /= case_bndr
+ -- Consider: case x of x { ... }
+ -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop
+ = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)
+ , occ_bs_rng = rng_vars `extendVarSet` case_bndr'
+ `unionVarSet` tyCoVarsOfMCo mco }
| otherwise
= env
where
- try_swap :: OutExpr -> Maybe (OutVar, OutExpr)
- try_swap (Var v) = Just (v, Var case_bndr')
- try_swap (Cast (Var v) co) = Just (v, Cast (Var case_bndr') (mkSymCo co))
- -- See Note [Case of cast]
- try_swap _ = Nothing
+ get_scrut_var :: OutExpr -> Maybe (OutVar, MCoercion)
+ get_scrut_var (Var v) = Just (v, MRefl)
+ get_scrut_var (Cast (Var v) co) = Just (v, MCo co) -- See Note [Case of cast]
+ get_scrut_var _ = Nothing
case_bndr' = zapIdOccInfo case_bndr
-- See Note [Zap case binders in proxy bindings]
+lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)
+-- See Note [The binder-swap substitution]
+-- Returns an expression of the same type as Id
+lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env }) bndr
+ = case lookupVarEnv bs_env bndr of {
+ Nothing -> (Var bndr, bndr) ;
+ Just (bndr1, mco) ->
+
+ -- Why do we iterate here?
+ -- See (BS2) in Note [The binder-swap substitution]
+ case lookupBndrSwap env bndr1 of
+ (fun, fun_id) -> (add_cast fun mco, fun_id) }
+
+ where
+ add_cast fun MRefl = fun
+ add_cast fun (MCo co) = Cast fun (mkSymCo co)
+ -- We must switch that 'co' to 'sym co';
+ -- see the comment with occ_bs_env
+ -- No need to test for isReflCo, because 'co' came from
+ -- a (Cast e co) and hence is unlikely to be Refl
+
{-
************************************************************************
* *
diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs
index c8a7506363..73ff22c85b 100644
--- a/compiler/GHC/Core/TyCo/FVs.hs
+++ b/compiler/GHC/Core/TyCo/FVs.hs
@@ -13,7 +13,7 @@ module GHC.Core.TyCo.FVs
shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv,
shallowTyCoVarsOfCo, shallowTyCoVarsOfCos,
- tyCoVarsOfCo, tyCoVarsOfCos,
+ tyCoVarsOfCo, tyCoVarsOfCos, tyCoVarsOfMCo,
coVarsOfType, coVarsOfTypes,
coVarsOfCo, coVarsOfCos,
tyCoVarsOfCoDSet,
@@ -291,6 +291,10 @@ tyCoVarsOfCo :: Coercion -> TyCoVarSet
-- See Note [Free variables of Coercions]
tyCoVarsOfCo co = runTyCoVars (deep_co co)
+tyCoVarsOfMCo :: MCoercion -> TyCoVarSet
+tyCoVarsOfMCo MRefl = emptyVarSet
+tyCoVarsOfMCo (MCo co) = tyCoVarsOfCo co
+
tyCoVarsOfCos :: [Coercion] -> TyCoVarSet
tyCoVarsOfCos cos = runTyCoVars (deep_cos cos)
diff --git a/testsuite/tests/simplCore/should_compile/T19581.hs b/testsuite/tests/simplCore/should_compile/T19581.hs
new file mode 100644
index 0000000000..448ce349d6
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19581.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE MagicHash #-}
+
+module Foo where
+
+import GHC.Exts
+
+g :: Int# -> Int#
+{-# NOINLINE g #-}
+g x = x +# 1#
+
+-- Setting up this test case is quite delicate.
+--
+-- With the code below, simplification terminates too early.
+--
+-- Removing either of the (g (x +# 1#)) cases makes successively
+-- merge 2 layers at a time, so it takes multiple iterations to
+-- get a fixpoint.
+
+f :: Int# -> Int#
+f x = case g x of {
+ 1# -> 2# ; _ ->
+
+ case g (x +# 1#) of { z ->
+
+ case g x of {
+ 2# -> z ; _ ->
+
+ case g (x +# 2#) of { z1 ->
+
+ case g x of {
+ 3# -> 4#; _ -> case g x of {
+ 4# -> z; _ -> case g x of {
+ 5# -> 6#; _ -> case g x of {
+ 6# -> z; _ -> case g x of {
+ 7# -> 8#; _ -> case g x of {
+ 8# -> 9#; _ -> case g x of {
+ 9# -> 10#; _ -> 6#
+ }}}}}}}}}}}
diff --git a/testsuite/tests/simplCore/should_compile/T19581.stderr b/testsuite/tests/simplCore/should_compile/T19581.stderr
new file mode 100644
index 0000000000..683e67d3c4
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T19581.stderr
@@ -0,0 +1,77 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 60, types: 16, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0}
+g [InlPrag=NOINLINE] :: Int# -> Int#
+[GblId, Arity=1, Str=<L>, Unf=OtherCon []]
+g = \ (x :: Int#) -> +# x 1#
+
+-- RHS size: {terms: 40, types: 6, coercions: 0, joins: 0/0}
+f :: Int# -> Int#
+[GblId,
+ Arity=1,
+ Str=<L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 192 0}]
+f = \ (x :: Int#) ->
+ case g x of ds {
+ __DEFAULT ->
+ case g (+# x 1#) of z { __DEFAULT ->
+ case ds of ds1 {
+ __DEFAULT ->
+ case g (+# x 2#) of { __DEFAULT ->
+ case ds1 of {
+ __DEFAULT -> 6#;
+ 3# -> 4#;
+ 4# -> z;
+ 6# -> z;
+ 7# -> 8#;
+ 8# -> 9#;
+ 9# -> 10#
+ }
+ };
+ 2# -> z
+ }
+ };
+ 1# -> 2#
+ }
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Foo.$trModule4 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Foo.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Foo.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Foo.$trModule3 = GHC.Types.TrNameS Foo.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+Foo.$trModule2 :: Addr#
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Foo.$trModule2 = "Foo"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+Foo.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Foo.$trModule1 = GHC.Types.TrNameS Foo.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+Foo.$trModule :: GHC.Types.Module
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+Foo.$trModule = GHC.Types.Module Foo.$trModule3 Foo.$trModule1
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index a2783f33e1..23058c2cd8 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -347,3 +347,6 @@ test('T18995', [ grep_errmsg(r'print') ], compile, ['-O -ddump-simpl -dsuppress-
test('T19168', normal, compile, [''])
test('T19246', only_ways(['optasm']), multimod_compile, ['T19246', '-v0 -ddump-rules'])
test('T19360', only_ways(['optasm']), compile, [''])
+
+# If the test goes wrong we'll get more case expressions in the output
+test('T19581', [ grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])