Use IntSet in Dataflow

Before this change, a list was used as a substitute for a heap.
This led to quadratic behavior on a simple program (see new
test case).

This change replaces it with IntSet in effect reverting
5a1a2633553. @simonmar said it's fine to revert as long as nofib
results are good.

Test Plan:
new test case:

20% improvement
3x improvement when N=10000

nofib:

I run it twice for before and after because the compile time
results are noisy.

- Compile Allocations:

```
          before    before re-run    after     after re-run
-1 s.d.   -----     -0.0%            -0.1%     -0.1%
+1 s.d.   -----     +0.0%            +0.1%     +0.1%
Average   -----     +0.0%            -0.0%     -0.0%
```
- Compile Time:

```
          before    before re-run    after     after re-run
-1 s.d.   -----     -0.1%            -2.3%     -2.6%
+1 s.d.   -----     +5.2%            +3.7%     +4.4%
Average   -----     +2.5%            +0.7%     +0.8%

```
I checked each case and couldn't find consistent slow-down/speed-up on
compile time. Full results here: P173

Reviewers: simonpj, simonmar, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter, simonmar

GHC Trac Issues: #14667

Differential Revision: https://phabricator.haskell.org/D4329

3 files changed, 57 insertions, 23 deletions

diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index b2a7716c62..2310db2619 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -132,7 +132,8 @@ fixpointAnalysis direction lattice do_block entries blockmap = loop start
     blocks     = sortBlocks direction entries blockmap
     num_blocks = length blocks
     block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
-    start      = {-# SCC "start" #-} [0 .. num_blocks - 1]
+    start      = {-# SCC "start" #-} IntSet.fromDistinctAscList
+      [0 .. num_blocks - 1]
     dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
     join       = fact_join lattice
 
@@ -140,8 +141,7 @@ fixpointAnalysis direction lattice do_block entries blockmap = loop start
         :: IntHeap     -- ^ Worklist, i.e., blocks to process
         -> FactBase f  -- ^ Current result (increases monotonically)
         -> FactBase f
-    loop []              !fbase1 = fbase1
-    loop (index : todo1) !fbase1 =
+    loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =
         let block = block_arr ! index
             out_facts = {-# SCC "do_block" #-} do_block block fbase1
             -- For each of the outgoing edges, we join it with the current
@@ -151,6 +151,7 @@ fixpointAnalysis direction lattice do_block entries blockmap = loop start
                 mapFoldWithKey
                     (updateFact join dep_blocks) (todo1, fbase1) out_facts
         in loop todo2 fbase2
+    loop _ !fbase1 = fbase1
 
 rewriteCmmBwd
     :: DataflowLattice f
@@ -196,7 +197,8 @@ fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap
     num_blocks = length blocks
     block_arr  = {-# SCC "block_arr_rewrite" #-}
                  listArray (0, num_blocks - 1) blocks
-    start      = {-# SCC "start_rewrite" #-} [0 .. num_blocks - 1]
+    start      = {-# SCC "start_rewrite" #-}
+                 IntSet.fromDistinctAscList [0 .. num_blocks - 1]
     dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks
     join       = fact_join lattice
 
@@ -205,8 +207,8 @@ fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap
         -> LabelMap CmmBlock  -- ^ Rewritten blocks.
         -> FactBase f         -- ^ Current facts.
         -> UniqSM (LabelMap CmmBlock, FactBase f)
-    loop []              !blocks1 !fbase1 = return (blocks1, fbase1)
-    loop (index : todo1) !blocks1 !fbase1 = do
+    loop todo !blocks1 !fbase1
+      | Just (index, todo1) <- IntSet.minView todo = do
         -- Note that we use the *original* block here. This is important.
         -- We're optimistically rewriting blocks even before reaching the fixed
         -- point, which means that the rewrite might be incorrect. So if the
@@ -220,6 +222,7 @@ fixpointRewrite dir lattice do_block entries blockmap = loop start blockmap
                 mapFoldWithKey
                     (updateFact join dep_blocks) (todo1, fbase1) out_facts
         loop todo2 blocks2 fbase2
+    loop _ !blocks1 !fbase1 = return (blocks1, fbase1)
 
 
 {-
@@ -344,7 +347,7 @@ updateFact fact_join dep_blocks lbl new_fact (todo, fbase)
               (NotChanged _) -> (todo, fbase)
               (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
   where
-    changed = IntSet.foldr insertIntHeap todo $
+    changed = todo `IntSet.union`
               mapFindWithDefault IntSet.empty lbl dep_blocks
 
 {-
@@ -436,19 +439,4 @@ joinBlocksOO (BMiddle n) b = blockCons n b
 joinBlocksOO b (BMiddle n) = blockSnoc b n
 joinBlocksOO b1 b2 = BCat b1 b2
 
--- -----------------------------------------------------------------------------
--- a Heap of Int
-
--- We should really use a proper Heap here, but my attempts to make
--- one have not succeeded in beating the simple ordered list.  Another
--- alternative is IntSet (using deleteFindMin), but that was also
--- slower than the ordered list in my experiments --SDM 25/1/2012
-
-type IntHeap = [Int] -- ordered
-
-insertIntHeap :: Int -> [Int] -> [Int]
-insertIntHeap x [] = [x]
-insertIntHeap x (y:ys)
-  | x < y     = x : y : ys
-  | x == y    = x : ys
-  | otherwise = y : insertIntHeap x ys
+type IntHeap = IntSet
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index bd038a2407..51dc6e8a99 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -1166,6 +1166,18 @@ test('ManyConstructors',
      multimod_compile,
      ['ManyConstructors', '-v0'])
 
+test('ManyAlternatives',
+     [ compiler_stats_num_field('bytes allocated',
+          [(wordsize(64), 1398898072, 10),
+          # initial:    1756999240
+          # 2018-01-20: 1398898072  Use IntSet in Dataflow
+          ]),
+       pre_cmd('./genManyAlternatives'),
+       extra_files(['genManyAlternatives']),
+     ],
+     multimod_compile,
+     ['ManyAlternatives', '-v0'])
+
 test('T13701',
      [ compiler_stats_num_field('bytes allocated',
           [(platform('x86_64-apple-darwin'), 2217187888, 10),
diff --git a/testsuite/tests/perf/compiler/genManyAlternatives b/testsuite/tests/perf/compiler/genManyAlternatives
new file mode 100755
index 0000000000..1035425bd4
--- /dev/null
+++ b/testsuite/tests/perf/compiler/genManyAlternatives
@@ -0,0 +1,34 @@
+SIZE=1000
+MODULE=ManyAlternatives
+
+# Generates a module with a large number of alternatives that looks
+# like this:
+#
+#   module ManyAlternatives where
+#
+#   data A1000 = A0
+#     | A0001
+#     | A0002
+#     ...
+#     | A1000
+#
+#   f :: A -> Int
+#   f A0001 = 1990001
+#   f A0002 = 1990002
+#   ...
+#   f A1000 = 1991000
+#
+# The point of this test is to check if we don't regress on #14667 reintroducing
+# some code that's quadratic in the number of alternatives.
+
+echo "module $MODULE where" > $MODULE.hs
+echo >> $MODULE.hs
+echo "data A$SIZE = A0" >> $MODULE.hs
+for i in $(seq -w 1 $SIZE); do
+  echo "  | A$i" >> $MODULE.hs
+done
+echo >> $MODULE.hs
+echo "f :: A$SIZE -> Int" >> $MODULE.hs
+for i in $(seq -w 1 $SIZE); do
+  echo "f A$i = 199$i" >> $MODULE.hs
+done