Hoopl/Dataflow: make the module more self-contained

This makes the GHC's Dataflow module more self-contained by also
forking the `DataflowLattice` (instead of only the analysis
algorithm). Effects/benefits:
- We no longer need to use the deprecated Hoopl functions (and can
  remove `-fno-warn-warnings-deprecations` from two modules).
- We can remove the unnecessary `Label` parameter of `JoinFun` (already
  ignored in all our implementations).
- We no longer mix Hoopl's `Dataflow` module and GHC's one.
- We can replace some calls to lazy folds in Hoopl with the strict ones
  (see `joinOutFacts` and `mkFactBase`).

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

Test Plan: validate

Reviewers: austin, simonmar, bgamari

Reviewed By: bgamari

Subscribers: thomie

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

5 files changed, 82 insertions, 52 deletions

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index a7ef994f11..2d7b938e0f 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -1,7 +1,5 @@
-{-# LANGUAGE CPP, GADTs #-}
+{-# LANGUAGE BangPatterns, CPP, GADTs #-}
 
--- See Note [Deprecations in Hoopl] in Hoopl module
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
 module CmmBuildInfoTables
     ( CAFSet, CAFEnv, cafAnal
     , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
@@ -89,9 +87,11 @@ type CAFEnv = BlockEnv CAFSet
 
 -- First, an analysis to find live CAFs.
 cafLattice :: DataflowLattice CAFSet
-cafLattice = DataflowLattice "live cafs" Set.empty add
-  where add _ (OldFact old) (NewFact new) = case old `Set.union` new of
-                                              new' -> (changeIf $ Set.size new' > Set.size old, new')
+cafLattice = DataflowLattice Set.empty add
+  where
+    add (OldFact old) (NewFact new) =
+        let !new' = old `Set.union` new
+        in changedIf (Set.size new' > Set.size old) new'
 
 cafTransfers :: BwdTransfer CmmNode CAFSet
 cafTransfers = mkBTransfer3 first middle last
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index 97bf361bcd..5346f4986c 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -3,9 +3,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
--- See Note [Deprecations in Hoopl] in Hoopl module
-{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-
 module CmmLive
     ( CmmLocalLive
     , cmmLocalLiveness
@@ -36,10 +33,11 @@ type CmmLocalLive = CmmLive LocalReg
 liveLattice :: Ord r => DataflowLattice (CmmLive r)
 {-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}
 {-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}
-liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
-    where add _ (OldFact old) (NewFact new) =
-               (changeIf $ sizeRegSet join > sizeRegSet old, join)
-              where !join = plusRegSet old new
+liveLattice = DataflowLattice emptyRegSet add
+  where
+    add (OldFact old) (NewFact new) =
+        let !join = plusRegSet old new
+        in changedIf (sizeRegSet join > sizeRegSet old) join
 
 
 -- | A mapping from block labels to the variables live on entry
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index e409fc42a1..9459a1058c 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -155,14 +155,14 @@ forward = mkFTransfer3 first middle last
       last l x = mkFactBase lattice $ map (\id -> (id, x)) (successors l)
 
 lattice :: DataflowLattice Status
-lattice = DataflowLattice "direct proc-point reachability" unreached add_to
+lattice = DataflowLattice unreached add_to
     where unreached = ReachedBy setEmpty
-          add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint)
-          add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint)
+          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 = (SomeChange, ReachedBy union)
-             | otherwise                 = (NoChange, ReachedBy p)
+          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.hs b/compiler/cmm/Hoopl.hs
index 513ab5b596..732c1b7bd0 100644
--- a/compiler/cmm/Hoopl.hs
+++ b/compiler/cmm/Hoopl.hs
@@ -7,39 +7,15 @@ module Hoopl (
 
 import Compiler.Hoopl hiding
   ( (<*>), mkLabel, mkBranch, mkMiddle, mkLast, -- clashes with our MkGraph
+    DataflowLattice, OldFact, NewFact, JoinFun,
+    fact_bot, fact_join, joinOutFacts, mkFactBase,
     Unique,
     FwdTransfer(..), FwdRewrite(..), FwdPass(..),
     BwdTransfer(..), BwdRewrite(..), BwdPass(..),
     mkFactBase, Fact,
     mkBRewrite3, mkBTransfer3,
     mkFRewrite3, mkFTransfer3,
+
   )
 
 import Hoopl.Dataflow
-
--- Note [Deprecations in Hoopl]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- CmmLive and CmmBuildInfoTables modules enable -fno-warn-warnings-deprecations
--- flag because they import deprecated functions from Hoopl. I spent some time
--- trying to figure out what is going on, so here's a brief explanation. The
--- culprit is the joinOutFacts function, which should be replaced with
--- joinFacts. The difference between them is that the latter one needs extra
--- Label parameter. Labels identify blocks and are used in the fact base to
--- assign facts to a block (in case you're wondering, Label is an Int wrapped in
--- a newtype). Lattice join function is also required to accept a Label but the
--- only reason why it is so are the debugging purposes: see joinInFacts function
--- which is a no-op and is run only because join function might produce
--- debugging output. Now, going back to the Cmm modules. The "problem" with the
--- deprecated joinOutFacts function is that it passes wrong label when calling
--- lattice join function: instead of label of a block for which we are joining
--- facts it uses labels of successors of that block. So the joinFacts function
--- expects to be given a label of a block for which we are joining facts. I
--- don't see an obvious way of recovering that Label at the call sites of
--- joinOutFacts (if that was easily done then joinFacts function could do it
--- internally without requiring label as a parameter). A cheap way of
--- eliminating these warnings would be to create a bogus Label, since none of
--- our join functions is actually using the Label parameter. But that doesn't
--- feel right. I think the real solution here is to fix Hoopl API, which is
--- already broken in several ways. See Hoopl/Cleanup page on the wiki for more
--- notes on improving Hoopl.
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index d8d37121f1..c28edb0d95 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -20,7 +20,7 @@
 module Hoopl.Dataflow
   ( C, O, DataflowLattice(..), OldFact(..), NewFact(..), Fact, FactBase
   , mkFactBase
-  , ChangeFlag(..)
+  , JoinedFact(..)
   , FwdPass(..), FwdTransfer, mkFTransfer3
 
   , BwdPass(..), BwdTransfer, mkBTransfer3
@@ -28,7 +28,7 @@ module Hoopl.Dataflow
   , dataflowAnalFwdBlocks, dataflowAnalBwd
   , analyzeFwd, analyzeFwdBlocks, analyzeBwd
 
-  , changeIf
+  , changedIf
   , joinOutFacts
   )
 where
@@ -37,8 +37,37 @@ import BlockId
 import Cmm
 
 import Data.Array
+import Data.List
+import Data.Maybe
 
-import Compiler.Hoopl
+-- Hide definitions from Hoopl's Dataflow module.
+import Compiler.Hoopl hiding ( DataflowLattice, OldFact, NewFact, JoinFun
+                             , fact_bot, fact_join, joinOutFacts, mkFactBase
+                             )
+
+newtype OldFact a = OldFact a
+
+newtype NewFact a = NewFact a
+
+-- | The result of joining OldFact and NewFact.
+data JoinedFact a
+    = Changed !a     -- ^ Result is different than OldFact.
+    | NotChanged !a  -- ^ Result is the same as OldFact.
+
+getJoined :: JoinedFact a -> a
+getJoined (Changed a) = a
+getJoined (NotChanged a) = a
+
+changedIf :: Bool -> a -> JoinedFact a
+changedIf True = Changed
+changedIf False = NotChanged
+
+type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
+
+data DataflowLattice a = DataflowLattice
+    { fact_bot :: a
+    , fact_join :: JoinFun a
+    }
 
 -- TODO(michalt): This wrapper will go away once we refactor the analyze*
 -- methods.
@@ -356,9 +385,9 @@ updateFact fact_join dep_blocks lbl new_fact (todo, fbase)
       Nothing       -> let !z = mapInsert lbl new_fact fbase in (changed, z)
                            -- Note [no old fact]
       Just old_fact ->
-        case fact_join lbl (OldFact old_fact) (NewFact new_fact) of
-          (NoChange, _) -> (todo, fbase)
-          (_,        f) -> let !z = mapInsert lbl f fbase in (changed, z)
+        case fact_join (OldFact old_fact) (NewFact new_fact) of
+          (NotChanged _) -> (todo, fbase)
+          (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
   where
      changed = foldr insertIntHeap todo $
                  mapFindWithDefault [] lbl dep_blocks
@@ -381,6 +410,33 @@ getFact  :: DataflowLattice f -> Label -> FactBase f -> f
 getFact lat l fb = case lookupFact l fb of Just  f -> f
                                            Nothing -> fact_bot lat
 
+-- | 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 lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
+  where
+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
+    facts =
+        [ fromJust fact
+        | s <- successors nonLocal
+        , let fact = lookupFact s fact_base
+        , isJust fact
+        ]
+
+-- | Returns the joined facts for each label.
+mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
+mkFactBase lattice = foldl' add mapEmpty
+  where
+    join = fact_join lattice
+
+    add result (l, f1) =
+        let !newFact =
+                case mapLookup l result of
+                    Nothing -> f1
+                    Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
+        in mapInsert l newFact result
+
+
 -- -----------------------------------------------------------------------------
 -- a Heap of Int