diff options
| -rw-r--r-- | compiler/GHC/Stg/CSE.hs | 116 | ||||
| -rw-r--r-- | testsuite/tests/simplStg/should_compile/T19717.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/simplStg/should_compile/T19717.stderr | 19 | ||||
| -rw-r--r-- | testsuite/tests/simplStg/should_compile/all.T | 1 |
4 files changed, 119 insertions, 23 deletions
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index bc266d20ba..01d1c4b518 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -203,19 +203,46 @@ initEnv in_scope = CseEnv , ce_in_scope = in_scope } +------------------- +normaliseConArgs :: CseEnv -> [OutStgArg] -> [OutStgArg] +-- See Note [Trivial case scrutinee] +normaliseConArgs env args + = map go args + where + bndr_map = ce_bndrMap env + go (StgVarArg v ) = StgVarArg (normaliseId bndr_map v) + go (StgLitArg lit) = StgLitArg lit + +normaliseId :: IdEnv OutId -> OutId -> OutId +normaliseId bndr_map v = case lookupVarEnv bndr_map v of + Just v' -> v' + Nothing -> v + +addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv +-- See Note [Trivial case scrutinee] +addTrivCaseBndr from to env + = env { ce_bndrMap = extendVarEnv bndr_map from norm_to } + where + bndr_map = ce_bndrMap env + norm_to = normaliseId bndr_map to + envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId -envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env) - where args' = map go args -- See Note [Trivial case scrutinee] - go (StgVarArg v ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v) - go (StgLitArg lit) = StgLitArg lit +envLookup dataCon args env + = lookupTM (dataCon, normaliseConArgs env args) + (ce_conAppMap env) + -- normaliseConArgs: See Note [Trivial case scrutinee] addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv --- do not bother with nullary data constructors, they are static anyways +-- Do not bother with nullary data constructors; they are static anyway addDataCon _ _ [] env = env -addDataCon bndr dataCon args env = env { ce_conAppMap = new_env } +addDataCon bndr dataCon args env + = env { ce_conAppMap = new_env } where - new_env = insertTM (dataCon, args) bndr (ce_conAppMap env) + new_env = insertTM (dataCon, normaliseConArgs env args) + bndr (ce_conAppMap env) + -- normaliseConArgs: See Note [Trivial case scrutinee] +------------------- forgetCse :: CseEnv -> CseEnv forgetCse env = env { ce_conAppMap = emptyTM } -- See note [Free variables of an StgClosure] @@ -224,10 +251,6 @@ addSubst :: OutId -> OutId -> CseEnv -> CseEnv addSubst from to env = env { ce_subst = extendVarEnv (ce_subst env) from to } -addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv -addTrivCaseBndr from to env - = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to } - substArgs :: CseEnv -> [InStgArg] -> [OutStgArg] substArgs env = map (substArg env) @@ -318,9 +341,11 @@ stgCseExpr env (StgCase scrut bndr ty alts) where scrut' = stgCseExpr env scrut (env1, bndr') = substBndr env bndr - env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1 + env2 | StgApp trivial_scrut [] <- scrut' + = addTrivCaseBndr bndr trivial_scrut env1 -- See Note [Trivial case scrutinee] - | otherwise = env1 + | otherwise + = env1 alts' = map (stgCseAlt env2 ty bndr') alts @@ -468,25 +493,70 @@ we can. Note [Trivial case scrutinee] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to be able to handle nested reconstruction of constructors as in +We want to be able to CSE nested reconstruction of constructors as in nested :: Either Int (Either Int a) -> Either Bool (Either Bool a) nested (Right (Right v)) = Right (Right v) - nested _ = Left True - -So if we come across + nested _ = Left True +We want the RHS of the first branch to be just the original argument. +The RHS of 'nested' will look like case x of r1 Right a -> case a of r2 Right b -> let v = Right b in Right v +Then: +* We create the ce_conAppMap [Right a :-> r1, Right b :-> r2]. +* When we encounter v = Right b, we'll drop the binding and extend + the substitution with [v :-> r2] +* But now when we see (Right v), we'll substitute to get (Right r2)...and + fail to find that in the ce_conAppMap! + +Solution: + +* When passing (case x of bndr { alts }), where 'x' is a variable, we + add [bndr :-> x] to the ce_bndrMap. In our example the ce_bndrMap will + be [r1 :-> x, r2 :-> a]. This is done in addTrivCaseBndr. + +* Before doing the /lookup/ in ce_conAppMap, we "normalise" the + arguments with the ce_bndrMap. In our example, we normalise + (Right r2) to (Right a), and then find it in the map. Normalisation + is done by normaliseConArgs. + +* Similarly before /inserting/ in ce_conAppMap, we normalise the arguments. + This is a bit more subtle. Suppose we have + case x of y + DEFAULT -> let a = Just y + let b = Just y + in ... + We'll have [y :-> x] in the ce_bndrMap. When looking up (Just y) in + the map, we'll normalise it to (Just x). So we'd better normalise + the (Just y) in the defn of 'a', before inserting it! + +* When inserting into cs_bndrMap, we must normalise that too! + case x of y + DEFAULT -> case y of z + DEFAULT -> ... + We want the cs_bndrMap to be [y :-> x, z :-> x]! + Hence the call to normaliseId in addTrivCaseBinder. + +All this is a bit tricky. Why does it not occur for the Core version +of CSE? See Note [CSE for bindings] in GHC.Core.Opt.CSE. The reason +is this: in Core CSE we augment the /main substitution/ with [y :-> x] +etc, so as a side consequence we transform + case x of y ===> case x of y + pat -> ...y... pat -> ...x... +That is, the /exact reverse/ of the binder-swap transformation done by +the occurrence analyser. However, it's easy for CSE to do on-the-fly, +and it completely solves the above tricky problem, using only two maps: +the main reverse-map, and the substitution. The occurrence analyser +puts it back the way it should be, the next time it runs. + +However in STG there is no occurrence analyser, and we don't want to +require another pass. So the ce_bndrMap is a little swizzle that we +apply just when manipulating the ce_conAppMap, but that does not +affect the output program. -we first replace v with r2. Next we want to replace Right r2 with r1. But the -ce_conAppMap contains Right a! - -Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use -this substitution before looking Right r2 up in ce_conAppMap, and everything -works out. Note [Free variables of an StgClosure] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/testsuite/tests/simplStg/should_compile/T19717.hs b/testsuite/tests/simplStg/should_compile/T19717.hs new file mode 100644 index 0000000000..2b485b6464 --- /dev/null +++ b/testsuite/tests/simplStg/should_compile/T19717.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Foo where + + +f x = x `seq` [Just x, Just x] diff --git a/testsuite/tests/simplStg/should_compile/T19717.stderr b/testsuite/tests/simplStg/should_compile/T19717.stderr new file mode 100644 index 0000000000..9dd1e085f8 --- /dev/null +++ b/testsuite/tests/simplStg/should_compile/T19717.stderr @@ -0,0 +1,19 @@ + +==================== Final STG: ==================== +Foo.f :: forall {a}. a -> [GHC.Maybe.Maybe a] +[GblId, Arity=1, Str=<1L>, Cpr=2, Unf=OtherCon []] = + {} \r [x] + case x of x1 { + __DEFAULT -> + let { + sat [Occ=Once1] :: GHC.Maybe.Maybe a + [LclId] = + CCCS GHC.Maybe.Just! [x1]; } in + let { + sat [Occ=Once1] :: [GHC.Maybe.Maybe a] + [LclId] = + CCCS :! [sat GHC.Types.[]]; + } in : [sat sat]; + }; + + diff --git a/testsuite/tests/simplStg/should_compile/all.T b/testsuite/tests/simplStg/should_compile/all.T index bb2e25ed4b..8cc4c49922 100644 --- a/testsuite/tests/simplStg/should_compile/all.T +++ b/testsuite/tests/simplStg/should_compile/all.T @@ -10,3 +10,4 @@ def f( name, opts ): setTestOpts(f) test('T13588', [ grep_errmsg('case') ] , compile, ['-dverbose-stg2stg -fno-worker-wrapper']) +test('T19717', normal, compile, ['-ddump-stg-final -dsuppress-uniques -dno-typeable-binds']) |