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

1 files changed, 11 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