diff options
author | Ben Gamari <ben@smart-cactus.org> | 2019-06-04 18:00:59 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2019-06-04 18:00:59 -0400 |
commit | 32ae6b2a23201c3efd1cee5a68edd68f9d45bddf (patch) | |
tree | 04cae982379ad1077566cb12189e7279f2463c3c | |
parent | bbdcc37502d12577b05575d2cf6402c44b26466a (diff) | |
parent | ed73729223dcab4e733ce9e94da8c8d3ea5c8035 (diff) | |
download | haskell-32ae6b2a23201c3efd1cee5a68edd68f9d45bddf.tar.gz |
Merge remote-tracking branch 'osa1/backport_t16066' into wip/ghc-8.8-merges
-rw-r--r-- | compiler/coreSyn/CoreArity.hs | 28 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T16066.hs | 27 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/T16066.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_run/all.T | 1 |
4 files changed, 57 insertions, 2 deletions
diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index 2947518352..927f8cb29f 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -11,7 +11,7 @@ -- | Arity and eta expansion module CoreArity ( manifestArity, joinRhsArity, exprArity, typeArity, - exprEtaExpandArity, findRhsArity, CheapFun, etaExpand, + exprEtaExpandArity, findRhsArity, etaExpand, etaExpandToJoinPoint, etaExpandToJoinPointRule, exprBotStrictness_maybe ) where @@ -704,6 +704,28 @@ lambda wasn't one-shot we don't want to do this. So we combine the best of the two branches, on the (slightly dodgy) basis that if we know one branch is one-shot, then they all must be. + +Note [Arity trimming] +~~~~~~~~~~~~~~~~~~~~~ +Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and +F is some type family. + +Because of Note [exprArity invariant], item (2), we must return with arity at +most 1, because typeArity (Int -> F a) = 1. So we have to trim the result of +calling arityType on (\x y. blah). Failing to do so, and hence breaking the +exprArity invariant, led to #5441. + +How to trim? For ATop, it's easy. But we must take great care with ABot. +Suppose the expression was (\x y. error "urk"), we'll get (ABot 2). We +absolutely must not trim that to (ABot 1), because that claims that +((\x y. error "urk") |> co) diverges when given one argument, which it +absolutely does not. And Bad Things happen if we think something returns bottom +when it doesn't (#16066). + +So, do not reduce the 'n' in (ABot n); rather, switch (conservatively) to ATop. + +Historical note: long ago, we unconditionally switched to ATop when we +encountered a cast, but that is far too conservative: see #5475 -} --------------------------- @@ -722,7 +744,9 @@ arityType :: ArityEnv -> CoreExpr -> ArityType arityType env (Cast e co) = case arityType env e of ATop os -> ATop (take co_arity os) - ABot n -> ABot (n `min` co_arity) + -- See Note [Arity trimming] + ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo) + | otherwise -> ABot n where co_arity = length (typeArity (pSnd (coercionKind co))) -- See Note [exprArity invariant] (2); must be true of diff --git a/testsuite/tests/simplCore/should_run/T16066.hs b/testsuite/tests/simplCore/should_run/T16066.hs new file mode 100644 index 0000000000..3a1f44084e --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T16066.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Main (main) where + +import Control.Monad (join) +import Control.Monad.Reader (ReaderT(..)) +import Control.Concurrent.STM (STM, atomically) +import Data.Kind (Type) + +class Monad (Transaction m) => MonadPersist m where + type Transaction m :: Type -> Type + atomicTransaction :: Transaction m y -> m y + +instance MonadPersist (ReaderT () IO) where + type Transaction (ReaderT () IO) = ReaderT () STM + atomicTransaction act = ReaderT (atomically . runReaderT act) + +main :: IO () +main = join (runReaderT doPure2 ()) >>= \x -> seq x (return ()) + +doPure2 :: MonadPersist m => m (IO ()) +doPure2 = atomicTransaction $ do + () <- pure () + () <- pure () + error "exit never happens" diff --git a/testsuite/tests/simplCore/should_run/T16066.stderr b/testsuite/tests/simplCore/should_run/T16066.stderr new file mode 100644 index 0000000000..85cfbabec1 --- /dev/null +++ b/testsuite/tests/simplCore/should_run/T16066.stderr @@ -0,0 +1,3 @@ +T16066: exit never happens +CallStack (from HasCallStack): + error, called at T16066.hs:31:3 in main:Main diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T index 0a74c628c7..f8614b0001 100644 --- a/testsuite/tests/simplCore/should_run/all.T +++ b/testsuite/tests/simplCore/should_run/all.T @@ -87,3 +87,4 @@ test('T14894', [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(1 test('T14965', normal, compile_and_run, ['']) test('T15114', only_ways('optasm'), compile_and_run, ['']) test('T15436', normal, compile_and_run, ['']) +test('T16066', exit_code(1), compile_and_run, ['-O1']) |