Fix #17724 by running the simplifier before late CSEwip/andreask/T17724

CSE seems to depend on bindings being in dependency order.
The simplifier put's bindings into dependency order.

So do a simplifier run first.

We used to do in order

* ...
* optional: late spec + simplifier "post-late-spec" run
* optional: late cse
* simplifier "final" run
* ...

We now do:

* ...
* optional: late spec
* optional: simplifier "pre-late-cse" run + cse
* simplifier "final" run.
* ...

The result is that:

* At -O we now potentially do fewer runs of the simplifier.
  "post-late-spec" is gone if late-spec is on
* At -O2 we do an additional simplifier run : "pre-late-cse"
* At -O2 with -fspec-late we do what we already did.
  Only that the intermediate simplifier run is called "pre-late-cse"
  instead of "post-late-spec".

We also removed a case where occAnal dropped code it assumed to be dead.

7 files changed, 133 insertions, 4 deletions

diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index 9a0945e290..0835f87bb0 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -327,6 +327,7 @@ the program; it's a kind of synthetic key for recursive bindings.
 ************************************************************************
 -}
 
+-- | Requires bindings to be in dependency order.
 cseProgram :: CoreProgram -> CoreProgram
 cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)
 
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/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index b8fb162432..799dfa93fe 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -318,15 +318,17 @@ getCoreToDo dflags
 
         maybe_rule_check (Phase 0),
 
-        runWhen late_specialise
-          (CoreDoPasses [ CoreDoSpecialising
-                        , simpl_phase 0 ["post-late-spec"] max_iter]),
+        runWhen late_specialise CoreDoSpecialising,
 
         -- LiberateCase can yield new CSE opportunities because it peels
         -- off one layer of a recursive function (concretely, I saw this
         -- in wheel-sieve1), and I'm guessing that SpecConstr can too
         -- And CSE is a very cheap pass. So it seems worth doing here.
+        -- This helps shake out any effect of liberate_case/spec_constr.
+        -- It also puts bindings in dependency order, which helps with CSE.
         runWhen ((liberate_case || spec_constr) && cse) CoreCSE,
+            ( CoreDoPasses [ simpl_phase 0 ["pre-late-cse"] max_iter
+                           , CoreCSE ]),
 
         -- Final clean-up simplification:
         simpl_phase 0 ["final"] max_iter,
diff --git a/testsuite/tests/simplCore/should_compile/T17722A.hs b/testsuite/tests/simplCore/should_compile/T17722A.hs
new file mode 100644
index 0000000000..1f63582beb
--- /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..54814c6d88
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T17722B.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

+{-# LANGUAGE OverloadedStrings          #-}

+module T17722B (setHelper) where

+

+import T17722A

+

+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

+

+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..9b6c2df0c7
--- /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..d35a9497b9 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -312,3 +312,6 @@ test('T17409',
      normal,
      makefile_test, ['T17409'])
 test('T17429', normal, compile, ['-dcore-lint -O2'])
+test('T17722A', normal, compile, ['-dcore-lint -O2'])
+test('T17722B', normal, compile, ['-dcore-lint -O2'])
+test('T17724', normal, compile, ['-dcore-lint -O2'])