[Git][ghc/ghc][master] 2 commits: FloatOut: Only eta-expand dead-end RHS if arity will increase (#18231)
Marge Bot
gitlab at gitlab.haskell.org
Thu May 28 20:25:26 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
10e6982c by Sebastian Graf at 2020-05-28T16:25:14-04:00
FloatOut: Only eta-expand dead-end RHS if arity will increase (#18231)
Otherwise we risk turning trivial RHS into non-trivial RHS, introducing
unnecessary bindings in the next Simplifier run, resulting in more
churn.
Fixes #18231.
- - - - -
08dab5f7 by Sebastian Graf at 2020-05-28T16:25:14-04:00
DmdAnal: Recognise precise exceptions from case alternatives (#18086)
Consider
```hs
m :: IO ()
m = do
putStrLn "foo"
error "bar"
```
`m` (from #18086) always throws a (precise or imprecise) exception or
diverges. Yet demand analysis infers `<L,A>` as demand signature instead
of `<L,A>x` for it.
That's because the demand analyser sees `putStrLn` occuring in a case
scrutinee and decides that it has to `deferAfterPreciseException`,
because `putStrLn` throws a precise exception on some control flow
paths. This will mask the `botDiv` `Divergence`of the single case alt
containing `error` to `topDiv`. Since `putStrLn` has `topDiv` itself,
the final `Divergence` is `topDiv`.
This is easily fixed: `deferAfterPreciseException` works by `lub`ing
with the demand type of a virtual case branch denoting the precise
exceptional control flow. We used `nopDmdType` before, but we can be
more precise and use `exnDmdType`, which is `nopDmdType` with `exnDiv`.
Now the `Divergence` from the case alt will degrade `botDiv` to `exnDiv`
instead of `topDiv`, which combines with the result from the scrutinee
to `exnDiv`, and all is well.
Fixes #18086.
- - - - -
9 changed files:
- compiler/GHC/Core/Opt/FloatOut.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Types/Demand.hs
- + testsuite/tests/simplCore/should_compile/T18231.hs
- + testsuite/tests/simplCore/should_compile/T18231.stderr
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/stranal/sigs/T18086.hs
- + testsuite/tests/stranal/sigs/T18086.stderr
- testsuite/tests/stranal/sigs/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/FloatOut.hs
=====================================
@@ -15,7 +15,7 @@ import GHC.Prelude
import GHC.Core
import GHC.Core.Utils
import GHC.Core.Make
-import GHC.Core.Opt.Arity ( etaExpand )
+import GHC.Core.Opt.Arity ( exprArity, etaExpand )
import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
import GHC.Driver.Session
@@ -221,8 +221,9 @@ floatBind (NonRec (TB var _) rhs)
-- A tiresome hack:
-- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels
- let rhs'' | isDeadEndId var = etaExpand (idArity var) rhs'
- | otherwise = rhs'
+ let rhs'' | isDeadEndId var
+ , exprArity rhs' < idArity var = etaExpand (idArity var) rhs'
+ | otherwise = rhs'
in (fs, rhs_floats, [NonRec var rhs'']) }
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -952,6 +952,9 @@ Tiresomely, though, the simplifier has an invariant that the manifest
arity of the RHS should be the same as the arity; but we can't call
etaExpand during GHC.Core.Opt.SetLevels because it works over a decorated form of
CoreExpr. So we do the eta expansion later, in GHC.Core.Opt.FloatOut.
+But we should only eta-expand if the RHS doesn't already have the right
+exprArity, otherwise we get unnecessary top-level bindings if the RHS was
+trivial after the next run of the Simplifier.
Note [Case MFEs]
~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Types/Demand.hs
=====================================
@@ -1055,11 +1055,19 @@ Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception
(ultimately via raiseIO#), then we must not force 'y', which may fail to
terminate or throw an imprecise exception, until we have performed @foo x s at .
-So we have to 'Demand.deferAfterPreciseException' (which just 'lub's with
-'nopDmdType' to model the exceptional control flow) when @foo x s@
-may throw a precise exception. Motivated by T13380{d,e,f}.
+So we have to 'deferAfterPreciseException' (which 'lub's with 'exnDmdType' to
+model the exceptional control flow) when @foo x s@ may throw a precise
+exception. Motivated by T13380{d,e,f}.
See Note [Which scrutinees may throw precise exceptions] in DmdAnal.
+We have to be careful not to discard dead-end Divergence from case
+alternatives, though (#18086):
+
+ m = putStrLn "foo" >> error "bar"
+
+'m' should still have 'exnDiv', which is why it is not sufficient to lub with
+'nopDmdType' (which has 'topDiv') in 'deferAfterPreciseException'.
+
Historical Note: This used to be called the "IO hack". But that term is rather
a bad fit because
1. It's easily confused with the "State hack", which also affects IO.
@@ -1261,6 +1269,11 @@ isTopDmdType :: DmdType -> Bool
isTopDmdType (DmdType env args div)
= div == topDiv && null args && isEmptyVarEnv env
+-- | The demand type of an unspecified expression that is guaranteed to
+-- throw a (precise or imprecise) exception or diverge.
+exnDmdType :: DmdType
+exnDmdType = DmdType emptyDmdEnv [] exnDiv
+
dmdTypeDepth :: DmdType -> Arity
dmdTypeDepth (DmdType _ ds _) = length ds
@@ -1303,13 +1316,17 @@ splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
splitDmdTy ty@(DmdType _ [] res_ty) = (defaultArgDmd res_ty, ty)
-- | When e is evaluated after executing an IO action that may throw a precise
--- exception, and d is e's demand, then what of this demand should we consider?
--- * We have to kill all strictness demands (i.e. lub with a lazy demand)
--- * We can keep usage information (i.e. lub with an absent demand)
--- * We have to kill definite divergence
+-- exception, we act as if there is an additional control flow path that is
+-- taken if e throws a precise exception. The demand type of this control flow
+-- path
+-- * is lazy and absent ('topDmd') in all free variables and arguments
+-- * has 'exnDiv' 'Divergence' result
+-- So we can simply take a variant of 'nopDmdType', 'exnDmdType'.
+-- Why not 'nopDmdType'? Because then the result of 'e' can never be 'exnDiv'!
+-- That means failure to drop dead-ends, see #18086.
-- See Note [Precise exceptions and strictness analysis]
deferAfterPreciseException :: DmdType -> DmdType
-deferAfterPreciseException d = lubDmdType d nopDmdType
+deferAfterPreciseException = lubDmdType exnDmdType
strictenDmd :: Demand -> CleanDemand
strictenDmd (JD { sd = s, ud = u})
=====================================
testsuite/tests/simplCore/should_compile/T18231.hs
=====================================
@@ -0,0 +1,7 @@
+module T18231 where
+
+import Control.Monad (forever)
+import Control.Monad.Trans.State.Strict
+
+m :: State Int ()
+m = forever $ modify' (+1)
=====================================
testsuite/tests/simplCore/should_compile/T18231.stderr
=====================================
@@ -0,0 +1,40 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core = {terms: 30, types: 22, coercions: 5, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18231.$trModule4 :: GHC.Prim.Addr#
+T18231.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18231.$trModule3 :: GHC.Types.TrName
+T18231.$trModule3 = GHC.Types.TrNameS T18231.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18231.$trModule2 :: GHC.Prim.Addr#
+T18231.$trModule2 = "T18231"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+T18231.$trModule1 :: GHC.Types.TrName
+T18231.$trModule1 = GHC.Types.TrNameS T18231.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T18231.$trModule :: GHC.Types.Module
+T18231.$trModule = GHC.Types.Module T18231.$trModule3 T18231.$trModule1
+
+Rec {
+-- RHS size: {terms: 6, types: 1, coercions: 0, joins: 0/0}
+lvl :: GHC.Prim.Int# -> Data.Functor.Identity.Identity ((), Int)
+lvl = \ (x :: GHC.Prim.Int#) -> T18231.m1 (GHC.Types.I# (GHC.Prim.+# x 1#))
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+T18231.m1 :: Int -> Data.Functor.Identity.Identity ((), Int)
+T18231.m1 = \ (s1 :: Int) -> case s1 of { GHC.Types.I# x -> lvl x }
+end Rec }
+
+-- RHS size: {terms: 1, types: 0, coercions: 5, joins: 0/0}
+m :: State Int ()
+m = T18231.m1 `cast` (Sym (Control.Monad.Trans.State.Strict.N:StateT[0] <Int>_N <Data.Functor.Identity.Identity>_R <()>_N) :: (Int -> Data.Functor.Identity.Identity ((), Int)) ~R# StateT Int Data.Functor.Identity.Identity ())
+
+
+
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -319,3 +319,8 @@ test('T17810', normal, multimod_compile, ['T17810', '-fspecialise-aggressively -
test('T18013', normal, multimod_compile, ['T18013', '-v0 -O'])
test('T18098', normal, compile, ['-dcore-lint -O2'])
test('T18120', normal, compile, ['-dcore-lint -O'])
+
+# Verify that there are only two top-level functions (the rec group of m's cast
+# WW worker m1). Ideally, it would be one, but we fail to inline dead-ending
+# recursive groups due to Note [Bottoming floats].
+test('T18231', [ only_ways(['optasm']), grep_errmsg(r'^[\w\.]+ ::.*->.*') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=99999 -dsuppress-uniques'])
=====================================
testsuite/tests/stranal/sigs/T18086.hs
=====================================
@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -O2 -fforce-recomp #-}
+module T18086 where
+
+import GHC.Stack
+import GHC.Utils.Panic.Plain
+import Control.Exception
+import System.IO.Unsafe
+
+-- Should have strictness signature <L,U>x, emphasis on the exceptional
+-- divergence result.
+m :: IO ()
+m = do
+ putStrLn "foo"
+ error "bar"
+
+-- Dito, just in a more complex scenario (the original reproducer of #18086)
+panic :: String -> a
+panic x = unsafeDupablePerformIO $ do
+ stack <- ccsToStrings =<< getCurrentCCS x
+ if null stack
+ then throw (PlainPanic x)
+ else throw (PlainPanic (x ++ '\n' : renderStack stack))
+
=====================================
testsuite/tests/stranal/sigs/T18086.stderr
=====================================
@@ -0,0 +1,21 @@
+
+==================== Strictness signatures ====================
+T18086.$trModule:
+T18086.m: <L,U>x
+T18086.panic: <L,U>x
+
+
+
+==================== Cpr signatures ====================
+T18086.$trModule:
+T18086.m: b
+T18086.panic:
+
+
+
+==================== Strictness signatures ====================
+T18086.$trModule:
+T18086.m: <L,U>x
+T18086.panic: <L,U>x
+
+
=====================================
testsuite/tests/stranal/sigs/all.T
=====================================
@@ -22,3 +22,4 @@ test('T5075', normal, compile, [''])
test('T17932', normal, compile, [''])
test('T13380c', expect_broken('!3014'), compile, [''])
test('T13380f', normal, compile, [''])
+test('T18086', normal, compile, ['-package ghc'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc5f004c4dc27d78d3415adc54e9b6694b865145...08dab5f74e021ad054112cc5f6bb7e55d8796cd7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dc5f004c4dc27d78d3415adc54e9b6694b865145...08dab5f74e021ad054112cc5f6bb7e55d8796cd7
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/20200528/8e5f961f/attachment-0001.html>
More information about the ghc-commits
mailing list