Hoopl: remove dependency on Hoopl package

This copies the subset of Hoopl's functionality needed by GHC to
`cmm/Hoopl` and removes the dependency on the Hoopl package.

The main motivation for this change is the confusing/noisy interface
between GHC and Hoopl:
- Hoopl has `Label` which is GHC's `BlockId` but different than
  GHC's `CLabel`
- Hoopl has `Unique` which is different than GHC's `Unique`
- Hoopl has `Unique{Map,Set}` which are different than GHC's
  `Uniq{FM,Set}`
- GHC has its own specialized copy of `Dataflow`, so `cmm/Hoopl` is
  needed just to filter the exposed functions (filter out some of the
  Hoopl's and add the GHC ones)
With this change, we'll be able to simplify this significantly.
It'll also be much easier to do invasive changes (Hoopl is a public
package on Hackage with users that depend on the current behavior)

This should introduce no changes in functionality - it merely
copies the relevant code.

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

Test Plan: ./validate

Reviewers: austin, bgamari, simonmar

Reviewed By: bgamari, simonmar

Subscribers: simonpj, kavon, rwbarton, thomie

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

55 files changed, 948 insertions, 94 deletions

diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
index d59cbd08e4..8f11ad194b 100644
--- a/compiler/cmm/BlockId.hs
+++ b/compiler/cmm/BlockId.hs
@@ -11,12 +11,11 @@ module BlockId
 import CLabel
 import IdInfo
 import Name
-import Outputable
 import Unique
 import UniqSupply
 
-import Compiler.Hoopl as Hoopl hiding (Unique)
-import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique)
+import Hoopl.Label (Label, uniqueToLbl)
+import Hoopl.Unique (intToUnique)
 
 ----------------------------------------------------------------
 --- Block Ids, their environments, and their sets
@@ -30,13 +29,7 @@ most assembly languages allow, a label is visible throughout the entire
 compilation unit in which it appears.
 -}
 
-type BlockId = Hoopl.Label
-
-instance Uniquable BlockId where
-  getUnique label = getUnique (lblToUnique label)
-
-instance Outputable BlockId where
-  ppr label = ppr (getUnique label)
+type BlockId = Label
 
 mkBlockId :: Unique -> BlockId
 mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index bab20f3fdd..dbd54236f5 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -31,7 +31,10 @@ import BlockId
 import CmmNode
 import SMRep
 import CmmExpr
-import Compiler.Hoopl
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
 import Outputable
 
 import Data.Word        ( Word8 )
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index a28feb4a2b..5dd8ee4ef2 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -7,7 +7,11 @@ where
 
 #include "HsVersions.h"
 
-import Hoopl
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Collections
+import Hoopl.Dataflow
 import Digraph
 import Bitmap
 import CLabel
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index 3dc8202274..3c23e70b8c 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -13,7 +13,10 @@ import CmmContFlowOpt
 -- import PprCmm ()
 import Prelude hiding (iterate, succ, unzip, zip)
 
-import Hoopl hiding (ChangeFlag)
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Collections
 import Data.Bits
 import Data.Maybe (mapMaybe)
 import qualified Data.List as List
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index 142de1e828..219b68e42a 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -8,7 +8,10 @@ module CmmContFlowOpt
     )
 where
 
-import Hoopl
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
 import BlockId
 import Cmm
 import CmmUtils
diff --git a/compiler/cmm/CmmImplementSwitchPlans.hs b/compiler/cmm/CmmImplementSwitchPlans.hs
index d378c66168..eda031e840 100644
--- a/compiler/cmm/CmmImplementSwitchPlans.hs
+++ b/compiler/cmm/CmmImplementSwitchPlans.hs
@@ -4,7 +4,7 @@ module CmmImplementSwitchPlans
   )
 where
 
-import Hoopl
+import Hoopl.Block
 import BlockId
 import Cmm
 import CmmUtils
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 35e3a1888d..e849c810ef 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -41,7 +41,7 @@ import SMRep
 import Bitmap
 import Stream (Stream)
 import qualified Stream
-import Hoopl
+import Hoopl.Collections
 
 import Maybes
 import DynFlags
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index ecbac71e8f..4151aa0c4e 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -17,7 +17,11 @@ import ForeignCall
 import CmmLive
 import CmmProcPoint
 import SMRep
-import Hoopl
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Graph
+import Hoopl.Label
 import UniqSupply
 import StgCmmUtils      ( newTemp )
 import Maybes
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 12c884a710..64b4400378 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -10,7 +10,10 @@ module CmmLint (
     cmmLint, cmmLintGraph
   ) where
 
-import Hoopl
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
 import Cmm
 import CmmUtils
 import CmmLive
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index b7a8dd6eec..944a9e394e 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -16,7 +16,10 @@ import DynFlags
 import BlockId
 import Cmm
 import PprCmmExpr ()
-import Hoopl
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Label
 
 import Maybes
 import Outputable
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index a3393903ad..f452b0b3f5 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -33,7 +33,9 @@ import SMRep
 import CoreSyn (Tickish)
 import qualified Unique as U
 
-import Compiler.Hoopl
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
 import Data.Maybe
 import Data.List (tails,sortBy)
 import Prelude hiding (succ)
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index a0fe4b1f12..bc827dfe87 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -16,7 +16,7 @@ import CmmProcPoint
 import CmmContFlowOpt
 import CmmLayoutStack
 import CmmSink
-import Hoopl
+import Hoopl.Collections
 
 import UniqSupply
 import DynFlags
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 3dc7ac4e92..2e2c22c10d 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -25,7 +25,11 @@ import Control.Monad
 import Outputable
 import Platform
 import UniqSupply
-import Hoopl
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Graph
+import Hoopl.Label
 
 -- Compute a minimal set of proc points for a control-flow graph.
 
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index d21f2422e7..517605b9ff 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -7,7 +7,10 @@ import Cmm
 import CmmOpt
 import CmmLive
 import CmmUtils
-import Hoopl
+import Hoopl.Block
+import Hoopl.Label
+import Hoopl.Collections
+import Hoopl.Graph
 import CodeGen.Platform
 import Platform (isARM, platformArch)
 
diff --git a/compiler/cmm/CmmSwitch.hs b/compiler/cmm/CmmSwitch.hs
index 514cf3835f..b0ca4be762 100644
--- a/compiler/cmm/CmmSwitch.hs
+++ b/compiler/cmm/CmmSwitch.hs
@@ -13,7 +13,7 @@ module CmmSwitch (
 
 import Outputable
 import DynFlags
-import Compiler.Hoopl (Label)
+import Hoopl.Label (Label)
 
 import Data.Maybe
 import Data.List (groupBy)
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 722718a3e2..74524c997f 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -79,7 +79,10 @@ import CodeGen.Platform
 import Data.Word
 import Data.Maybe
 import Data.Bits
-import Hoopl
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Block
+import Hoopl.Collections
 
 ---------------------------------------------------
 --
diff --git a/compiler/cmm/Debug.hs b/compiler/cmm/Debug.hs
index 428721a657..33595d8987 100644
--- a/compiler/cmm/Debug.hs
+++ b/compiler/cmm/Debug.hs
@@ -35,7 +35,10 @@ import PprCmmExpr      ( pprExpr )
 import SrcLoc
 import Util
 
-import Compiler.Hoopl
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
 
 import Data.Maybe
 import Data.List     ( minimumBy, nubBy )
diff --git a/compiler/cmm/Hoopl.hs b/compiler/cmm/Hoopl.hs
deleted file mode 100644
index 60cae8ab2b..0000000000
--- a/compiler/cmm/Hoopl.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Hoopl (
-    module Compiler.Hoopl,
-    module Hoopl.Dataflow,
-  ) where
-
-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
-import Outputable
-
-instance Outputable LabelSet where
-  ppr = ppr . setElems
-
-instance Outputable a => Outputable (LabelMap a) where
-  ppr = ppr . mapToList
diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs
new file mode 100644
index 0000000000..3623fcd242
--- /dev/null
+++ b/compiler/cmm/Hoopl/Block.hs
@@ -0,0 +1,327 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Block
+    ( C
+    , O
+    , MaybeO(..)
+    , IndexedCO
+    , Block(..)
+    , blockAppend
+    , blockCons
+    , blockFromList
+    , blockJoin
+    , blockJoinHead
+    , blockJoinTail
+    , blockSnoc
+    , blockSplit
+    , blockSplitHead
+    , blockSplitTail
+    , blockToList
+    , emptyBlock
+    , firstNode
+    , foldBlockNodesB
+    , foldBlockNodesB3
+    , foldBlockNodesF
+    , isEmptyBlock
+    , lastNode
+    , mapBlock
+    , mapBlock'
+    , mapBlock3'
+    , replaceFirstNode
+    , replaceLastNode
+    ) where
+
+
+-- -----------------------------------------------------------------------------
+-- Shapes: Open and Closed
+
+-- | Used at the type level to indicate an "open" structure with
+-- a unique, unnamed control-flow edge flowing in or out.
+-- "Fallthrough" and concatenation are permitted at an open point.
+data O
+
+-- | Used at the type level to indicate a "closed" structure which
+-- supports control transfer only through the use of named
+-- labels---no "fallthrough" is permitted.  The number of control-flow
+-- edges is unconstrained.
+data C
+
+-- | Either type indexed by closed/open using type families
+type family IndexedCO ex a b :: *
+type instance IndexedCO C a _b = a
+type instance IndexedCO O _a b = b
+
+-- | Maybe type indexed by open/closed
+data MaybeO ex t where
+  JustO    :: t -> MaybeO O t
+  NothingO ::      MaybeO C t
+
+-- | Maybe type indexed by closed/open
+data MaybeC ex t where
+  JustC    :: t -> MaybeC C t
+  NothingC ::      MaybeC O t
+
+
+instance Functor (MaybeO ex) where
+  fmap _ NothingO = NothingO
+  fmap f (JustO a) = JustO (f a)
+
+instance Functor (MaybeC ex) where
+  fmap _ NothingC = NothingC
+  fmap f (JustC a) = JustC (f a)
+
+-- -----------------------------------------------------------------------------
+-- The Block type
+
+-- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).
+-- Open at the entry means single entry, mutatis mutandis for exit.
+-- A closed/closed block is a /basic/ block and can't be extended further.
+-- Clients should avoid manipulating blocks and should stick to either nodes
+-- or graphs.
+data Block n e x where
+  BlockCO  :: n C O -> Block n O O          -> Block n C O
+  BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C
+  BlockOC  ::          Block n O O -> n O C -> Block n O C
+
+  BNil    :: Block n O O
+  BMiddle :: n O O                      -> Block n O O
+  BCat    :: Block n O O -> Block n O O -> Block n O O
+  BSnoc   :: Block n O O -> n O O       -> Block n O O
+  BCons   :: n O O       -> Block n O O -> Block n O O
+
+
+-- -----------------------------------------------------------------------------
+-- Simple operations on Blocks
+
+-- Predicates
+
+isEmptyBlock :: Block n e x -> Bool
+isEmptyBlock BNil       = True
+isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r
+isEmptyBlock _          = False
+
+
+-- Building
+
+emptyBlock :: Block n O O
+emptyBlock = BNil
+
+blockCons :: n O O -> Block n O x -> Block n O x
+blockCons n b = case b of
+  BlockOC b l  -> (BlockOC $! (n `blockCons` b)) l
+  BNil{}    -> BMiddle n
+  BMiddle{} -> n `BCons` b
+  BCat{}    -> n `BCons` b
+  BSnoc{}   -> n `BCons` b
+  BCons{}   -> n `BCons` b
+
+blockSnoc :: Block n e O -> n O O -> Block n e O
+blockSnoc b n = case b of
+  BlockCO f b -> BlockCO f $! (b `blockSnoc` n)
+  BNil{}      -> BMiddle n
+  BMiddle{}   -> b `BSnoc` n
+  BCat{}      -> b `BSnoc` n
+  BSnoc{}     -> b `BSnoc` n
+  BCons{}     -> b `BSnoc` n
+
+blockJoinHead :: n C O -> Block n O x -> Block n C x
+blockJoinHead f (BlockOC b l) = BlockCC f b l
+blockJoinHead f b = BlockCO f BNil `cat` b
+
+blockJoinTail :: Block n e O -> n O C -> Block n e C
+blockJoinTail (BlockCO f b) t = BlockCC f b t
+blockJoinTail b t = b `cat` BlockOC BNil t
+
+blockJoin :: n C O -> Block n O O -> n O C -> Block n C C
+blockJoin f b t = BlockCC f b t
+
+blockAppend :: Block n e O -> Block n O x -> Block n e x
+blockAppend = cat
+
+
+-- Taking apart
+
+firstNode :: Block n C x -> n C O
+firstNode (BlockCO n _)   = n
+firstNode (BlockCC n _ _) = n
+
+lastNode :: Block n x C -> n O C
+lastNode (BlockOC   _ n) = n
+lastNode (BlockCC _ _ n) = n
+
+blockSplitHead :: Block n C x -> (n C O, Block n O x)
+blockSplitHead (BlockCO n b)   = (n, b)
+blockSplitHead (BlockCC n b t) = (n, BlockOC b t)
+
+blockSplitTail :: Block n e C -> (Block n e O, n O C)
+blockSplitTail (BlockOC b n)   = (b, n)
+blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
+
+-- | Split a closed block into its entry node, open middle block, and
+-- exit node.
+blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
+blockSplit (BlockCC f b t) = (f, b, t)
+
+blockToList :: Block n O O -> [n O O]
+blockToList b = go b []
+   where go :: Block n O O -> [n O O] -> [n O O]
+         go BNil         r = r
+         go (BMiddle n)  r = n : r
+         go (BCat b1 b2) r = go b1 $! go b2 r
+         go (BSnoc b1 n) r = go b1 (n:r)
+         go (BCons n b1) r = n : go b1 r
+
+blockFromList :: [n O O] -> Block n O O
+blockFromList = foldr BCons BNil
+
+-- Modifying
+
+replaceFirstNode :: Block n C x -> n C O -> Block n C x
+replaceFirstNode (BlockCO _ b)   f = BlockCO f b
+replaceFirstNode (BlockCC _ b n) f = BlockCC f b n
+
+replaceLastNode :: Block n x C -> n O C -> Block n x C
+replaceLastNode (BlockOC   b _) n = BlockOC b n
+replaceLastNode (BlockCC l b _) n = BlockCC l b n
+
+-- -----------------------------------------------------------------------------
+-- General concatenation
+
+cat :: Block n e O -> Block n O x -> Block n e x
+cat x y = case x of
+  BNil -> y
+
+  BlockCO l b1 -> case y of
+                   BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n
+                   BNil         -> x
+                   BMiddle _    -> BlockCO l $! (b1 `cat` y)
+                   BCat{}       -> BlockCO l $! (b1 `cat` y)
+                   BSnoc{}      -> BlockCO l $! (b1 `cat` y)
+                   BCons{}      -> BlockCO l $! (b1 `cat` y)
+
+  BMiddle n -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle{}     -> BCons n y
+                   BCat{}        -> BCons n y
+                   BSnoc{}       -> BCons n y
+                   BCons{}       -> BCons n y
+
+  BCat{} -> case y of
+                   BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+  BSnoc{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+
+  BCons{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping
+
+-- | map a function over the nodes of a 'Block'
+mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
+mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)
+mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)
+mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)
+mapBlock _  BNil           = BNil
+mapBlock f (BMiddle n)     = BMiddle (f n)
+mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)
+mapBlock f (BSnoc b n)     = BSnoc   (mapBlock f b)  (f n)
+mapBlock f (BCons n b)     = BCons   (f n)  (mapBlock f b)
+
+-- | A strict 'mapBlock'
+mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)
+mapBlock' f = mapBlock3' (f, f, f)
+
+-- | map over a block, with different functions to apply to first nodes,
+-- middle nodes and last nodes respectively.  The map is strict.
+--
+mapBlock3' :: forall n n' e x .
+             ( n C O -> n' C O
+             , n O O -> n' O O,
+               n O C -> n' O C)
+          -> Block n e x -> Block n' e x
+mapBlock3' (f, m, l) b = go b
+  where go :: forall e x . Block n e x -> Block n' e x
+        go (BlockOC b y)   = (BlockOC $! go b) $! l y
+        go (BlockCO x b)   = (BlockCO $! f x) $! (go b)
+        go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)
+        go BNil            = BNil
+        go (BMiddle n)     = BMiddle $! m n
+        go (BCat x y)      = (BCat $! go x) $! (go y)
+        go (BSnoc x n)     = (BSnoc $! go x) $! (m n)
+        go (BCons n x)     = (BCons $! m n) $! (go x)
+
+-- -----------------------------------------------------------------------------
+-- Folding
+
+
+-- | Fold a function over every node in a block, forward or backward.
+-- The fold function must be polymorphic in the shape of the nodes.
+foldBlockNodesF3 :: forall n a b c .
+                   ( n C O       -> a -> b
+                   , n O O       -> b -> b
+                   , n O C       -> b -> c)
+                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
+foldBlockNodesF  :: forall n a .
+                    (forall e x . n e x       -> a -> a)
+                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
+foldBlockNodesB3 :: forall n a b c .
+                   ( n C O       -> b -> c
+                   , n O O       -> b -> b
+                   , n O C       -> a -> b)
+                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
+foldBlockNodesB  :: forall n a .
+                    (forall e x . n e x       -> a -> a)
+                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
+
+foldBlockNodesF3 (ff, fm, fl) = block
+  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
+        block (BMiddle node)    = fm node
+        block (b1 `BCat`    b2) = block b1 `cat` block b2
+        block (b1 `BSnoc` n)    = block b1 `cat` fm n
+        block (n `BCons` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
+        cat f f' = f' . f
+
+foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
+
+foldBlockNodesB3 (ff, fm, fl) = block
+  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
+        block (BMiddle node)    = fm node
+        block (b1 `BCat`    b2) = block b1 `cat` block b2
+        block (b1 `BSnoc` n)    = block b1 `cat` fm n
+        block (n `BCons` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
+        cat f f' = f . f'
+
+foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
+
diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs
new file mode 100644
index 0000000000..679057626b
--- /dev/null
+++ b/compiler/cmm/Hoopl/Collections.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Collections
+    ( IsSet(..)
+    , setInsertList, setDeleteList, setUnions
+    , IsMap(..)
+    , mapInsertList, mapDeleteList, mapUnions
+    ) where
+
+import Data.List (foldl', foldl1')
+
+class IsSet set where
+  type ElemOf set
+
+  setNull :: set -> Bool
+  setSize :: set -> Int
+  setMember :: ElemOf set -> set -> Bool
+
+  setEmpty :: set
+  setSingleton :: ElemOf set -> set
+  setInsert :: ElemOf set -> set -> set
+  setDelete :: ElemOf set -> set -> set
+
+  setUnion :: set -> set -> set
+  setDifference :: set -> set -> set
+  setIntersection :: set -> set -> set
+  setIsSubsetOf :: set -> set -> Bool
+
+  setFold :: (ElemOf set -> b -> b) -> b -> set -> b
+
+  setElems :: set -> [ElemOf set]
+  setFromList :: [ElemOf set] -> set
+
+-- Helper functions for IsSet class
+setInsertList :: IsSet set => [ElemOf set] -> set -> set
+setInsertList keys set = foldl' (flip setInsert) set keys
+
+setDeleteList :: IsSet set => [ElemOf set] -> set -> set
+setDeleteList keys set = foldl' (flip setDelete) set keys
+
+setUnions :: IsSet set => [set] -> set
+setUnions [] = setEmpty
+setUnions sets = foldl1' setUnion sets
+
+
+class IsMap map where
+  type KeyOf map
+
+  mapNull :: map a -> Bool
+  mapSize :: map a -> Int
+  mapMember :: KeyOf map -> map a -> Bool
+  mapLookup :: KeyOf map -> map a -> Maybe a
+  mapFindWithDefault :: a -> KeyOf map -> map a -> a
+
+  mapEmpty :: map a
+  mapSingleton :: KeyOf map -> a -> map a
+  mapInsert :: KeyOf map -> a -> map a -> map a
+  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
+  mapDelete :: KeyOf map -> map a -> map a
+
+  mapUnion :: map a -> map a -> map a
+  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
+  mapDifference :: map a -> map a -> map a
+  mapIntersection :: map a -> map a -> map a
+  mapIsSubmapOf :: Eq a => map a -> map a -> Bool
+
+  mapMap :: (a -> b) -> map a -> map b
+  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
+  mapFold :: (a -> b -> b) -> b -> map a -> b
+  mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b
+  mapFilter :: (a -> Bool) -> map a -> map a
+
+  mapElems :: map a -> [a]
+  mapKeys :: map a -> [KeyOf map]
+  mapToList :: map a -> [(KeyOf map, a)]
+  mapFromList :: [(KeyOf map, a)] -> map a
+  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a
+
+-- Helper functions for IsMap class
+mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a
+mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs
+
+mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a
+mapDeleteList keys map = foldl' (flip mapDelete) map keys
+
+mapUnions :: IsMap map => [map a] -> map a
+mapUnions [] = mapEmpty
+mapUnions maps = foldl1' mapUnion maps
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index 6b33cf146b..c2ace502b3 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -42,10 +42,14 @@ import Data.Maybe
 import Data.IntSet (IntSet)
 import qualified Data.IntSet as IntSet
 
--- Hide definitions from Hoopl's Dataflow module.
-import Compiler.Hoopl hiding ( DataflowLattice, OldFact, NewFact, JoinFun
-                             , fact_bot, fact_join, joinOutFacts, mkFactBase
-                             )
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
+import Hoopl.Label
+
+type family   Fact x f :: *
+type instance Fact C f = FactBase f
+type instance Fact O f = f
 
 newtype OldFact a = OldFact a
 
diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs
new file mode 100644
index 0000000000..87da072458
--- /dev/null
+++ b/compiler/cmm/Hoopl/Graph.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Graph
+    ( Body
+    , Graph
+    , Graph'(..)
+    , NonLocal(..)
+    , addBlock
+    , bodyList
+    , emptyBody
+    , labelsDefined
+    , mapGraph
+    , mapGraphBlocks
+    , postorder_dfs_from
+    ) where
+
+
+import Hoopl.Label
+import Hoopl.Block
+import Hoopl.Collections
+
+-- | A (possibly empty) collection of closed/closed blocks
+type Body n = LabelMap (Block n C C)
+
+-- | @Body@ abstracted over @block@
+type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
+
+-------------------------------
+-- | Gives access to the anchor points for
+-- nonlocal edges as well as the edges themselves
+class NonLocal thing where
+  entryLabel :: thing C x -> Label   -- ^ The label of a first node or block
+  successors :: thing e C -> [Label] -- ^ Gives control-flow successors
+
+instance NonLocal n => NonLocal (Block n) where
+  entryLabel (BlockCO f _)   = entryLabel f
+  entryLabel (BlockCC f _ _) = entryLabel f
+
+  successors (BlockOC   _ n) = successors n
+  successors (BlockCC _ _ n) = successors n
+
+
+emptyBody :: Body' block n
+emptyBody = mapEmpty
+
+bodyList :: Body' block n -> [(Label,block n C C)]
+bodyList body = mapToList body
+
+addBlock :: NonLocal thing
+         => thing C C -> LabelMap (thing C C)
+         -> LabelMap (thing C C)
+addBlock b body
+  | mapMember lbl body = error $ "duplicate label " ++ show lbl ++ " in graph"
+  | otherwise          = mapInsert lbl b body
+  where lbl = entryLabel b
+
+
+-- ---------------------------------------------------------------------------
+-- Graph
+
+-- | A control-flow graph, which may take any of four shapes (O/O,
+-- O/C, C/O, C/C).  A graph open at the entry has a single,
+-- distinguished, anonymous entry point; if a graph is closed at the
+-- entry, its entry point(s) are supplied by a context.
+type Graph = Graph' Block
+
+-- | @Graph'@ is abstracted over the block type, so that we can build
+-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
+-- needs this).
+data Graph' block (n :: * -> * -> *) e x where
+  GNil  :: Graph' block n O O
+  GUnit :: block n O O -> Graph' block n O O
+  GMany :: MaybeO e (block n O C)
+        -> Body' block n
+        -> MaybeO x (block n C O)
+        -> Graph' block n e x
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping over graphs
+
+-- | Maps over all nodes in a graph.
+mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
+mapGraph f = mapGraphBlocks (mapBlock f)
+
+-- | Function 'mapGraphBlocks' enables a change of representation of blocks,
+-- nodes, or both.  It lifts a polymorphic block transform into a polymorphic
+-- graph transform.  When the block representation stabilizes, a similar
+-- function should be provided for blocks.
+mapGraphBlocks :: forall block n block' n' e x .
+                  (forall e x . block n e x -> block' n' e x)
+               -> (Graph' block n e x -> Graph' block' n' e x)
+
+mapGraphBlocks f = map
+  where map :: Graph' block n e x -> Graph' block' n' e x
+        map GNil = GNil
+        map (GUnit b) = GUnit (f b)
+        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
+
+-- -----------------------------------------------------------------------------
+-- Extracting Labels from graphs
+
+labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
+              -> LabelSet
+labelsDefined GNil      = setEmpty
+labelsDefined (GUnit{}) = setEmpty
+labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body
+  where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet
+        addEntry label _ labels = setInsert label labels
+        exitLabel :: MaybeO x (block n C O) -> LabelSet
+        exitLabel NothingO  = setEmpty
+        exitLabel (JustO b) = setSingleton (entryLabel b)
+
+
+----------------------------------------------------------------
+
+class LabelsPtr l where
+  targetLabels :: l -> [Label]
+
+instance NonLocal n => LabelsPtr (n e C) where
+  targetLabels n = successors n
+
+instance LabelsPtr Label where
+  targetLabels l = [l]
+
+instance LabelsPtr LabelSet where
+  targetLabels = setElems
+
+instance LabelsPtr l => LabelsPtr [l] where
+  targetLabels = concatMap targetLabels
+
+-- | This is the most important traversal over this data structure.  It drops
+-- unreachable code and puts blocks in an order that is good for solving forward
+-- dataflow problems quickly.  The reverse order is good for solving backward
+-- dataflow problems quickly.  The forward order is also reasonably good for
+-- emitting instructions, except that it will not usually exploit Forrest
+-- Baskett's trick of eliminating the unconditional branch from a loop.  For
+-- that you would need a more serious analysis, probably based on dominators, to
+-- identify loop headers.
+--
+-- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
+-- representation, when for most purposes the plain 'Graph' representation is
+-- more mathematically elegant (but results in more complicated code).
+--
+-- Here's an easy way to go wrong!  Consider
+-- @
+--      A -> [B,C]
+--      B -> D
+--      C -> D
+-- @
+-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
+-- Better to get [A,B,C,D]
+
+
+-- | Traversal: 'postorder_dfs' returns a list of blocks reachable
+-- from the entry of enterable graph. The entry and exit are *not* included.
+-- The list has the following property:
+--
+--      Say a "back reference" exists if one of a block's
+--      control-flow successors precedes it in the output list
+--
+--      Then there are as few back references as possible
+--
+-- The output is suitable for use in
+-- a forward dataflow problem.  For a backward problem, simply reverse
+-- the list.  ('postorder_dfs' is sufficiently tricky to implement that
+-- one doesn't want to try and maintain both forward and backward
+-- versions.)
+
+postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
+                          => LabelMap (block C C) -> e -> LabelSet -> [block C C]
+postorder_dfs_from_except blocks b visited =
+ vchildren (get_children b) (\acc _visited -> acc) [] visited
+ where
+   vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
+   vnode block cont acc visited =
+        if setMember id visited then
+            cont acc visited
+        else
+            let cont' acc visited = cont (block:acc) visited in
+            vchildren (get_children block) cont' acc (setInsert id visited)
+      where id = entryLabel block
+   vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
+   vchildren bs cont acc visited = next bs acc visited
+      where next children acc visited =
+                case children of []     -> cont acc visited
+                                 (b:bs) -> vnode b (next bs) acc visited
+   get_children :: forall l. LabelsPtr l => l -> [block C C]
+   get_children block = foldr add_id [] $ targetLabels block
+   add_id id rst = case lookupFact id blocks of
+                      Just b -> b : rst
+                      Nothing -> rst
+
+postorder_dfs_from
+    :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
+postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty
diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs
new file mode 100644
index 0000000000..5ee4f72fc3
--- /dev/null
+++ b/compiler/cmm/Hoopl/Label.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Label
+    ( Label
+    , LabelMap
+    , LabelSet
+    , FactBase
+    , lookupFact
+    , uniqueToLbl
+    ) where
+
+import Outputable
+
+import Hoopl.Collections
+-- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
+import Hoopl.Unique
+
+import Unique (Uniquable(..))
+
+-----------------------------------------------------------------------------
+--              Label
+-----------------------------------------------------------------------------
+
+newtype Label = Label { lblToUnique :: Unique }
+  deriving (Eq, Ord)
+
+uniqueToLbl :: Unique -> Label
+uniqueToLbl = Label
+
+instance Show Label where
+  show (Label n) = "L" ++ show n
+
+instance Uniquable Label where
+  getUnique label = getUnique (lblToUnique label)
+
+instance Outputable Label where
+  ppr label = ppr (getUnique label)
+
+-----------------------------------------------------------------------------
+-- LabelSet
+
+newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)
+
+instance IsSet LabelSet where
+  type ElemOf LabelSet = Label
+
+  setNull (LS s) = setNull s
+  setSize (LS s) = setSize s
+  setMember (Label k) (LS s) = setMember k s
+
+  setEmpty = LS setEmpty
+  setSingleton (Label k) = LS (setSingleton k)
+  setInsert (Label k) (LS s) = LS (setInsert k s)
+  setDelete (Label k) (LS s) = LS (setDelete k s)
+
+  setUnion (LS x) (LS y) = LS (setUnion x y)
+  setDifference (LS x) (LS y) = LS (setDifference x y)
+  setIntersection (LS x) (LS y) = LS (setIntersection x y)
+  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
+
+  setFold k z (LS s) = setFold (k . uniqueToLbl) z s
+
+  setElems (LS s) = map uniqueToLbl (setElems s)
+  setFromList ks = LS (setFromList (map lblToUnique ks))
+
+-----------------------------------------------------------------------------
+-- LabelMap
+
+newtype LabelMap v = LM (UniqueMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap LabelMap where
+  type KeyOf LabelMap = Label
+
+  mapNull (LM m) = mapNull m
+  mapSize (LM m) = mapSize m
+  mapMember (Label k) (LM m) = mapMember k m
+  mapLookup (Label k) (LM m) = mapLookup k m
+  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
+
+  mapEmpty = LM mapEmpty
+  mapSingleton (Label k) v = LM (mapSingleton k v)
+  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
+  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
+  mapDelete (Label k) (LM m) = LM (mapDelete k m)
+
+  mapUnion (LM x) (LM y) = LM (mapUnion x y)
+  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y)
+  mapDifference (LM x) (LM y) = LM (mapDifference x y)
+  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
+  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
+
+  mapMap f (LM m) = LM (mapMap f m)
+  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m)
+  mapFold k z (LM m) = mapFold k z m
+  mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m
+  mapFilter f (LM m) = LM (mapFilter f m)
+
+  mapElems (LM m) = mapElems m
+  mapKeys (LM m) = map uniqueToLbl (mapKeys m)
+  mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m]
+  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
+  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
+
+-----------------------------------------------------------------------------
+-- Instances
+
+instance Outputable LabelSet where
+  ppr = ppr . setElems
+
+instance Outputable a => Outputable (LabelMap a) where
+  ppr = ppr . mapToList
+
+-----------------------------------------------------------------------------
+-- FactBase
+
+type FactBase f = LabelMap f
+
+lookupFact :: Label -> FactBase f -> Maybe f
+lookupFact = mapLookup
diff --git a/compiler/cmm/Hoopl/Unique.hs b/compiler/cmm/Hoopl/Unique.hs
new file mode 100644
index 0000000000..f27961bb28
--- /dev/null
+++ b/compiler/cmm/Hoopl/Unique.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Unique
+    ( Unique
+    , UniqueMap
+    , UniqueSet
+    , intToUnique
+    ) where
+
+import qualified Data.IntMap as M
+import qualified Data.IntSet as S
+
+import Hoopl.Collections
+
+
+-----------------------------------------------------------------------------
+--              Unique
+-----------------------------------------------------------------------------
+
+type Unique = Int
+
+intToUnique :: Int -> Unique
+intToUnique = id
+
+-----------------------------------------------------------------------------
+-- UniqueSet
+
+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show)
+
+instance IsSet UniqueSet where
+  type ElemOf UniqueSet = Unique
+
+  setNull (US s) = S.null s
+  setSize (US s) = S.size s
+  setMember k (US s) = S.member k s
+
+  setEmpty = US S.empty
+  setSingleton k = US (S.singleton k)
+  setInsert k (US s) = US (S.insert k s)
+  setDelete k (US s) = US (S.delete k s)
+
+  setUnion (US x) (US y) = US (S.union x y)
+  setDifference (US x) (US y) = US (S.difference x y)
+  setIntersection (US x) (US y) = US (S.intersection x y)
+  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
+
+  setFold k z (US s) = S.foldr k z s
+
+  setElems (US s) = S.elems s
+  setFromList ks = US (S.fromList ks)
+
+-----------------------------------------------------------------------------
+-- UniqueMap
+
+newtype UniqueMap v = UM (M.IntMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap UniqueMap where
+  type KeyOf UniqueMap = Unique
+
+  mapNull (UM m) = M.null m
+  mapSize (UM m) = M.size m
+  mapMember k (UM m) = M.member k m
+  mapLookup k (UM m) = M.lookup k m
+  mapFindWithDefault def k (UM m) = M.findWithDefault def k m
+
+  mapEmpty = UM M.empty
+  mapSingleton k v = UM (M.singleton k v)
+  mapInsert k v (UM m) = UM (M.insert k v m)
+  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
+  mapDelete k (UM m) = UM (M.delete k m)
+
+  mapUnion (UM x) (UM y) = UM (M.union x y)
+  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y)
+  mapDifference (UM x) (UM y) = UM (M.difference x y)
+  mapIntersection (UM x) (UM y) = UM (M.intersection x y)
+  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
+
+  mapMap f (UM m) = UM (M.map f m)
+  mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m)
+  mapFold k z (UM m) = M.foldr k z m
+  mapFoldWithKey k z (UM m) = M.foldrWithKey (k . intToUnique) z m
+  mapFilter f (UM m) = UM (M.filter f m)
+
+  mapElems (UM m) = M.elems m
+  mapKeys (UM m) = M.keys m
+  mapToList (UM m) = M.toList m
+  mapFromList assocs = UM (M.fromList assocs)
+  mapFromListWith f assocs = UM (M.fromListWith f assocs)
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 81d9c0f540..62dfd34da3 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -26,7 +26,9 @@ import Cmm
 import CmmCallConv
 import CmmSwitch (SwitchTargets)
 
-import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
 import DynFlags
 import FastString
 import ForeignCall
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 21ed6f6516..7d36c120b0 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -31,7 +31,9 @@ import CLabel
 import ForeignCall
 import Cmm hiding (pprBBlock)
 import PprCmm ()
-import Hoopl
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
 import CmmUtils
 import CmmSwitch
 
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index d20f013cb8..dbd4619416 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -53,7 +53,8 @@ import Util
 import PprCore ()
 
 import BasicTypes
-import Compiler.Hoopl
+import Hoopl.Block
+import Hoopl.Graph
 import Data.List
 import Prelude hiding (succ)
 
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index d8f268d2bd..7184153f10 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -14,7 +14,8 @@ module CgUtils ( fixStgRegisters ) where
 
 import CodeGen.Platform
 import Cmm
-import Hoopl
+import Hoopl.Block
+import Hoopl.Graph
 import CmmUtils
 import CLabel
 import DynFlags
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index a0b822dfd6..db62985e3c 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -36,7 +36,7 @@ import StgCmmEnv
 
 import MkGraph
 
-import Hoopl
+import Hoopl.Label
 import SMRep
 import BlockId
 import Cmm
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 754cbfb19e..5e62183fb5 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -64,7 +64,7 @@ module StgCmmMonad (
 import Cmm
 import StgCmmClosure
 import DynFlags
-import Hoopl
+import Hoopl.Collections
 import Maybes
 import MkGraph
 import BlockId
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index d11a42bccc..1427a51bac 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -64,8 +64,7 @@ Library
                    transformers == 0.5.*,
                    ghc-boot   == @ProjectVersionMunged@,
                    ghc-boot-th == @ProjectVersionMunged@,
-                   ghci == @ProjectVersionMunged@,
-                   hoopl      >= 3.10.2 && < 3.11
+                   ghci == @ProjectVersionMunged@
 
     if os(windows)
         Build-Depends: Win32  >= 2.3 && < 2.6
@@ -546,8 +545,12 @@ Library
         Vectorise.Env
         Vectorise.Exp
         Vectorise
+        Hoopl.Block
+        Hoopl.Collections
         Hoopl.Dataflow
-        Hoopl
+        Hoopl.Graph
+        Hoopl.Label
+        Hoopl.Unique
 --        CgInfoTbls used in ghci/DebuggerUtils
 --        CgHeapery  mkVirtHeapOffsets used in ghci
 
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 5596d599c4..71b9996ceb 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -19,7 +19,8 @@ import BlockId
 import CgUtils ( fixStgRegisters )
 import Cmm
 import CmmUtils
-import Hoopl
+import Hoopl.Block
+import Hoopl.Collections
 import PprCmm
 
 import BufWrite
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index bf84782537..f6ff838d14 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -18,7 +18,9 @@ import Cmm
 import PprCmm
 import CmmUtils
 import CmmSwitch
-import Hoopl
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
 
 import DynFlags
 import FastString
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index b4cfd8e310..e7a3efdfbe 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -65,7 +65,9 @@ import BlockId
 import CgUtils          ( fixStgRegisters )
 import Cmm
 import CmmUtils
-import Hoopl
+import Hoopl.Collections
+import Hoopl.Label
+import Hoopl.Block
 import CmmOpt           ( cmmMachOpFold )
 import PprCmm
 import CLabel
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
index 1066169639..afeac030fd 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -26,7 +26,8 @@ import qualified Data.Map as Map
 import System.FilePath
 import System.Directory ( getCurrentDirectory )
 
-import qualified Compiler.Hoopl as H
+import qualified Hoopl.Label as H
+import qualified Hoopl.Collections as H
 
 -- | Generate DWARF/debug information
 dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
index ff05cbd111..515d4f3d85 100644
--- a/compiler/nativeGen/Instruction.hs
+++ b/compiler/nativeGen/Instruction.hs
@@ -17,7 +17,8 @@ where
 import Reg
 
 import BlockId
-import Hoopl
+import Hoopl.Collections
+import Hoopl.Label
 import DynFlags
 import Cmm hiding (topInfoTable)
 import Platform
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
index 34aaa17701..6af0df5b01 100644
--- a/compiler/nativeGen/NCGMonad.hs
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -42,7 +42,8 @@ import Format
 import TargetReg
 
 import BlockId
-import Hoopl
+import Hoopl.Collections
+import Hoopl.Label
 import CLabel           ( CLabel, mkAsmTempLabel )
 import Debug
 import FastString       ( FastString )
@@ -54,8 +55,6 @@ import Module
 
 import Control.Monad    ( liftM, ap )
 
-import Compiler.Hoopl   ( LabelMap, Label )
-
 data NatM_State
         = NatM_State {
                 natm_us          :: UniqSupply,
diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs
index d6005745b3..bef0a21235 100644
--- a/compiler/nativeGen/PIC.hs
+++ b/compiler/nativeGen/PIC.hs
@@ -58,7 +58,7 @@ import Reg
 import NCGMonad
 
 
-import Hoopl
+import Hoopl.Collections
 import Cmm
 import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,
                           mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index a1a205bb95..1e88a1d025 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -46,7 +46,8 @@ import Cmm
 import CmmUtils
 import CmmSwitch
 import CLabel
-import Hoopl
+import Hoopl.Block
+import Hoopl.Graph
 
 -- The rest:
 import OrdList
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index b8b5043d96..eb179c5a99 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -33,7 +33,8 @@ import Reg
 
 import CodeGen.Platform
 import BlockId
-import Hoopl
+import Hoopl.Collections
+import Hoopl.Label
 import DynFlags
 import Cmm
 import CmmInfo
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 7f30c5b7ee..63d01c3913 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -20,7 +20,8 @@ import RegClass
 import TargetReg
 
 import Cmm hiding (topInfoTable)
-import Hoopl
+import Hoopl.Collections
+import Hoopl.Label
 
 import CLabel
 
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
index 9a3808ad9a..0014ab6fed 100644
--- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -12,7 +12,7 @@ import Instruction
 import Reg
 import Cmm hiding (RegSet)
 import BlockId
-import Hoopl
+import Hoopl.Collections
 
 import MonadUtils
 import State
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
index 0811147eda..faef4037c2 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -33,7 +33,6 @@ import Instruction
 import Reg
 
 import BlockId
-import Hoopl
 import Cmm
 import UniqSet
 import UniqFM
@@ -41,6 +40,7 @@ import Unique
 import State
 import Outputable
 import Platform
+import Hoopl.Collections
 
 import Data.List
 import Data.Maybe
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
index 82976c08aa..9811f1a64b 100644
--- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -20,7 +20,7 @@ import Reg
 
 import GraphBase
 
-import Hoopl (mapLookup)
+import Hoopl.Collections (mapLookup)
 import Cmm
 import UniqFM
 import UniqSet
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index 1b639c9757..c262b2b059 100644
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -17,7 +17,7 @@ import Instruction
 import Reg
 
 import BlockId
-import Hoopl
+import Hoopl.Collections
 import Digraph
 import DynFlags
 import Outputable
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index b7721880c3..2ba682ad17 100644
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -118,7 +118,7 @@ import Instruction
 import Reg
 
 import BlockId
-import Hoopl
+import Hoopl.Collections
 import Cmm hiding (RegSet)
 
 import Digraph
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 53e09285c4..e66139786b 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -39,7 +39,8 @@ import Reg
 import Instruction
 
 import BlockId
-import Hoopl
+import Hoopl.Collections
+import Hoopl.Label
 import Cmm hiding (RegSet, emptyRegSet)
 import PprCmm()
 
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 3e9058bdfd..71d320fa63 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -44,7 +44,8 @@ import BlockId
 import Cmm
 import CmmUtils
 import CmmSwitch
-import Hoopl
+import Hoopl.Block
+import Hoopl.Graph
 import PIC
 import Reg
 import CLabel
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index 5d6b6f70dc..88b04b952a 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -39,7 +39,8 @@ import PprBase
 import Cmm hiding (topInfoTable)
 import PprCmm()
 import CLabel
-import Hoopl
+import Hoopl.Label
+import Hoopl.Collections
 
 import Unique           ( Uniquable(..), pprUniqueAlways )
 import Outputable
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index baa5c8f1b8..341fa43dbc 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -55,7 +55,8 @@ import PprCmm           ()
 import CmmUtils
 import CmmSwitch
 import Cmm
-import Hoopl
+import Hoopl.Block
+import Hoopl.Graph
 import CLabel
 import CoreSyn          ( Tickish(..) )
 import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 16e08f3a97..71f50e9d2a 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -26,7 +26,8 @@ import Reg
 import TargetReg
 
 import BlockId
-import Hoopl
+import Hoopl.Collections
+import Hoopl.Label
 import CodeGen.Platform
 import Cmm
 import FastString
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index bd957b45de..fce432a3dc 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -32,7 +32,8 @@ import Reg
 import PprBase
 
 
-import Hoopl
+import Hoopl.Collections
+import Hoopl.Label
 import BasicTypes       (Alignment)
 import DynFlags
 import Cmm              hiding (topInfoTable)
diff --git a/ghc.mk b/ghc.mk
index 3fafcf0ac9..cdab331486 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -430,7 +430,7 @@ else # CLEANING
 # programs such as GHC and ghc-pkg, that we do not assume the stage0
 # compiler already has installed (or up-to-date enough).
 
-PACKAGES_STAGE0 = binary Cabal/Cabal hpc ghc-boot-th ghc-boot hoopl transformers template-haskell ghci
+PACKAGES_STAGE0 = binary Cabal/Cabal hpc ghc-boot-th ghc-boot transformers template-haskell ghci
 ifeq "$(Windows_Host)" "NO"
 PACKAGES_STAGE0 += terminfo
 endif
@@ -461,7 +461,6 @@ PACKAGES_STAGE1 += Cabal/Cabal
 PACKAGES_STAGE1 += ghc-boot-th
 PACKAGES_STAGE1 += ghc-boot
 PACKAGES_STAGE1 += template-haskell
-PACKAGES_STAGE1 += hoopl
 PACKAGES_STAGE1 += transformers
 PACKAGES_STAGE1 += ghc-compact
 
diff --git a/libraries/hoopl b/libraries/hoopl
deleted file mode 160000
-Subproject ac24864c2db7951a6f34674e2b11b69d37ef84f
diff --git a/packages b/packages
index a99bac6561..6ee80712f2 100644
--- a/packages
+++ b/packages
@@ -51,7 +51,6 @@ libraries/deepseq            -           -                               ssh://g
 libraries/directory          -           -                               ssh://git@github.com/haskell/directory.git
 libraries/filepath           -           -                               ssh://git@github.com/haskell/filepath.git
 libraries/haskeline          -           -                               https://github.com/judah/haskeline.git
-libraries/hoopl              -           -                               -
 libraries/hpc                -           -                               -
 libraries/pretty             -           -                               https://github.com/haskell/pretty.git
 libraries/process            -           -                               ssh://git@github.com/haskell/process.git