diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index 8b6bc2eed2743a7b126632cef159655818f5d8b8..f56832cbd3011bf894eb9344f807df3f2e634146 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -79,11 +79,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 (Trac #9583 is an example)
+ -- 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 0000000000000000000000000000000000000000..2a37163afaeb7c6a3ee3130578c5750c085109a2
--- /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 0000000000000000000000000000000000000000..ffcf5c9203db321278509d6a7133c123af6f5104
--- /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 0000000000000000000000000000000000000000..a514a7f305251ec4d99ab0a1b2b8a04c42bbedd4
--- /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 0d4d3635639dfb3a665a41eb0744941ae1efa0f0..90d6f140a6cd6873b795c4e6e2669320b6fbee50 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -332,3 +332,5 @@ test('T16978A', normal, compile, ['-O'])
test('T16979a', normal, compile, ['-O'])
test('T16979b', normal, compile, ['-O'])
test('T17429', normal, compile, ['-dcore-lint -O2'])
+test('T17722', normal, multimod_compile, ['T17722B', '-dcore-lint -O2 -v0'])
+test('T17724', normal, compile, ['-dcore-lint -O2'])