Fix #17724 by having occAnal preserve used bindings.

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 4ec89337ea..bd512897a7 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'])