summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndreas Klebinger <klebinger.andreas@gmx.at>2020-02-06 15:11:21 +0100
committerAndreas Klebinger <klebinger.andreas@gmx.at>2020-02-18 15:22:18 +0100
commitb0f28fa91610cf009e32560fb75cda29e2978531 (patch)
tree84cd2fe80308332249178cedb717ef3d1b0cda7b
parentf0c0ee7d9a942a19361e72553cd08f42cc12b04a (diff)
downloadhaskell-wip/andreask/T17724_occ_only.tar.gz
Fix #17724 by having occAnal preserve used bindings.wip/andreask/T17724_occ_only
It sometimes happened that occAnal would remove bindings as dead code by relying on bindings to be in dependency order. The fix was contributed by SPJ.
-rw-r--r--compiler/simplCore/OccurAnal.hs7
-rw-r--r--testsuite/tests/simplCore/should_compile/T17722A.hs20
-rw-r--r--testsuite/tests/simplCore/should_compile/T17722B.hs73
-rw-r--r--testsuite/tests/simplCore/should_compile/T17724.hs26
-rw-r--r--testsuite/tests/simplCore/should_compile/all.T2
5 files changed, 127 insertions, 1 deletions
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index 96ee9623c3..47460178f1 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -81,11 +81,16 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
(final_usage, occ_anald_binds) = go init_env binds
(_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel
imp_rule_edges
- (flattenBinds occ_anald_binds)
+ (flattenBinds binds)
initial_uds
-- It's crucial to re-analyse the glommed-together bindings
-- so that we establish the right loop breakers. Otherwise
-- we can easily create an infinite loop (#9583 is an example)
+ --
+ -- Also crucial to re-analyse the /original/ bindings
+ -- in case the first pass accidentally discarded as dead code
+ -- a binding that was actually needed (albeit before its
+ -- definition site). #17724 threw this up.
initial_uds = addManyOccsSet emptyDetails
(rulesFreeVars imp_rules)
diff --git a/testsuite/tests/simplCore/should_compile/T17722A.hs b/testsuite/tests/simplCore/should_compile/T17722A.hs
new file mode 100644
index 0000000000..2a37163afa
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17722A.hs
@@ -0,0 +1,20 @@
+module T17722A (Validation(..)) where
+
+data Validation e a
+ = Failure e
+ | Success a
+
+instance Functor (Validation e) where
+ fmap _ (Failure e) = Failure e
+ fmap f (Success a) = Success (f a)
+
+(<.>) :: Semigroup e => Validation e (t -> a) -> Validation e t -> Validation e a
+Failure e1 <.> b = Failure $ case b of
+ Failure e2 -> e1 <> e2
+ Success _ -> e1
+Success _ <.> Failure e = Failure e
+Success f <.> Success x = Success (f x)
+
+instance Semigroup e => Applicative (Validation e) where
+ pure = Success
+ (<*>) = (<.>)
diff --git a/testsuite/tests/simplCore/should_compile/T17722B.hs b/testsuite/tests/simplCore/should_compile/T17722B.hs
new file mode 100644
index 0000000000..ffcf5c9203
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17722B.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module T17722B (setHelper) where
+
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Sequence (Seq)
+import Data.Text (Text)
+import Data.Void (Void)
+import qualified Data.Foldable
+import qualified Data.List
+import qualified Data.Sequence
+import qualified Data.Text
+
+import T17722A
+
+data Expr s a
+ = App (Expr s a) (Expr s a)
+ | List
+ | ListLit (Maybe (Expr s a)) (Seq (Expr s a))
+
+data Src
+
+type Extractor s a = Validation (ExtractErrors s a)
+
+typeError :: Expr s a -> Expr s a -> Extractor s a b
+typeError expected actual =
+ Failure . ExtractErrors . pure . TypeMismatch $ InvalidDecoder expected actual
+
+extractError :: Text -> Extractor s a b
+extractError = Failure . ExtractErrors . pure . ExtractError
+
+newtype ExtractErrors s a = ExtractErrors (NonEmpty (ExtractError s a))
+ deriving Semigroup
+
+data ExtractError s a =
+ TypeMismatch (InvalidDecoder s a)
+ | ExtractError Text
+
+data InvalidDecoder s a = InvalidDecoder (Expr s a) (Expr s a)
+
+data Decoder a = Decoder
+ (Expr Src Void -> Extractor Src Void a)
+ (Expr Src Void)
+
+setHelper :: (Eq a, Foldable t, Show a)
+ => (t a -> Int)
+ -> ([a] -> t a)
+ -> Decoder a
+ -> Decoder (t a)
+setHelper size toSet (Decoder extractIn expectedIn) = Decoder extractOut expectedOut
+ where
+ extractOut (ListLit _ es) = case traverse extractIn es of
+ Success vSeq
+ | sameSize -> Success vSet
+ | otherwise -> extractError err
+ where
+ vList = Data.Foldable.toList vSeq
+ vSet = toSet vList
+ sameSize = size vSet == Data.Sequence.length vSeq
+ duplicates = vList Data.List.\\ Data.Foldable.toList vSet
+ err | length duplicates == 1 =
+ "One duplicate element in the list: "
+ <> (Data.Text.pack $ show $ head duplicates)
+ | otherwise = Data.Text.pack $ unwords
+ [ show $ length duplicates
+ , "duplicates were found in the list, including"
+ , show $ head duplicates
+ ]
+ Failure f -> Failure f
+ extractOut expr = typeError expectedOut expr
+
+ expectedOut = App List expectedIn
diff --git a/testsuite/tests/simplCore/should_compile/T17724.hs b/testsuite/tests/simplCore/should_compile/T17724.hs
new file mode 100644
index 0000000000..a514a7f305
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17724.hs
@@ -0,0 +1,26 @@
+-- The CSE pass implicitly requires bindings to be in argument order
+-- or things can go wrong. This was the case in this example.
+-- This code is extracted from containers' sequence-benchmarks and the gauge
+-- package.
+{-# language ExistentialQuantification #-}
+
+module T17724 where
+
+import Control.Exception (evaluate)
+
+data Benchmarkable = forall a .
+ Benchmarkable
+ { allocEnv :: Int -> IO a
+ , runRepeatedly :: a -> Int -> IO ()
+ }
+
+a, b :: Benchmarkable
+a = nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (100,2500)
+b = nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (2500,100)
+
+nf :: (a -> b) -> a -> Benchmarkable
+nf f0 x0 = Benchmarkable (const (return ())) (const (go f0 x0))
+ where go f x n
+ | n <= 0 = return ()
+ | otherwise = evaluate (f x) >> go f x (n-1)
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 7146b76e6d..8177520e3e 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -312,3 +312,5 @@ test('T17409',
normal,
makefile_test, ['T17409'])
test('T17429', normal, compile, ['-dcore-lint -O2'])
+test('T17722', normal, multimod_compile, ['T17722B', '-dcore-lint -O2 -v0'])
+test('T17724', normal, compile, ['-dcore-lint -O2'])