Hoopl/Dataflow: use block-oriented interface

This introduces the new interface for dataflow analysis, where transfer
functions operate on a whole basic block.

The main changes are:
- Hoopl.Dataflow: implement the new interface and remove the old code;
  expose a utility function to do a strict fold over the nodes of a
  basic block (for analyses that do want to look at all the nodes)
- Refactor all the analyses to use the new interface.

One of the nice effects is that we can remove the `analyzeFwdBlocks`
hack that ignored the middle nodes (that existed for analyses that
didn't need to go over all the nodes). Now this is no longer a special
case and fits well with the new interface.

Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>

Test Plan:
validate, earlier version of the patch had assertions
comparing the results with the old implementation

Reviewers: erikd, austin, simonmar, hvr, goldfire, bgamari

Reviewed By: bgamari

Subscribers: goldfire, erikd, thomie

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

4 files changed, 160 insertions, 292 deletions

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 2d7b938e0f..c4ec95cf1c 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -85,7 +85,6 @@ This is what flattenCAFSets is doing.
 type CAFSet = Set CLabel
 type CAFEnv = BlockEnv CAFSet
 
--- First, an analysis to find live CAFs.
 cafLattice :: DataflowLattice CAFSet
 cafLattice = DataflowLattice Set.empty add
   where
@@ -93,21 +92,27 @@ cafLattice = DataflowLattice Set.empty add
         let !new' = old `Set.union` new
         in changedIf (Set.size new' > Set.size old) new'
 
-cafTransfers :: BwdTransfer CmmNode CAFSet
-cafTransfers = mkBTransfer3 first middle last
-  where first  _ live = live
-        middle m live = foldExpDeep addCaf m live
-        last   l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
-        addCaf e set = case e of
-               CmmLit (CmmLabel c)              -> add c set
-               CmmLit (CmmLabelOff c _)         -> add c set
-               CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
-               _ -> set
-        add l s = if hasCAF l then Set.insert (toClosureLbl l) s
-                              else s
+cafTransfers :: TransferFun CAFSet
+cafTransfers (BlockCC eNode middle xNode) fBase =
+    let joined = cafsInNode xNode $! joinOutFacts cafLattice xNode fBase
+        !result = foldNodesBwdOO cafsInNode middle joined
+    in mapSingleton (entryLabel eNode) result
 
+cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
+cafsInNode node set = foldExpDeep addCaf node set
+  where
+    addCaf expr !set =
+        case expr of
+            CmmLit (CmmLabel c) -> add c set
+            CmmLit (CmmLabelOff c _) -> add c set
+            CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $! add c2 set
+            _ -> set
+    add l s | hasCAF l  = Set.insert (toClosureLbl l) s
+            | otherwise = s
+
+-- | An analysis to find live CAFs.
 cafAnal :: CmmGraph -> CAFEnv
-cafAnal g = dataflowAnalBwd g [] cafLattice cafTransfers
+cafAnal cmmGraph = analyzeCmmBwd cafLattice cafTransfers cmmGraph mapEmpty
 
 -----------------------------------------------------------------------
 -- Building the SRTs
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index 5346f4986c..7d77948c77 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -16,7 +16,7 @@ import DynFlags
 import BlockId
 import Cmm
 import PprCmmExpr ()
-import Hoopl.Dataflow
+import Hoopl
 
 import Maybes
 import Outputable
@@ -39,7 +39,6 @@ liveLattice = DataflowLattice emptyRegSet add
         let !join = plusRegSet old new
         in changedIf (sizeRegSet join > sizeRegSet old) join
 
-
 -- | A mapping from block labels to the variables live on entry
 type BlockEntryLiveness r = BlockEnv (CmmLive r)
 
@@ -49,14 +48,15 @@ type BlockEntryLiveness r = BlockEnv (CmmLive r)
 
 cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
 cmmLocalLiveness dflags graph =
-  check $ dataflowAnalBwd graph [] liveLattice (xferLive dflags)
-  where entry = g_entry graph
-        check facts = noLiveOnEntry entry
-                        (expectJust "check" $ mapLookup entry facts) facts
+    check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
+  where
+    entry = g_entry graph
+    check facts =
+        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
 
 cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg
 cmmGlobalLiveness dflags graph =
-  dataflowAnalBwd graph [] liveLattice (xferLive dflags)
+    analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
 
 -- | On entry to the procedure, there had better not be any LocalReg's live-in.
 noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a
@@ -64,32 +64,25 @@ noLiveOnEntry bid in_fact x =
   if nullRegSet in_fact then x
   else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
 
--- | The transfer equations use the traditional 'gen' and 'kill'
--- notations, which should be familiar from the Dragon Book.
-gen  :: UserOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r
-{-# INLINE gen #-}
-gen dflags a live = foldRegsUsed dflags extendRegSet live a
-
-kill :: DefinerOfRegs r a => DynFlags -> a -> RegSet r -> RegSet r
-{-# INLINE kill #-}
-kill dflags a live = foldRegsDefd dflags deleteFromRegSet live a
-
-gen_kill :: (DefinerOfRegs r a, UserOfRegs r a)
-          => DynFlags -> a -> CmmLive r -> CmmLive r
+gen_kill
+    :: (DefinerOfRegs r n, UserOfRegs r n)
+    => DynFlags -> n -> CmmLive r -> CmmLive r
+gen_kill dflags node set =
+    let !afterKill = foldRegsDefd dflags deleteFromRegSet set node
+    in foldRegsUsed dflags extendRegSet afterKill node
 {-# INLINE gen_kill #-}
-gen_kill dflags a = gen dflags a . kill dflags a
 
--- | The transfer function
-xferLive :: forall r . ( UserOfRegs    r (CmmNode O O)
-                       , DefinerOfRegs r (CmmNode O O)
-                       , UserOfRegs    r (CmmNode O C)
-                       , DefinerOfRegs r (CmmNode O C))
-         => DynFlags -> BwdTransfer CmmNode (CmmLive r)
-{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive LocalReg) #-}
-{-# SPECIALIZE xferLive :: DynFlags -> BwdTransfer CmmNode (CmmLive GlobalReg) #-}
-xferLive dflags = mkBTransfer3 fst mid lst
-  where fst _ f = f
-        mid :: CmmNode O O -> CmmLive r -> CmmLive r
-        mid n f = gen_kill dflags n f
-        lst :: CmmNode O C -> FactBase (CmmLive r) -> CmmLive r
-        lst n f = gen_kill dflags n $ joinOutFacts liveLattice n f
+xferLive
+    :: forall r.
+       ( UserOfRegs r (CmmNode O O)
+       , DefinerOfRegs r (CmmNode O O)
+       , UserOfRegs r (CmmNode O C)
+       , DefinerOfRegs r (CmmNode O C)
+       )
+    => DynFlags -> TransferFun (CmmLive r)
+xferLive dflags (BlockCC eNode middle xNode) fBase =
+    let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase
+        !result = foldNodesBwdOO (gen_kill dflags) middle joined
+    in mapSingleton (entryLabel eNode) result
+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}
+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 0efd45c104..40810a59da 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, DisambiguateRecordFields #-}
+{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
 
 module CmmProcPoint
     ( ProcPointSet, Status(..)
@@ -17,7 +17,7 @@ import Cmm
 import PprCmm ()
 import CmmUtils
 import CmmInfo
-import CmmLive (cmmGlobalLiveness)
+import CmmLive
 import CmmSwitch
 import Data.List (sortBy)
 import Maybes
@@ -25,7 +25,6 @@ import Control.Monad
 import Outputable
 import Platform
 import UniqSupply
-
 import Hoopl
 
 -- Compute a minimal set of proc points for a control-flow graph.
@@ -129,42 +128,44 @@ instance Outputable Status where
 --------------------------------------------------
 -- Proc point analysis
 
-procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status)
 -- Once you know what the proc-points are, figure out
 -- what proc-points each block is reachable from
 -- See Note [Proc-point analysis]
-procPointAnalysis procPoints g@(CmmGraph {g_graph = graph}) =
-  -- pprTrace "procPointAnalysis" (ppr procPoints) $
-  return $ dataflowAnalFwdBlocks g initProcPoints lattice forward
-  where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints,
-                                            id `setMember` labelsInGraph ]
-                                    -- See Note [Non-existing proc-points]
-        labelsInGraph  = labelsDefined graph
--- transfer equations
-
-forward :: FwdTransfer CmmNode Status
-forward = mkFTransfer3 first middle last
-    where
-      first :: CmmNode C O -> Status -> Status
-      first (CmmEntry id _) ProcPoint = ReachedBy $ setSingleton id
-      first  _ x = x
-
-      middle _ x = x
-
-      last :: CmmNode O C -> Status -> FactBase Status
-      last l x = mkFactBase lattice $ map (\id -> (id, x)) (successors l)
-
-lattice :: DataflowLattice Status
-lattice = DataflowLattice unreached add_to
-    where unreached = ReachedBy setEmpty
-          add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
-          add_to _ (NewFact ProcPoint) = Changed ProcPoint
-                       -- because of previous case
-          add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
-             | setSize union > setSize p = Changed (ReachedBy union)
-             | otherwise                 = NotChanged (ReachedBy p)
-           where
-             union = setUnion p' p
+procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (BlockEnv Status)
+procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
+    return $
+        analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
+  where
+    initProcPoints =
+        mkFactBase
+            procPointLattice
+            [ (id, ProcPoint)
+            | id <- setElems procPoints
+            -- See Note [Non-existing proc-points]
+            , id `setMember` labelsInGraph
+            ]
+    labelsInGraph = labelsDefined graph
+
+procPointTransfer :: TransferFun Status
+procPointTransfer block facts =
+    let label = entryLabel block
+        !fact = case getFact procPointLattice label facts of
+            ProcPoint -> ReachedBy $! setSingleton label
+            f -> f
+        result = map (\id -> (id, fact)) (successors block)
+    in mkFactBase procPointLattice result
+
+procPointLattice :: DataflowLattice Status
+procPointLattice = DataflowLattice unreached add_to
+  where
+    unreached = ReachedBy setEmpty
+    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
+    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
+    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
+        | setSize union > setSize p = Changed (ReachedBy union)
+        | otherwise = NotChanged (ReachedBy p)
+      where
+        union = setUnion p' p
 
 ----------------------------------------------------------------------
 
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index c28edb0d95..3115aa0b58 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -18,16 +18,13 @@
 --
 
 module Hoopl.Dataflow
-  ( C, O, DataflowLattice(..), OldFact(..), NewFact(..), Fact, FactBase
-  , mkFactBase
-  , JoinedFact(..)
-  , FwdPass(..), FwdTransfer, mkFTransfer3
-
-  , BwdPass(..), BwdTransfer, mkBTransfer3
-
-  , dataflowAnalFwdBlocks, dataflowAnalBwd
-  , analyzeFwd, analyzeFwdBlocks, analyzeBwd
-
+  ( C, O, Block
+  , lastNode, entryLabel
+  , foldNodesBwdOO
+  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..), TransferFun
+  , Fact, FactBase
+  , getFact, mkFactBase
+  , analyzeCmmFwd, analyzeCmmBwd
   , changedIf
   , joinOutFacts
   )
@@ -69,212 +66,73 @@ data DataflowLattice a = DataflowLattice
     , fact_join :: JoinFun a
     }
 
--- TODO(michalt): This wrapper will go away once we refactor the analyze*
--- methods.
-dataflowAnalFwdBlocks
-    :: NonLocal n
-    => GenCmmGraph n
-    -> [(BlockId, f)]
-    -> DataflowLattice f
-    -> FwdTransfer n f
-    -> BlockEnv f
-dataflowAnalFwdBlocks
-        (CmmGraph {g_entry = entry, g_graph = graph}) facts lattice xfer =
-    analyzeFwdBlocks
-        lattice xfer (JustC [entry]) graph (mkFactBase lattice facts)
-
--- TODO(michalt): This wrapper will go away once we refactor the analyze*
--- methods.
-dataflowAnalBwd
-    :: NonLocal n
-    => GenCmmGraph n
-    -> [(BlockId, f)]
-    -> DataflowLattice f
-    -> BwdTransfer n f
-    -> BlockEnv f
-dataflowAnalBwd
-        (CmmGraph {g_entry = entry, g_graph = graph}) facts lattice xfer =
-    analyzeBwd lattice xfer (JustC [entry]) graph (mkFactBase lattice facts)
-
-
-----------------------------------------------------------------
---       Forward Analysis only
-----------------------------------------------------------------
-
--- | if the graph being analyzed is open at the entry, there must
---   be no other entry point, or all goes horribly wrong...
-analyzeFwd
-   :: forall n f e .  NonLocal n
-   => DataflowLattice f
-   -> FwdTransfer n f
-   -> MaybeC e [Label]
-   -> Graph n e C -> Fact e f
-   -> FactBase f
-analyzeFwd lattice (FwdTransfer3 (ftr, mtr, ltr)) entries g in_fact =
-    graph g in_fact
-  where
-    graph :: Graph n e C -> Fact e f -> FactBase f
-    graph (GMany entry blockmap NothingO)
-      = case (entries, entry) of
-         (NothingC, JustO entry)   -> block entry `cat` body (successors entry)
-         (JustC entries, NothingO) -> body entries
-     where
-       body  :: [Label] -> Fact C f -> Fact C f
-       body entries f
-         = fixpointAnal Fwd lattice do_block entries blockmap f
-         where
-           do_block :: forall x . Block n C x -> FactBase f -> Fact x f
-           do_block b fb = block b entryFact
-             where entryFact = getFact lattice (entryLabel b) fb
-
-    -- NB. eta-expand block, GHC can't do this by itself.  See #5809.
-    block :: forall e x . Block n e x -> f -> Fact x f
-    block BNil            f = f
-    block (BlockCO n b)   f = (ftr n `cat`  block b) f
-    block (BlockCC l b n) f = (ftr l `cat` (block b `cat` ltr n)) f
-    block (BlockOC   b n) f =              (block b `cat` ltr n) f
-
-    block (BMiddle n)     f = mtr n f
-    block (BCat b1 b2)    f = (block b1 `cat` block b2) f
-    block (BSnoc h n)     f = (block h  `cat` mtr n) f
-    block (BCons n t)     f = (mtr  n   `cat` block t) f
-
-    {-# INLINE cat #-}
-    cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
-    cat ft1 ft2 = \f -> ft2 $! ft1 f
-
--- | if the graph being analyzed is open at the entry, there must
---   be no other entry point, or all goes horribly wrong...
-analyzeFwdBlocks
-   :: forall n f e .  NonLocal n
-   => DataflowLattice f
-   -> FwdTransfer n f
-   -> MaybeC e [Label]
-   -> Graph n e C -> Fact e f
-   -> FactBase f
-analyzeFwdBlocks lattice (FwdTransfer3 (ftr, _, ltr)) entries g in_fact =
-    graph g in_fact
-  where
-    graph :: Graph n e C -> Fact e f -> FactBase f
-    graph (GMany entry blockmap NothingO)
-      = case (entries, entry) of
-         (NothingC, JustO entry)   -> block entry `cat` body (successors entry)
-         (JustC entries, NothingO) -> body entries
-     where
-       body  :: [Label] -> Fact C f -> Fact C f
-       body entries f
-         = fixpointAnal Fwd lattice do_block entries blockmap f
-         where
-           do_block :: forall x . Block n C x -> FactBase f -> Fact x f
-           do_block b fb = block b entryFact
-             where entryFact = getFact lattice (entryLabel b) fb
-
-    -- NB. eta-expand block, GHC can't do this by itself.  See #5809.
-    block :: forall e x . Block n e x -> f -> Fact x f
-    block BNil            f = f
-    block (BlockCO n _)   f = ftr n f
-    block (BlockCC l _ n) f = (ftr l `cat` ltr n) f
-    block (BlockOC   _ n) f = ltr n f
-    block _               _ = error "analyzeFwdBlocks"
-
-    {-# INLINE cat #-}
-    cat :: forall f1 f2 f3 . (f1 -> f2) -> (f2 -> f3) -> (f1 -> f3)
-    cat ft1 ft2 = \f -> ft2 $! ft1 f
-
-----------------------------------------------------------------
---       Backward Analysis only
-----------------------------------------------------------------
-
--- | if the graph being analyzed is open at the entry, there must
---   be no other entry point, or all goes horribly wrong...
-analyzeBwd
-   :: forall n f e .  NonLocal n
-   => DataflowLattice f
-   -> BwdTransfer n f
-   -> MaybeC e [Label]
-   -> Graph n e C -> Fact C f
-   -> FactBase f
-analyzeBwd lattice (BwdTransfer3 (ftr, mtr, ltr)) entries g in_fact =
-    graph g in_fact
-  where
-    graph :: Graph n e C -> Fact C f -> FactBase f
-    graph (GMany entry blockmap NothingO)
-      = case (entries, entry) of
-         (NothingC, JustO entry)   -> body (successors entry)
-         (JustC entries, NothingO) -> body entries
-     where
-       body  :: [Label] -> Fact C f -> Fact C f
-       body entries f
-         = fixpointAnal Bwd lattice do_block entries blockmap f
-         where
-           do_block :: forall x . Block n C x -> Fact x f -> FactBase f
-           do_block b fb = mapSingleton (entryLabel b) (block b fb)
-
-    -- NB. eta-expand block, GHC can't do this by itself.  See #5809.
-    block :: forall e x . Block n e x -> Fact x f -> f
-    block BNil            f = f
-    block (BlockCO n b)   f = (ftr n `cat`  block b) f
-    block (BlockCC l b n) f = ((ftr l `cat` block b) `cat` ltr n) f
-    block (BlockOC   b n) f =              (block b `cat` ltr n) f
-
-    block (BMiddle n)     f = mtr n f
-    block (BCat b1 b2)    f = (block b1 `cat` block b2) f
-    block (BSnoc h n)     f = (block h  `cat` mtr n) f
-    block (BCons n t)     f = (mtr  n   `cat` block t) f
-
-    {-# INLINE cat #-}
-    cat :: forall f1 f2 f3 . (f2 -> f3) -> (f1 -> f2) -> (f1 -> f3)
-    cat ft1 ft2 = \f -> ft1 $! ft2 f
-
+data Direction = Fwd | Bwd
 
------------------------------------------------------------------------------
---      fixpoint
------------------------------------------------------------------------------
+type TransferFun f = CmmBlock -> FactBase f -> FactBase f
 
-data Direction = Fwd | Bwd
+analyzeCmmBwd, analyzeCmmFwd
+    :: DataflowLattice f
+    -> TransferFun f
+    -> CmmGraph
+    -> FactBase f
+    -> FactBase f
+analyzeCmmBwd = analyzeCmm Bwd
+analyzeCmmFwd = analyzeCmm Fwd
 
--- | fixpointing for analysis-only
---
-fixpointAnal :: forall n f. NonLocal n
- => Direction
- -> DataflowLattice f
- -> (Block n C C -> Fact C f -> Fact C f)
- -> [Label]
- -> LabelMap (Block n C C)
- -> Fact C f -> FactBase f
-
-fixpointAnal direction DataflowLattice{ fact_bot = _, fact_join = join }
-              do_block entries blockmap init_fbase
-  = loop start init_fbase
+analyzeCmm
+    :: Direction
+    -> DataflowLattice f
+    -> TransferFun f
+    -> CmmGraph
+    -> FactBase f
+    -> FactBase f
+analyzeCmm dir lattice transfer cmmGraph initFact =
+    let entry = g_entry cmmGraph
+        hooplGraph = g_graph cmmGraph
+        blockMap =
+            case hooplGraph of
+                GMany NothingO bm NothingO -> bm
+        entries = if mapNull initFact then [entry] else mapKeys initFact
+    in fixpointAnalysis dir lattice transfer entries blockMap initFact
+
+-- Fixpoint algorithm.
+fixpointAnalysis
+    :: forall f.
+       Direction
+    -> DataflowLattice f
+    -> TransferFun f
+    -> [Label]
+    -> LabelMap CmmBlock
+    -> FactBase f
+    -> FactBase f
+fixpointAnalysis direction lattice do_block entries blockmap = loop start
   where
+    -- Sorting the blocks helps to minimize the number of times we need to
+    -- process blocks. For instance, for forward analysis we want to look at
+    -- blocks in reverse postorder. Also, see comments for sortBlocks.
     blocks     = sortBlocks direction entries blockmap
-    n          = length blocks
-    block_arr  = {-# SCC "block_arr" #-} listArray (0,n-1) blocks
-    start      = {-# SCC "start" #-} [0..n-1]
+    num_blocks = length blocks
+    block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
+    start      = {-# SCC "start" #-} [0 .. num_blocks - 1]
     dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
+    join       = fact_join lattice
 
     loop
-       :: IntHeap      -- blocks still to analyse
-       -> FactBase f  -- current factbase (increases monotonically)
-       -> FactBase f
-
-    loop []        fbase = fbase
-    loop (ix:todo) fbase =
-           let
-               blk = block_arr ! ix
+        :: IntHeap     -- ^ Worklist, i.e., blocks to process
+        -> FactBase f  -- ^ Current result (increases monotonically)
+        -> FactBase f
+    loop []              !fbase1 = fbase1
+    loop (index : todo1) !fbase1 =
+        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
+            -- information in fbase1 and (if something changed) we update it
+            -- and add the affected blocks to the worklist.
+            (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
+                mapFoldWithKey
+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts
+        in loop todo2 fbase2
 
-               out_facts = {-# SCC "do_block" #-} do_block blk fbase
-
-               !(todo', fbase') = {-# SCC "mapFoldWithKey" #-}
-                     mapFoldWithKey (updateFact join dep_blocks)
-                                    (todo,fbase) out_facts
-           in
-           -- trace ("analysing: " ++ show (entryLabel blk)) $
-           -- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()
-           -- trace ("changed: " ++ show changed) $ return ()
-           -- trace ("to analyse: " ++ show to_analyse) $ return ()
-
-           loop todo' fbase'
 
 
 {-
@@ -412,7 +270,7 @@ getFact lat l fb = case lookupFact l fb of Just  f -> f
 
 -- | Returns the result of joining the facts from all the successors of the
 -- provided node or block.
-joinOutFacts :: (NonLocal n) => DataflowLattice f -> n O C -> FactBase f -> f
+joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
 joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
   where
     join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
@@ -436,6 +294,17 @@ mkFactBase lattice = foldl' add mapEmpty
                     Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
         in mapInsert l newFact result
 
+-- | Folds backward over all nodes of an open-open block.
+-- Strict in the accumulator.
+foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
+foldNodesBwdOO funOO = go
+  where
+    go (BCat b1 b2) f = go b1 $! go b2 f
+    go (BSnoc h n) f = go h $! funOO n f
+    go (BCons n t) f = funOO n $! go t f
+    go (BMiddle n) f = funOO n f
+    go BNil f = f
+{-# INLINABLE foldNodesBwdOO #-}
 
 -- -----------------------------------------------------------------------------
 -- a Heap of Int