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.

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'])