diff --git a/FAQ b/FAQ
--- a/FAQ
+++ b/FAQ
@@ -1,20 +0,0 @@
- > in GHC we quite often we want to get the entry or the last node of a block.
- > Currently that can take up to linear time in the length of a block, right?
- > Are there any plans to improve it, perhaps by changing the representation
- > of a block?
-
-Milan,
-
-The current representation can be either 'front-biased' or
-'back-biased' to make one of those operations constant time.
-The previous representation was always front-biased and we never noted
-any performance problems.
-
-If, and only if, you find a situation where you have measured a
-significant performance problem, I suggest that you wrap the existing
-block in a new block type that caches the information you need.
-The representation Graph' is polymorphic precisely to enable this sort
-of trickery; you'll see a different application in the dataflow
-module, where a fact is stored with every block.
-
-
diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2010, João Dias, Simon Peyton Jones, and Norman Ramsey
+Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones, and Norman Ramsey
 All rights reserved.
 
 Redistribution and use in source and binary forms, with or without
diff --git a/README b/README
--- a/README
+++ b/README
@@ -24,3 +24,5 @@
 
   cabal sdist
   cabal upload dist/something.tar.gz
+
+Developers, please see HOWTO-BRANCHES
diff --git a/hoopl.cabal b/hoopl.cabal
--- a/hoopl.cabal
+++ b/hoopl.cabal
@@ -1,14 +1,21 @@
 Name:                hoopl
-Version:             3.8.7.4
+Version:             3.9.0.0
 -- version 3.8.6.0 is the version that goes with the camera-ready Haskell'10 paper
 -- version 3.8.7.0 works with GHC 7
 -- version 3.8.7.1 adds some unnamed functions without breaking compatibility
 -- version 3.8.7.2 adds Compiler.Hoopl.Fuel.liftFuel
 -- version 3.8.7.4 re-exports runWithFuel
-Description:         Higher-order optimization library
+-- version 3.9.0.0 adds the new API for working with blocks, and lots of internal refactoring
+Description:
+  Higher-order optimization library
+  .
+  Changes in 3.9.0.0
+  .
+  * Lots of API changes; mainly a new API for working with Blocks
+
 License:             BSD3
 License-File:        LICENSE
-Author:              Norman Ramsey, João Dias, and Simon Peyton Jones
+Author:              Norman Ramsey, João Dias, Simon Marlow and Simon Peyton Jones
 Maintainer:          nr@cs.tufts.edu
 Homepage:            http://ghc.cs.tufts.edu/hoopl/
 Build-Type:          Simple
@@ -21,21 +28,21 @@
   Hs-Source-Dirs:    src
   Build-Depends:     base >= 3 && < 5, containers
   Exposed-Modules:   Compiler.Hoopl,
+                     Compiler.Hoopl.Internals,
                      Compiler.Hoopl.Wrappers,
                      Compiler.Hoopl.Passes.Dominator,
-                     Compiler.Hoopl.Passes.DList,
+                     Compiler.Hoopl.Passes.DList
 --                     Compiler.Hoopl.DataflowFold,
 --                     Compiler.Hoopl.OldDataflow,
-                     Compiler.Hoopl.GHC
-  Other-Modules:     Compiler.Hoopl.GraphUtil,
-                     -- GraphUtil should *never* be seen by clients.
-                     -- The remaining modules are hidden *provisionally*
-                     Compiler.Hoopl.Checkpoint,
+
+  -- The remaining modules are hidden *provisionally*
+  Other-modules:     Compiler.Hoopl.Checkpoint,
                      Compiler.Hoopl.Collections,
                      Compiler.Hoopl.Combinators,
                      Compiler.Hoopl.Dataflow,
                      Compiler.Hoopl.Debug,
-                     Compiler.Hoopl.Graph, 
+                     Compiler.Hoopl.Block,
+                     Compiler.Hoopl.Graph,
                      Compiler.Hoopl.Label,
                      Compiler.Hoopl.MkGraph,
                      Compiler.Hoopl.Fuel,
@@ -43,7 +50,6 @@
                      Compiler.Hoopl.Shape,
                      Compiler.Hoopl.Show, 
                      Compiler.Hoopl.Unique, 
-                     Compiler.Hoopl.Util,
                      Compiler.Hoopl.XUtil
 
   Ghc-Options:       -Wall -fno-warn-name-shadowing
diff --git a/src/Compiler/Hoopl.hs b/src/Compiler/Hoopl.hs
--- a/src/Compiler/Hoopl.hs
+++ b/src/Compiler/Hoopl.hs
@@ -4,6 +4,7 @@
 
 module Compiler.Hoopl
   ( module Compiler.Hoopl.Graph
+  , module Compiler.Hoopl.Block
   , module Compiler.Hoopl.MkGraph
   , module Compiler.Hoopl.XUtil
   , module Compiler.Hoopl.Collections
@@ -14,7 +15,6 @@
   , module Compiler.Hoopl.Combinators
   , module Compiler.Hoopl.Fuel
   , module Compiler.Hoopl.Unique
-  , module Compiler.Hoopl.Util
   , module Compiler.Hoopl.Debug
   , module Compiler.Hoopl.Show
   )
@@ -26,16 +26,12 @@
 import Compiler.Hoopl.Dataflow hiding ( wrapFR, wrapFR2, wrapBR, wrapBR2
                                       )
 import Compiler.Hoopl.Debug
-import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel)
-import Compiler.Hoopl.Graph hiding 
-   ( Body
-   , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast
-   )
-import Compiler.Hoopl.Graph (Body)
+import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel, runWithFuel)
+import Compiler.Hoopl.Block
+import Compiler.Hoopl.Graph hiding (splice, gSplice)
 import Compiler.Hoopl.Label hiding (uniqueToLbl, lblToUnique)
 import Compiler.Hoopl.MkGraph
 import Compiler.Hoopl.Pointed
 import Compiler.Hoopl.Show
-import Compiler.Hoopl.Util
 import Compiler.Hoopl.Unique hiding (uniqueToInt)
 import Compiler.Hoopl.XUtil
diff --git a/src/Compiler/Hoopl/Block.hs b/src/Compiler/Hoopl/Block.hs
new file mode 100644
--- /dev/null
+++ b/src/Compiler/Hoopl/Block.hs
@@ -0,0 +1,421 @@
+{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, ScopedTypeVariables, RankNTypes #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Safe #-}
+#endif
+
+module Compiler.Hoopl.Block (
+    -- * Shapes
+    O, C
+  , MaybeO(..), MaybeC(..)
+  , IndexedCO
+  , Shape(..)
+
+    -- * Blocks
+  , Block(..)
+
+    -- ** Predicates on Blocks
+  , isEmptyBlock
+
+    -- ** Constructing blocks
+  , emptyBlock, blockCons, blockSnoc
+  , blockJoinHead, blockJoinTail, blockJoin, blockJoinAny
+  , blockAppend
+
+    -- ** Deconstructing blocks
+  , firstNode, lastNode, endNodes
+  , blockSplitHead, blockSplitTail, blockSplit, blockSplitAny
+
+    -- ** Modifying blocks
+  , replaceFirstNode, replaceLastNode
+
+    -- ** Converting to and from lists
+  , blockToList, blockFromList
+
+    -- ** Maps and folds
+  , mapBlock, mapBlock', mapBlock3'
+  , foldBlockNodesF, foldBlockNodesF3
+  , foldBlockNodesB, foldBlockNodesB3
+
+    -- ** Biasing
+  , frontBiasBlock, backBiasBlock
+
+  ) 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)
+
+
+-- | Dynamic shape value
+data Shape ex where
+  Closed :: Shape C
+  Open   :: Shape O
+
+
+-- -----------------------------------------------------------------------------
+-- 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 `BCons` b) l
+  BNil{}    -> n `BCons` b
+  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 `BSnoc` n)
+  BNil{}      -> b `BSnoc` 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
+
+endNodes :: Block n C C -> (n C O, n O C)
+endNodes (BlockCC f _ l) = (f,l)
+
+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)
+
+blockSplitAny :: Block n e x
+              -> (MaybeC e (n C O), Block n O O, MaybeC x (n O C))
+blockSplitAny block = case block of
+  BlockCO f b   -> (JustC f,  b, NothingC)
+  BlockCC f b l -> (JustC f,  b, JustC l)
+  BlockOC   b l -> (NothingC, b, JustC l)
+  b@BNil        -> (NothingC, b, NothingC)
+  b@BMiddle{}   -> (NothingC, b, NothingC)
+  b@BCat{}      -> (NothingC, b, NothingC)
+  b@BCons{}     -> (NothingC, b, NothingC)
+  b@BSnoc{}     -> (NothingC, b, NothingC)
+
+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
+
+
+-- | Convert a list of nodes to a block. The entry and exit node must
+-- or must not be present depending on the shape of the block.
+--
+blockJoinAny :: (MaybeC e (n C O), Block n O O, MaybeC x (n O C)) -> Block n e x
+blockJoinAny (NothingC, m, NothingC)  = m
+blockJoinAny (NothingC, m, JustC l)   = BlockOC   m l
+blockJoinAny (JustC f, m, NothingC)   = BlockCO f m
+blockJoinAny (JustC f, m, JustC l)    = BlockCC f m l
+
+
+-- 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)
+
+
+----------------------------------------------------------------
+
+-- | A block is "front biased" if the left child of every
+-- concatenation operation is a node, not a general block; a
+-- front-biased block is analogous to an ordinary list.  If a block is
+-- front-biased, then its nodes can be traversed from front to back
+-- without general recusion; tail recursion suffices.  Not all shapes
+-- can be front-biased; a closed/open block is inherently back-biased.
+
+frontBiasBlock :: Block n e x -> Block n e x
+frontBiasBlock blk = case blk of
+   BlockCO f b   -> BlockCO f (fb b BNil)
+   BlockOC   b n -> BlockOC   (fb b BNil) n
+   BlockCC f b n -> BlockCC f (fb b BNil) n
+   b@BNil{}      -> fb b BNil
+   b@BMiddle{}   -> fb b BNil
+   b@BCat{}      -> fb b BNil
+   b@BSnoc{}     -> fb b BNil
+   b@BCons{}     -> fb b BNil
+ where
+   fb :: Block n O O -> Block n O O -> Block n O O
+   fb BNil        rest = rest
+   fb (BMiddle n) rest = BCons n rest
+   fb (BCat l r)  rest = fb l (fb r rest)
+   fb (BCons n b) rest = BCons n (fb b rest)
+   fb (BSnoc b n) rest = fb b (BCons n rest)
+
+-- | A block is "back biased" if the right child of every
+-- concatenation operation is a node, not a general block; a
+-- back-biased block is analogous to a snoc-list.  If a block is
+-- back-biased, then its nodes can be traversed from back to back
+-- without general recusion; tail recursion suffices.  Not all shapes
+-- can be back-biased; an open/closed block is inherently front-biased.
+
+backBiasBlock :: Block n e x -> Block n e x
+backBiasBlock blk = case blk of
+   BlockCO f b   -> BlockCO f (bb BNil b)
+   BlockOC   b n -> BlockOC   (bb BNil b) n
+   BlockCC f b n -> BlockCC f (bb BNil b) n
+   b@BNil{}      -> bb BNil b
+   b@BMiddle{}   -> bb BNil b
+   b@BCat{}      -> bb BNil b
+   b@BSnoc{}     -> bb BNil b
+   b@BCons{}     -> bb BNil b
+ where
+   bb :: Block n O O -> Block n O O -> Block n O O
+   bb rest BNil = rest
+   bb rest (BMiddle n) = BSnoc rest n
+   bb rest (BCat l r) = bb (bb rest l) r
+   bb rest (BCons n b) = bb (BSnoc rest n) b
+   bb rest (BSnoc b n) = BSnoc (bb rest b) n
diff --git a/src/Compiler/Hoopl/Collections.hs b/src/Compiler/Hoopl/Collections.hs
--- a/src/Compiler/Hoopl/Collections.hs
+++ b/src/Compiler/Hoopl/Collections.hs
@@ -59,6 +59,7 @@
   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
@@ -76,6 +77,7 @@
   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
diff --git a/src/Compiler/Hoopl/Combinators.hs b/src/Compiler/Hoopl/Combinators.hs
--- a/src/Compiler/Hoopl/Combinators.hs
+++ b/src/Compiler/Hoopl/Combinators.hs
@@ -19,7 +19,8 @@
 import Compiler.Hoopl.Collections
 import Compiler.Hoopl.Dataflow
 import Compiler.Hoopl.Fuel
-import Compiler.Hoopl.Graph (Graph, C, O, Shape(..))
+import Compiler.Hoopl.Block
+import Compiler.Hoopl.Graph (Graph)
 import Compiler.Hoopl.Label
 
 ----------------------------------------------------------------
diff --git a/src/Compiler/Hoopl/Dataflow.hs b/src/Compiler/Hoopl/Dataflow.hs
--- a/src/Compiler/Hoopl/Dataflow.hs
+++ b/src/Compiler/Hoopl/Dataflow.hs
@@ -1,36 +1,48 @@
 {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-}
+#if __GLASGOW_HASKELL__ >= 703
+{- OPTIONS_GHC -fprof-auto #-}
+#endif
 #if __GLASGOW_HASKELL__ >= 701
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 #endif
+#if __GLASGOW_HASKELL__ < 701
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+#endif
 
 module Compiler.Hoopl.Dataflow
   ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact, mkFactBase
+
   , ChangeFlag(..), changeIf
-  , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3
-  -- * Respecting Fuel
 
-  -- $fuel
-  , FwdRewrite,  mkFRewrite,  mkFRewrite3,  getFRewrite3, noFwdRewrite
+  , FwdPass(..)
+  , FwdTransfer(..), mkFTransfer, mkFTransfer3
+  , FwdRewrite(..),  mkFRewrite,  mkFRewrite3, noFwdRewrite
   , wrapFR, wrapFR2
-  , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3
+
+  , BwdPass(..)
+  , BwdTransfer(..), mkBTransfer, mkBTransfer3
   , wrapBR, wrapBR2
-  , BwdRewrite,  mkBRewrite,  mkBRewrite3,  getBRewrite3, noBwdRewrite
+  , BwdRewrite(..),  mkBRewrite,  mkBRewrite3, noBwdRewrite
+
   , analyzeAndRewriteFwd,  analyzeAndRewriteBwd
+
+  -- * Respecting Fuel
+
+  -- $fuel
   )
 where
 
-import Control.Monad
-import Data.Maybe
-
-import Compiler.Hoopl.Checkpoint
+import Compiler.Hoopl.Block
 import Compiler.Hoopl.Collections
+import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Fuel
 import Compiler.Hoopl.Graph hiding (Graph) -- hiding so we can redefine
                                            -- and include definition in paper
-import qualified Compiler.Hoopl.GraphUtil as U
 import Compiler.Hoopl.Label
-import Compiler.Hoopl.Util
 
+import Control.Monad
+import Data.Maybe
+
 -----------------------------------------------------------------------------
 --              DataflowLattice
 -----------------------------------------------------------------------------
@@ -93,6 +105,7 @@
                     , n O C -> f -> m (Maybe (Graph n O C, FwdRewrite m n f))
                     ) }
 
+{-# INLINE wrapFR #-}
 wrapFR :: (forall e x. (n  e x -> f  -> m  (Maybe (Graph n  e x, FwdRewrite m  n  f )))
                     -> (n' e x -> f' -> m' (Maybe (Graph n' e x, FwdRewrite m' n' f')))
           )
@@ -101,7 +114,9 @@
        -> FwdRewrite m  n  f 
        -> FwdRewrite m' n' f'      -- see Note [Respects Fuel]
 wrapFR wrap (FwdRewrite3 (f, m, l)) = FwdRewrite3 (wrap f, wrap m, wrap l)
-wrapFR2 
+
+{-# INLINE wrapFR2 #-}
+wrapFR2
   :: (forall e x . (n1 e x -> f1 -> m1 (Maybe (Graph n1 e x, FwdRewrite m1 n1 f1))) ->
                    (n2 e x -> f2 -> m2 (Maybe (Graph n2 e x, FwdRewrite m2 n2 f2))) ->
                    (n3 e x -> f3 -> m3 (Maybe (Graph n3 e x, FwdRewrite m3 n3 f3)))
@@ -186,7 +201,9 @@
 arfGraph :: forall m n f e x .
             (NonLocal n, CheckpointMonad m) => FwdPass m n f -> 
             Entries e -> Graph n e x -> Fact e f -> m (DG f n e x, Fact x f)
-arfGraph pass entries = graph
+arfGraph pass@FwdPass { fp_lattice = lattice,
+                        fp_transfer = transfer,
+                        fp_rewrite  = rewrite } entries = graph
   where
     {- nested type synonyms would be so lovely here 
     type ARF  thing = forall e x . thing e x -> f        -> m (DG f n e x, Fact x f)
@@ -232,21 +249,23 @@
 
     -- Lift from nodes to blocks
 -- @ start block.tex -2
-    block (BFirst  n)  = node n
+    block BNil          = \f -> return (dgnil, f)
+    block (BlockCO l b)   = node l `cat` block b
+    block (BlockCC l b n) = node l `cat` block b `cat` node n
+    block (BlockOC   b n) =              block b `cat` node n
+
     block (BMiddle n)  = node n
-    block (BLast   n)  = node n
     block (BCat b1 b2) = block b1 `cat` block b2
 -- @ end block.tex
-    block (BHead h n)  = block h  `cat` node n
-    block (BTail n t)  = node  n  `cat` block t
-    block (BClosed h t)= block h  `cat` block t
+    block (BSnoc h n)  = block h  `cat` node n
+    block (BCons n t)  = node  n  `cat` block t
 
 -- @ start node.tex -4
     node n f
-     = do { grw <- frewrite pass n f
+     = do { grw <- frewrite rewrite n f
           ; case grw of
               Nothing -> return ( singletonDG f n
-                                , ftransfer pass n f )
+                                , ftransfer transfer n f )
               Just (g, rw) ->
                   let pass' = pass { fp_rewrite = rw }
                       f'    = fwdEntryFact n f
@@ -268,7 +287,6 @@
          -> (thing C x -> Fact C f -> m (DG f n C x, Fact x f))
     arfx arf thing fb = 
       arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb
-     where lattice = fp_lattice pass
      -- joinInFacts adds debugging information
 
 
@@ -277,11 +295,10 @@
                     -- the Body are in the 'DG f n C C'
 -- @ start bodyfun.tex
     body entries blockmap init_fbase
-      = fixpoint Fwd lattice do_block blocks init_fbase
+      = fixpoint Fwd lattice do_block entries blockmap init_fbase
       where
-        blocks  = forwardBlockList entries blockmap
-        lattice = fp_lattice pass
-        do_block :: forall x. Block n C x -> FactBase f -> m (DG f n C x, Fact x f)
+        do_block :: forall x. Block n C x -> FactBase f
+                 -> m (DG f n C x, Fact x f)
         do_block b fb = block b entryFact
           where entryFact = getFact lattice (entryLabel b) fb
 -- @ end bodyfun.tex
@@ -323,6 +340,7 @@
                     , n O C -> FactBase f -> m (Maybe (Graph n O C, BwdRewrite m n f))
                     ) }
 
+{-# INLINE wrapBR #-}
 wrapBR :: (forall e x .
                 Shape x 
              -> (n  e x -> Fact x f  -> m  (Maybe (Graph n  e x, BwdRewrite m  n  f )))
@@ -335,6 +353,7 @@
 wrapBR wrap (BwdRewrite3 (f, m, l)) = 
   BwdRewrite3 (wrap Open f, wrap Open m, wrap Closed l)
 
+{-# INLINE wrapBR2 #-}
 wrapBR2 :: (forall e x . Shape x
             -> (n1 e x -> Fact x f1 -> m1 (Maybe (Graph n1 e x, BwdRewrite m1 n1 f1)))
             -> (n2 e x -> Fact x f2 -> m2 (Maybe (Graph n2 e x, BwdRewrite m2 n2 f2)))
@@ -387,7 +406,9 @@
 arbGraph :: forall m n f e x .
             (NonLocal n, CheckpointMonad m) => BwdPass m n f -> 
             Entries e -> Graph n e x -> Fact x f -> m (DG f n e x, Fact e f)
-arbGraph pass entries = graph
+arbGraph pass@BwdPass { bp_lattice  = lattice,
+                        bp_transfer = transfer,
+                        bp_rewrite  = rewrite } entries = graph
   where
     {- nested type synonyms would be so lovely here 
     type ARB  thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f)
@@ -419,23 +440,25 @@
              c _ _ = error "bogus GADT pattern match failure"
 
     -- Lift from nodes to blocks
-    block (BFirst  n)  = node n
+    block BNil          = \f -> return (dgnil, f)
+    block (BlockCO l b)   = node l `cat` block b
+    block (BlockCC l b n) = node l `cat` block b `cat` node n
+    block (BlockOC   b n) =              block b `cat` node n
+
     block (BMiddle n)  = node n
-    block (BLast   n)  = node n
     block (BCat b1 b2) = block b1 `cat` block b2
-    block (BHead h n)  = block h  `cat` node n
-    block (BTail n t)  = node  n  `cat` block t
-    block (BClosed h t)= block h  `cat` block t
+    block (BSnoc h n)  = block h  `cat` node n
+    block (BCons n t)  = node  n  `cat` block t
 
     node n f
-      = do { bwdres <- brewrite pass n f
+      = do { bwdres <- brewrite rewrite n f
            ; case bwdres of
                Nothing -> return (singletonDG entry_f n, entry_f)
-                            where entry_f = btransfer pass n f
+                            where entry_f = btransfer transfer n f
                Just (g, rw) ->
                           do { let pass' = pass { bp_rewrite = rw }
                              ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f
-                             ; return (g, bwdEntryFact (bp_lattice pass) n f)} }
+                             ; return (g, bwdEntryFact lattice n f)} }
 
     -- | Compose fact transformers and concatenate the resulting
     -- rewritten graphs.
@@ -450,7 +473,7 @@
          -> (thing C x -> Fact x f -> m (DG f n C x, Fact C f))
 
     arbx arb thing f = do { (rg, f) <- arb thing f
-                          ; let fb = joinInFacts (bp_lattice pass) $
+                          ; let fb = joinInFacts lattice $
                                      mapSingleton (entryLabel thing) f
                           ; return (rg, fb) }
      -- joinInFacts adds debugging information
@@ -459,14 +482,14 @@
                     -- in the Body; the facts for Labels *in*
                     -- the Body are in the 'DG f n C C'
     body entries blockmap init_fbase
-      = fixpoint Bwd (bp_lattice pass) do_block blocks init_fbase
+      = fixpoint Bwd lattice do_block (map entryLabel (backwardBlockList entries blockmap)) blockmap init_fbase
       where
-        blocks = backwardBlockList entries blockmap
         do_block :: forall x. Block n C x -> Fact x f -> m (DG f n C x, LabelMap f)
         do_block b f = do (g, f) <- block b f
                           return (g, mapSingleton (entryLabel b) f)
 
 
+
 backwardBlockList :: (LabelsPtr entries, NonLocal n) => entries -> Body n -> [Block n C C]
 -- This produces a list of blocks in order suitable for backward analysis,
 -- along with the list of Labels it may depend on for facts.
@@ -510,23 +533,18 @@
 -----------------------------------------------------------------------------
 --      fixpoint: finding fixed points
 -----------------------------------------------------------------------------
--- @ start txfb.tex
-data TxFactBase n f
-  = TxFB { tfb_fbase :: FactBase f
-         , tfb_rg    :: DG f n C C -- Transformed blocks
-         , tfb_cha   :: ChangeFlag
-         , tfb_lbls  :: LabelSet }
--- @ end txfb.tex
+
      -- See Note [TxFactBase invariants]
--- @ start update.tex
-updateFact :: DataflowLattice f -> LabelSet
-           -> Label -> f -> (ChangeFlag, FactBase f)
-           -> (ChangeFlag, FactBase f)
+
+updateFact :: DataflowLattice f
+           -> LabelMap (DBlock f n C C)
+           -> Label -> f       -- out fact
+           -> ([Label], FactBase f)
+           -> ([Label], FactBase f)
 -- See Note [TxFactBase change flag]
-updateFact lat lbls lbl new_fact (cha, fbase)
-  | NoChange <- cha2     = (cha,        fbase)
-  | lbl `setMember` lbls = (SomeChange, new_fbase)
-  | otherwise            = (cha,        new_fbase)
+updateFact lat newblocks lbl new_fact (cha, fbase)
+  | NoChange <- cha2, lbl `mapMember` newblocks  = (cha,     fbase)
+  | otherwise         = (lbl:cha, mapInsert lbl res_fact fbase)
   where
     (cha2, res_fact) -- Note [Unreachable blocks]
        = case lookupFact lbl fbase of
@@ -536,8 +554,6 @@
                  fact_join lat lbl
                    (OldFact old_fact) (NewFact new_fact)
                (_, new_fact_debug) = join (fact_bot lat)
-    new_fbase = mapInsert lbl res_fact fbase
--- @ end update.tex
 
 
 {-
@@ -552,75 +568,63 @@
  => Direction
  -> DataflowLattice f
  -> (Block n C C -> Fact C f -> m (DG f n C C, Fact C f))
- -> [Block n C C]
+ -> [Label]
+ -> LabelMap (Block n C C)
  -> (Fact C f -> m (DG f n C C, Fact C f))
 -- @ end fptype.tex
 -- @ start fpimp.tex
-fixpoint direction lat do_block blocks init_fbase
-  = do { tx_fb <- loop init_fbase
-       ; return (tfb_rg tx_fb, 
-                 map (fst . fst) tagged_blocks 
-                    `mapDeleteList` tfb_fbase tx_fb ) }
-    -- The successors of the Graph are the the Labels 
+fixpoint direction lat do_block entries blockmap init_fbase
+  = do
+        -- trace ("fixpoint: " ++ show (case direction of Fwd -> True; Bwd -> False) ++ " " ++ show (mapKeys blockmap) ++ show entries ++ " " ++ show (mapKeys init_fbase)) $ return()
+        (fbase, newblocks) <- loop init_fbase entries mapEmpty
+        -- trace ("fixpoint DONE: " ++ show (mapKeys fbase) ++ show (mapKeys newblocks)) $ return()
+        return (GMany NothingO newblocks NothingO,
+                mapDeleteList (mapKeys blockmap) fbase)
+    -- The successors of the Graph are the the Labels
     -- for which we have facts and which are *not* in
     -- the blocks of the graph
   where
-    tagged_blocks = map tag blocks
-    is_fwd = case direction of { Fwd -> True; 
-                                 Bwd -> False }
-    tag :: NonLocal t => t C C -> ((Label, t C C), [Label])
-    tag b = ((entryLabel b, b), 
-             if is_fwd then [entryLabel b] 
-                        else successors b)
-     -- 'tag' adds the in-labels of the block; 
-     -- see Note [TxFactBase invairants]
+    -- mapping from L -> Ls.  If the fact for L changes, re-analyse Ls.
+    dep_blocks :: LabelMap [Label]
+    dep_blocks = mapFromListWith (++)
+                        [ (l, [entryLabel b])
+                        | b <- mapElems blockmap
+                        , l <- case direction of
+                                 Fwd -> [entryLabel b]
+                                 Bwd -> successors b
+                        ]
 
-    tx_blocks :: [((Label, Block n C C), [Label])]   -- I do not understand this type
-              -> TxFactBase n f -> m (TxFactBase n f)
-    tx_blocks []              tx_fb = return tx_fb
-    tx_blocks (((lbl,blk), in_lbls):bs) tx_fb 
-      = tx_block lbl blk in_lbls tx_fb >>= tx_blocks bs
-     -- "in_lbls" == Labels the block may 
-     --                 _depend_ upon for facts
+    loop
+       :: FactBase f  -- current factbase (increases monotonically)
+       -> [Label]     -- blocks still to analyse (Todo: use a better rep)
+       -> LabelMap (DBlock f n C C)  -- transformed graph
+       -> m (FactBase f, LabelMap (DBlock f n C C))
 
-    tx_block :: Label -> Block n C C -> [Label]
-             -> TxFactBase n f -> m (TxFactBase n f)
-    tx_block lbl blk in_lbls 
-        tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls
-                    , tfb_rg = blks, tfb_cha = cha })
-      | is_fwd && not (lbl `mapMember` fbase)
-      = return (tx_fb {tfb_lbls = lbls'})       -- Note [Unreachable blocks]
-      | otherwise
-      = do { (rg, out_facts) <- do_block blk fbase
-           ; let (cha', fbase') = mapFoldWithKey
-                                  (updateFact lat lbls')
-                                  (cha,fbase) out_facts
-           ; return $
-               TxFB { tfb_lbls  = lbls'
-                    , tfb_rg    = rg `dgSplice` blks
-                    , tfb_fbase = fbase'
-                    , tfb_cha = cha' } }
-      where
-        lbls' = lbls `setUnion` setFromList in_lbls
-        
+    loop fbase []         newblocks = return (fbase, newblocks)
+    loop fbase (lbl:todo) newblocks = do
+      case mapLookup lbl blockmap of
+         Nothing  -> loop fbase todo newblocks
+         Just blk -> do
+           -- trace ("analysing: " ++ show lbl) $ return ()
+           (rg, out_facts) <- do_block blk fbase
+           let (changed, fbase') = mapFoldWithKey
+                                     (updateFact lat newblocks)
+                                     ([],fbase) out_facts
+           -- trace ("fbase': " ++ show (mapKeys fbase')) $ return ()
+           -- trace ("changed: " ++ show changed) $ return ()
+     
+           let to_analyse
+                 = filter (`notElem` todo) $
+                   concatMap (\l -> mapFindWithDefault [] l dep_blocks) changed
 
-    loop :: FactBase f -> m (TxFactBase n f)
-    loop fbase 
-      = do { s <- checkpoint
-           ; let init_tx :: TxFactBase n f
-                 init_tx = TxFB { tfb_fbase = fbase
-                                , tfb_cha   = NoChange
-                                , tfb_rg    = dgnilC
-                                , tfb_lbls  = setEmpty }
-           ; tx_fb <- tx_blocks tagged_blocks init_tx
-           ; case tfb_cha tx_fb of
-               NoChange   -> return tx_fb
-               SomeChange 
-                 -> do { restart s
-                       ; loop (tfb_fbase tx_fb) } }
--- @ end fpimp.tex           
+           -- trace ("to analyse: " ++ show to_analyse) $ return ()
 
+           let newblocks' = case rg of
+                              GMany _ blks _ -> mapUnion blks newblocks
+     
+           loop fbase' (todo ++ to_analyse) newblocks'
 
+
 {-  Note [TxFactBase invariants]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The TxFactBase is used only during a fixpoint iteration (or "sweep"),
@@ -712,14 +716,13 @@
 
 ---- observers
 
-type GraphWithFacts n f e x = (Graph n e x, FactBase f)
-  -- A Graph together with the facts for that graph
-  -- The domains of the two maps should be identical
-
 normalizeGraph :: forall n f e x .
-                  NonLocal n => DG f n e x -> GraphWithFacts n f e x
+                  NonLocal n => DG f n e x
+               -> (Graph n e x, FactBase f)
+                 -- A Graph together with the facts for that graph
+                 -- The domains of the two maps should be identical
 
-normalizeGraph g = (graphMapBlocks dropFact g, facts g)
+normalizeGraph g = (mapGraphBlocks dropFact g, facts g)
     where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3
           dropFact (DBlock _ b) = b
           facts :: DG f n e x -> FactBase f
@@ -730,18 +733,18 @@
           exitFacts NothingO = noFacts
           exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f
           bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f
-          bodyFacts body = mapFold f noFacts body
-            where f :: forall t a x. (NonLocal t) => DBlock a t C x -> LabelMap a -> LabelMap a
-                  f (DBlock f b) fb = mapInsert (entryLabel b) f fb
+          bodyFacts body = mapFoldWithKey f noFacts body
+            where f :: forall t a x. (NonLocal t) => Label -> DBlock a t C x -> LabelMap a -> LabelMap a
+                  f lbl (DBlock f _) fb = mapInsert lbl f fb
 
 --- implementation of the constructors (boring)
 
 dgnil  = GNil
 dgnilC = GMany NothingO emptyBody NothingO
 
-dgSplice = U.splice fzCat
+dgSplice = splice fzCat
   where fzCat :: DBlock f n e O -> DBlock t n O x -> DBlock f n e x
-        fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2)
+        fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `blockAppend` b2)
 
 ----------------------------------------------------------------
 --       Utilities
@@ -758,43 +761,43 @@
  singletonDG   :: f -> n e x -> DG f n e x
  fwdEntryFact  :: NonLocal n => n e x -> f -> Fact e f
  fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label]
- ftransfer :: FwdPass m n f -> n e x -> f -> Fact x f
- frewrite  :: FwdPass m n f -> n e x 
+ ftransfer :: FwdTransfer n f -> n e x -> f -> Fact x f
+ frewrite  :: FwdRewrite m n f -> n e x
            -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))
 -- @ end node.tex
  bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f
- btransfer    :: BwdPass m n f -> n e x -> Fact x f -> f
- brewrite     :: BwdPass m n f -> n e x
+ btransfer    :: BwdTransfer n f -> n e x -> Fact x f -> f
+ brewrite     :: BwdRewrite m n f -> n e x
               -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f))
 
 instance ShapeLifter C O where
-  singletonDG f = gUnitCO . DBlock f . BFirst
+  singletonDG f n = gUnitCO (DBlock f (BlockCO n BNil))
   fwdEntryFact     n f  = mapSingleton (entryLabel n) f
   bwdEntryFact lat n fb = getFact lat (entryLabel n) fb
-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (ft, _, _)}) n f = ft n f
-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (bt, _, _)}) n f = bt n f
-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (fr, _, _)}) n f = fr n f
-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (br, _, _)}) n f = br n f
+  ftransfer (FwdTransfer3 (ft, _, _)) n f = ft n f
+  btransfer (BwdTransfer3 (bt, _, _)) n f = bt n f
+  frewrite  (FwdRewrite3  (fr, _, _)) n f = fr n f
+  brewrite  (BwdRewrite3  (br, _, _)) n f = br n f
   fwdEntryLabel n = JustC [entryLabel n]
 
 instance ShapeLifter O O where
   singletonDG f = gUnitOO . DBlock f . BMiddle
   fwdEntryFact   _ f = f
   bwdEntryFact _ _ f = f
-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, ft, _)}) n f = ft n f
-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, bt, _)}) n f = bt n f
-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, fr, _)}) n f = fr n f
-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, br, _)}) n f = br n f
+  ftransfer (FwdTransfer3 (_, ft, _)) n f = ft n f
+  btransfer (BwdTransfer3 (_, bt, _)) n f = bt n f
+  frewrite  (FwdRewrite3  (_, fr, _)) n f = fr n f
+  brewrite  (BwdRewrite3  (_, br, _)) n f = br n f
   fwdEntryLabel _ = NothingC
 
 instance ShapeLifter O C where
-  singletonDG f = gUnitOC . DBlock f . BLast
+  singletonDG f n = gUnitOC (DBlock f (BlockOC BNil n))
   fwdEntryFact   _ f = f
   bwdEntryFact _ _ f = f
-  ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, _, ft)}) n f = ft n f
-  btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, _, bt)}) n f = bt n f
-  frewrite  (FwdPass {fp_rewrite  = FwdRewrite3  (_, _, fr)}) n f = fr n f
-  brewrite  (BwdPass {bp_rewrite  = BwdRewrite3  (_, _, br)}) n f = br n f
+  ftransfer (FwdTransfer3 (_, _, ft)) n f = ft n f
+  btransfer (BwdTransfer3 (_, _, bt)) n f = bt n f
+  frewrite  (FwdRewrite3  (_, _, fr)) n f = fr n f
+  brewrite  (BwdRewrite3  (_, _, br)) n f = br n f
   fwdEntryLabel _ = NothingC
 
 -- Fact lookup: the fact `orelse` bottom
diff --git a/src/Compiler/Hoopl/GHC.hs b/src/Compiler/Hoopl/GHC.hs
deleted file mode 100644
--- a/src/Compiler/Hoopl/GHC.hs
+++ /dev/null
@@ -1,27 +0,0 @@
-{-# LANGUAGE GADTs, RankNTypes #-}
-#if __GLASGOW_HASKELL__ >= 701
-{-# LANGUAGE Safe #-}
-#endif
-
-{- Exposing some internals to GHC -}
-module Compiler.Hoopl.GHC
-  ( uniqueToInt
-  , uniqueToLbl, lblToUnique
-  , getFuel, setFuel
-  , bodyToBlockMap, bodyOfBlockMap
-  )
-where
-
-import Compiler.Hoopl.Fuel
-import Compiler.Hoopl.Graph
-import Compiler.Hoopl.Label
-import Compiler.Hoopl.Unique
-
--- Converts Body to a map of closed/closed blocks.
--- It should better be a constant-time operation
--- as GHC is counting on it.
-bodyToBlockMap :: Body' block n -> LabelMap (block n C C)
-bodyToBlockMap (Body bodyMap) = bodyMap
-
-bodyOfBlockMap :: LabelMap (block n C C) -> Body' block n
-bodyOfBlockMap = Body
diff --git a/src/Compiler/Hoopl/Graph.hs b/src/Compiler/Hoopl/Graph.hs
--- a/src/Compiler/Hoopl/Graph.hs
+++ b/src/Compiler/Hoopl/Graph.hs
@@ -1,98 +1,102 @@
-{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, Rank2Types #-}
+{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, ScopedTypeVariables,
+    RankNTypes, FlexibleInstances, TypeSynonymInstances #-}
 #if __GLASGOW_HASKELL__ >= 701
 {-# LANGUAGE Safe #-}
 #endif
+#if __GLASGOW_HASKELL__ < 701
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+#endif
 
 module Compiler.Hoopl.Graph 
-  ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..)
-  , MaybeO(..), MaybeC(..), Shape(..), IndexedCO
+  (
+    -- * Body
+    Body, Body', emptyBody, bodyList, addBlock, bodyUnion
+
+    -- * Graph
+  , Graph, Graph'(..)
   , NonLocal(entryLabel, successors)
-  , emptyBody, addBlock, bodyList
-  , mapGraph, mapMaybeO, mapMaybeC, mapBlock
+
+  -- ** Constructing graphs
+  , bodyGraph
+  , blockGraph
+  , gUnitOO, gUnitOC, gUnitCO, gUnitCC
+  , catGraphNodeOC, catGraphNodeOO
+  , catNodeCOGraph, catNodeOOGraph
+
+  -- ** Splicing graphs
+  , splice, gSplice
+
+  -- ** Maps
+  , mapGraph, mapGraphBlocks
+
+  -- ** Folds
+  , foldGraphNodes
+
+  -- ** Extracting Labels
+  , labelsDefined, labelsUsed, externalEntryLabels
+
+  -- ** Depth-first traversals
+  , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
+  , preorder_dfs, preorder_dfs_from_except
+  , LabelsPtr(..)
   )
 where
 
 import Compiler.Hoopl.Collections
+import Compiler.Hoopl.Block
 import Compiler.Hoopl.Label
 
------------------------------------------------------------------------------
---		Graphs
------------------------------------------------------------------------------
+import Control.Monad
 
--- | 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
 
--- | 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
-  -- nodes
-  BFirst  :: n C O                 -> Block n C O -- x^ block holds a single first node
-  BMiddle :: n O O                 -> Block n O O -- x^ block holds a single middle node
-  BLast   :: n O C                 -> Block n O C -- x^ block holds a single last node
-
-  -- concatenation operations
-  BCat    :: Block n O O -> Block n O O -> Block n O O -- non-list-like
-  BHead   :: Block n C O -> n O O       -> Block n C O
-  BTail   :: n O O       -> Block n O C -> Block n O C  
-
-  BClosed :: Block n C O -> Block n O C -> Block n C C -- the zipper
+-- -----------------------------------------------------------------------------
+-- Body
 
 -- | A (possibly empty) collection of closed/closed blocks
 type Body n = LabelMap (Block n C C)
-newtype Body' block n = Body (LabelMap (block n C C))
 
--- | 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
-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) 
-        -> LabelMap (block n C C)
-        -> MaybeO x (block n C O)
-        -> Graph' block n e x
+-- | @Body@ abstracted over @block@
+type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
 
--- | Maybe type indexed by open/closed
-data MaybeO ex t where
-  JustO    :: t -> MaybeO O t
-  NothingO ::      MaybeO C t
+emptyBody :: Body' block n
+emptyBody = mapEmpty
 
--- | Maybe type indexed by closed/open
-data MaybeC ex t where
-  JustC    :: t -> MaybeC C t
-  NothingC ::      MaybeC O t
+bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a
+bodyUnion = mapUnionWithKey nodups
+  where nodups l _ _ = error $ "duplicate blocks with label " ++ show l
 
--- | Dynamic shape value
-data Shape ex where
-  Closed :: Shape C
-  Open   :: Shape O
+bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)]
+bodyList body = mapToList body
 
--- | 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
+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
 
-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)
+-- ---------------------------------------------------------------------------
+-- 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
+
 -------------------------------
 -- | Gives access to the anchor points for
 -- nonlocal edges as well as the edges themselves
@@ -101,49 +105,310 @@
   successors :: thing e C -> [Label] -- ^ Gives control-flow successors
 
 instance NonLocal n => NonLocal (Block n) where
-  entryLabel (BFirst n)    = entryLabel n
-  entryLabel (BHead h _)   = entryLabel h
-  entryLabel (BClosed h _) = entryLabel h
-  successors (BLast n)     = successors n
-  successors (BTail _ t)   = successors t
-  successors (BClosed _ t) = successors t
+  entryLabel (BlockCO f _)   = entryLabel f
+  entryLabel (BlockCC f _ _) = entryLabel f
 
-------------------------------
-emptyBody :: LabelMap (thing C C)
-emptyBody = mapEmpty
+  successors (BlockOC   _ n) = successors n
+  successors (BlockCC _ _ n) = successors n
 
-addBlock :: NonLocal thing => thing C C -> LabelMap (thing C C) -> LabelMap (thing C C)
-addBlock b body = nodupsInsert (entryLabel b) b body
-  where nodupsInsert l b body = if mapMember l body then
-                                    error $ "duplicate label " ++ show l ++ " in graph"
-                                else
-                                    mapInsert l b body
 
-bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)]
-bodyList (Body body) = mapToList body
+-- -----------------------------------------------------------------------------
+-- Constructing graphs
 
+bodyGraph :: Body n -> Graph n C C
+bodyGraph b = GMany NothingO b NothingO
+
+gUnitOO :: block n O O -> Graph' block n O O
+gUnitOC :: block n O C -> Graph' block n O C
+gUnitCO :: block n C O -> Graph' block n C O
+gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C
+gUnitOO b = GUnit b
+gUnitOC b = GMany (JustO b) emptyBody  NothingO
+gUnitCO b = GMany NothingO  emptyBody (JustO b)
+gUnitCC b = GMany NothingO (addBlock b emptyBody) NothingO
+
+
+catGraphNodeOO ::               Graph n e O -> n O O -> Graph n e O
+catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C
+catNodeOOGraph ::               n O O -> Graph n O x -> Graph n O x
+catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x
+
+catGraphNodeOO GNil                     n = gUnitOO $ BMiddle n
+catGraphNodeOO (GUnit b)                n = gUnitOO $ BSnoc b n
+catGraphNodeOO (GMany e body (JustO (BlockCO f b))) n
+  = GMany e body (JustO (BlockCO f (BSnoc b n)))
+
+catGraphNodeOC GNil                     n = gUnitOC $ BlockOC BNil n
+catGraphNodeOC (GUnit b)                n = gUnitOC $ BlockOC b n
+catGraphNodeOC (GMany e body (JustO (BlockCO f x))) n
+  = GMany e (addBlock (BlockCC f x n) body) NothingO
+
+catNodeOOGraph n GNil                     = gUnitOO $ BMiddle n
+catNodeOOGraph n (GUnit b)                = gUnitOO $ BCons n b
+catNodeOOGraph n (GMany (JustO (BlockOC b l)) body x)
+   = GMany (JustO (BlockOC (n `BCons` b) l)) body x
+
+catNodeCOGraph f GNil                     = gUnitCO (BlockCO f BNil)
+catNodeCOGraph f (GUnit b)                = gUnitCO (BlockCO f b)
+catNodeCOGraph f (GMany (JustO (BlockOC b n)) body x)
+  = GMany NothingO (addBlock (BlockCC f b n) body) x
+
+
+blockGraph :: NonLocal n => Block n e x -> Graph n e x
+blockGraph b@(BlockCO {}) = gUnitCO b
+blockGraph b@(BlockOC {}) = gUnitOC b
+blockGraph b@(BlockCC {}) = gUnitCC b
+blockGraph   (BNil  {})   = GNil
+blockGraph b@(BMiddle {}) = gUnitOO b
+blockGraph b@(BCat {})    = gUnitOO b
+blockGraph b@(BSnoc {})   = gUnitOO b
+blockGraph b@(BCons {})   = gUnitOO b
+
+
+-- -----------------------------------------------------------------------------
+-- Splicing graphs
+
+splice :: forall block n e a x . NonLocal (block n) =>
+          (forall e x . block n e O -> block n O x -> block n e x)
+       -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x)
+
+splice bcat = sp
+  where sp :: forall e a x .
+              Graph' block n e a -> Graph' block n a x -> Graph' block n e x
+
+        sp GNil g2 = g2
+        sp g1 GNil = g1
+
+        sp (GUnit b1) (GUnit b2) = {-# SCC "sp1" #-} GUnit $! b1 `bcat` b2
+
+        sp (GUnit b) (GMany (JustO e) bs x) = {-# SCC "sp2" #-} GMany (JustO (b `bcat` e)) bs x
+
+        sp (GMany e bs (JustO x)) (GUnit b2) = {-# SCC "sp3" #-} x `seq` GMany e bs (JustO x')
+             where x' = x `bcat` b2
+
+        sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2)
+          = {-# SCC "sp4" #-} (GMany e1 $! b1 `bodyUnion` b2) x2
+          where b1   = (addBlock $! x1 `bcat` e2) bs1
+
+        sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)
+          = {-# SCC "sp5" #-} (GMany e1 $! b1 `bodyUnion` b2) x2
+
+        sp _ _ = error "bogus GADT match failure"
+
+gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x
+gSplice = splice blockAppend
+
+
+-- -----------------------------------------------------------------------------
+-- 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 _ GNil = GNil
-mapGraph f (GUnit b) = GUnit (mapBlock f b)
-mapGraph f (GMany x y z)
-    = GMany (mapMaybeO f x)
-            (mapMap (mapBlock f) y)
-            (mapMaybeO f z)
+mapGraph f = mapGraphBlocks (mapBlock f)
 
-mapMaybeO :: (forall e x. n e x -> n' e x) -> MaybeO ex (Block n e x) -> MaybeO ex (Block n' e x)
-mapMaybeO _  NothingO = NothingO
-mapMaybeO f (JustO b) = JustO (mapBlock f b)
+-- | 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)
 
-mapMaybeC :: (forall e x. n e x -> n' e x) -> MaybeC ex (Block n e x) -> MaybeC ex (Block n' e x)
-mapMaybeC _  NothingC = NothingC
-mapMaybeC f (JustC b) = JustC (mapBlock f b)
+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)
 
-mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
-mapBlock f (BFirst n)      = BFirst  (f n)
-mapBlock f (BMiddle n)     = BMiddle (f n)
-mapBlock f (BLast n)       = BLast   (f n)
-mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)
-mapBlock f (BHead b n)     = BHead   (mapBlock f b)  (f n)
-mapBlock f (BTail n b)     = BTail   (f n)  (mapBlock f b)
-mapBlock f (BClosed b1 b2) = BClosed (mapBlock f b1) (mapBlock f b2)
+
+-- -----------------------------------------------------------------------------
+-- Folds
+
+-- | Fold a function over every node in a graph.
+-- The fold function must be polymorphic in the shape of the nodes.
+
+foldGraphNodes :: forall n a .
+                  (forall e x . n e x       -> a -> a)
+               -> (forall e x . Graph n e x -> a -> a)
+
+foldGraphNodes f = graph
+    where graph :: forall e x . Graph n e x -> a -> a
+          lift  :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)
+
+          graph GNil              = id
+          graph (GUnit b)         = block b
+          graph (GMany e b x)     = lift block e . body b . lift block x
+          body :: Body n -> a -> a
+          body bdy                = \a -> mapFold block a bdy
+          lift _ NothingO         = id
+          lift f (JustO thing)    = f thing
+
+          block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a
+          block = foldBlockNodesF f
+
+
+----------------------------------------------------------------
+
+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
+
+
+-- | 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 :: NonLocal (block n) => Graph' block n O x -> [block n C C]
+preorder_dfs  :: NonLocal (block n) => Graph' block n O x -> [block n C C]
+
+-- | 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]
+
+
+graphDfs :: (NonLocal (block n))
+         => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])
+         -> (Graph' block n O x -> [block n C C])
+graphDfs _     (GNil)    = []
+graphDfs _     (GUnit{}) = []
+graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty
+
+postorder_dfs = graphDfs postorder_dfs_from_except
+preorder_dfs  = graphDfs preorder_dfs_from_except
+
+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
+
+
+----------------------------------------------------------------
+
+data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }
+marked :: Label -> VM Bool
+mark   :: Label -> VM ()
+instance Monad VM where
+  return a = VM $ \visited -> (a, visited)
+  m >>= k  = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
+marked l = VM $ \v -> (setMember l v, v)
+mark   l = VM $ \v -> ((), setInsert l v)
+
+preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
+                         => LabelMap (block C C) -> e -> LabelSet -> [block C C]
+preorder_dfs_from_except blocks b visited =
+    (fst $ unVM (children (get_children b)) visited) []
+  where children [] = return id
+        children (b:bs) = liftM2 (.) (visit b) (children bs)
+        visit :: block C C -> VM (HL (block C C))
+        visit b = do already <- marked (entryLabel b)
+                     if already then return id
+                      else do mark (entryLabel b)
+                              bs <- children $ get_children b
+                              return $ b `cons` bs
+        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
+
+type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)
+cons :: a -> HL a -> HL a
+cons a as tail = a : as tail
+
+
+-- -----------------------------------------------------------------------------
+-- 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)
+
+labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x
+           -> LabelSet
+labelsUsed GNil      = setEmpty
+labelsUsed (GUnit{}) = setEmpty
+labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body 
+  where addTargets :: forall e. block n e C -> LabelSet -> LabelSet
+        addTargets block labels = setInsertList (successors block) labels
+        entryTargets :: MaybeO e (block n O C) -> LabelSet
+        entryTargets NothingO = setEmpty
+        entryTargets (JustO b) = addTargets b setEmpty
+
+externalEntryLabels :: forall n .
+                       NonLocal n => LabelMap (Block n C C) -> LabelSet
+externalEntryLabels body = defined `setDifference` used
+  where defined = labelsDefined g
+        used = labelsUsed g
+        g = GMany NothingO body NothingO
+
diff --git a/src/Compiler/Hoopl/GraphUtil.hs b/src/Compiler/Hoopl/GraphUtil.hs
deleted file mode 100644
--- a/src/Compiler/Hoopl/GraphUtil.hs
+++ /dev/null
@@ -1,127 +0,0 @@
-{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
-#if __GLASGOW_HASKELL__ >= 701
-{-# LANGUAGE Safe #-}
-#endif
-
--- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint
-
-module Compiler.Hoopl.GraphUtil
-  ( splice, gSplice , cat , bodyGraph, bodyUnion
-  , frontBiasBlock, backBiasBlock
-  )
-
-where
-
-import Compiler.Hoopl.Collections
-import Compiler.Hoopl.Graph
-import Compiler.Hoopl.Label
-
-bodyGraph :: Body n -> Graph n C C
-bodyGraph b = GMany NothingO b NothingO
-
-splice :: forall block n e a x . NonLocal (block n) =>
-          (forall e x . block n e O -> block n O x -> block n e x)
-       -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x)
-splice bcat = sp
-  where sp :: forall e a x .
-              Graph' block n e a -> Graph' block n a x -> Graph' block n e x
-
-        sp GNil g2 = g2
-        sp g1 GNil = g1
-
-        sp (GUnit b1) (GUnit b2) = GUnit (b1 `bcat` b2)
-
-        sp (GUnit b) (GMany (JustO e) bs x) = GMany (JustO (b `bcat` e)) bs x
-
-        sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2))
-
-        sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2)
-          = GMany e1 (b1 `bodyUnion` b2) x2
-          where b1 = addBlock (x1 `bcat` e2) bs1
-
-        sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)
-          = GMany e1 (b1 `bodyUnion` b2) x2
-
-        sp _ _ = error "bogus GADT match failure"
-
-bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a
-bodyUnion = mapUnionWithKey nodups
-  where nodups l _ _ = error $ "duplicate blocks with label " ++ show l
-
-gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x
-gSplice = splice cat
-
-cat :: Block n e O -> Block n O x -> Block n e x
-cat b1@(BFirst {})     (BMiddle n)  = BHead   b1 n
-cat b1@(BFirst {})  b2@(BLast{})    = BClosed b1 b2
-cat b1@(BFirst {})  b2@(BTail{})    = BClosed b1 b2
-cat b1@(BFirst {})     (BCat b2 b3) = (b1 `cat` b2) `cat` b3
-cat b1@(BHead {})      (BCat b2 b3) = (b1 `cat` b2) `cat` b3
-cat b1@(BHead {})      (BMiddle n)  = BHead   b1 n
-cat b1@(BHead {})   b2@(BLast{})    = BClosed b1 b2
-cat b1@(BHead {})   b2@(BTail{})    = BClosed b1 b2
-cat b1@(BMiddle {}) b2@(BMiddle{})  = BCat    b1 b2
-cat    (BMiddle n)  b2@(BLast{})    = BTail    n b2
-cat b1@(BMiddle {}) b2@(BCat{})     = BCat    b1 b2
-cat    (BMiddle n)  b2@(BTail{})    = BTail    n b2
-cat    (BCat b1 b2) b3@(BLast{})    = b1 `cat` (b2 `cat` b3)
-cat    (BCat b1 b2) b3@(BTail{})    = b1 `cat` (b2 `cat` b3)
-cat b1@(BCat {})    b2@(BCat{})     = BCat    b1 b2
-cat b1@(BCat {})    b2@(BMiddle{})  = BCat    b1 b2
-
-
-----------------------------------------------------------------
-
--- | A block is "front biased" if the left child of every
--- concatenation operation is a node, not a general block; a
--- front-biased block is analogous to an ordinary list.  If a block is
--- front-biased, then its nodes can be traversed from front to back
--- without general recusion; tail recursion suffices.  Not all shapes
--- can be front-biased; a closed/open block is inherently back-biased.
-
-frontBiasBlock :: Block n e x -> Block n e x
-frontBiasBlock b@(BFirst  {}) = b
-frontBiasBlock b@(BMiddle {}) = b
-frontBiasBlock b@(BLast   {}) = b
-frontBiasBlock b@(BCat {}) = rotate b
-  where -- rotate and append ensure every left child of ZCat is ZMiddle
-        -- provided 2nd argument to append already has this property
-    rotate :: Block n O O -> Block n O O
-    append :: Block n O O -> Block n O O -> Block n O O
-    rotate (BCat h t)     = append h (rotate t)
-    rotate b@(BMiddle {}) = b
-    append b@(BMiddle {}) t = b `BCat` t
-    append (BCat b1 b2) b3 = b1 `append` (b2 `append` b3)
-frontBiasBlock b@(BHead {})    = b -- back-biased by nature; cannot fix
-frontBiasBlock b@(BTail {})    = b -- statically front-biased
-frontBiasBlock   (BClosed h t) = shiftRight h t
-    where shiftRight :: Block n C O -> Block n O C -> Block n C C
-          shiftRight (BHead b1 b2)  b3 = shiftRight b1 (BTail b2 b3)
-          shiftRight b1@(BFirst {}) b2 = BClosed b1 b2
-
--- | A block is "back biased" if the right child of every
--- concatenation operation is a node, not a general block; a
--- back-biased block is analogous to a snoc-list.  If a block is
--- back-biased, then its nodes can be traversed from back to back
--- without general recusion; tail recursion suffices.  Not all shapes
--- can be back-biased; an open/closed block is inherently front-biased.
-
-backBiasBlock :: Block n e x -> Block n e x
-backBiasBlock b@(BFirst  {}) = b
-backBiasBlock b@(BMiddle {}) = b
-backBiasBlock b@(BLast   {}) = b
-backBiasBlock b@(BCat {}) = rotate b
-  where -- rotate and append ensure every right child of Cat is Middle
-        -- provided 1st argument to append already has this property
-    rotate :: Block n O O -> Block n O O
-    append :: Block n O O -> Block n O O -> Block n O O
-    rotate (BCat h t)     = append (rotate h) t
-    rotate b@(BMiddle {}) = b
-    append h b@(BMiddle {}) = h `BCat` b
-    append b1 (BCat b2 b3) = (b1 `append` b2) `append` b3
-backBiasBlock b@(BHead {}) = b -- statically back-biased
-backBiasBlock b@(BTail {}) = b -- front-biased by nature; cannot fix
-backBiasBlock (BClosed h t) = shiftLeft h t
-    where shiftLeft :: Block n C O -> Block n O C -> Block n C C
-          shiftLeft b1 (BTail b2 b3) = shiftLeft (BHead b1 b2) b3
-          shiftLeft b1 b2@(BLast {}) = BClosed b1 b2
diff --git a/src/Compiler/Hoopl/Internals.hs b/src/Compiler/Hoopl/Internals.hs
new file mode 100644
--- /dev/null
+++ b/src/Compiler/Hoopl/Internals.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE GADTs, RankNTypes #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE Safe #-}
+#endif
+
+{- Exposing some internals to friends (e.g. GHC) -}
+module Compiler.Hoopl.Internals
+  ( module Compiler.Hoopl.Block
+  , module Compiler.Hoopl.Graph
+  , module Compiler.Hoopl.Label
+  , module Compiler.Hoopl.Dataflow
+  )
+where
+
+import Compiler.Hoopl.Block
+import Compiler.Hoopl.Graph
+import Compiler.Hoopl.Label
+import Compiler.Hoopl.Dataflow
diff --git a/src/Compiler/Hoopl/Label.hs b/src/Compiler/Hoopl/Label.hs
--- a/src/Compiler/Hoopl/Label.hs
+++ b/src/Compiler/Hoopl/Label.hs
@@ -78,6 +78,7 @@
   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)
@@ -95,6 +96,7 @@
   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])
 
 -----------------------------------------------------------------------------
 -- FactBase
diff --git a/src/Compiler/Hoopl/MkGraph.hs b/src/Compiler/Hoopl/MkGraph.hs
--- a/src/Compiler/Hoopl/MkGraph.hs
+++ b/src/Compiler/Hoopl/MkGraph.hs
@@ -15,8 +15,8 @@
 where
 
 import Compiler.Hoopl.Label (Label, uniqueToLbl)
-import Compiler.Hoopl.Graph
-import qualified Compiler.Hoopl.GraphUtil as U
+import Compiler.Hoopl.Block
+import Compiler.Hoopl.Graph as U
 import Compiler.Hoopl.Unique
 import Control.Monad (liftM2)
 
@@ -70,8 +70,8 @@
   mkMiddle :: n O O -> g n O O
   -- | Create a graph from a last node
   mkLast   :: n O C -> g n O C
-  mkFirst = mkExit  . BFirst
-  mkLast  = mkEntry . BLast
+  mkFirst n = mkExit (BlockCO n BNil)
+  mkLast  n = mkEntry (BlockOC BNil n)
   infixl 3 <*>
   infixl 2 |*><*| 
   -- | Concatenate two graphs; control flows from left to right.
diff --git a/src/Compiler/Hoopl/Pointed.hs b/src/Compiler/Hoopl/Pointed.hs
--- a/src/Compiler/Hoopl/Pointed.hs
+++ b/src/Compiler/Hoopl/Pointed.hs
@@ -12,7 +12,7 @@
   )
 where
 
-import Compiler.Hoopl.Graph
+import Compiler.Hoopl.Block
 import Compiler.Hoopl.Label
 import Compiler.Hoopl.Dataflow
 
diff --git a/src/Compiler/Hoopl/Show.hs b/src/Compiler/Hoopl/Show.hs
--- a/src/Compiler/Hoopl/Show.hs
+++ b/src/Compiler/Hoopl/Show.hs
@@ -9,6 +9,7 @@
 where
 
 import Compiler.Hoopl.Collections
+import Compiler.Hoopl.Block
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.Label
 
@@ -28,13 +29,14 @@
             open b g_entry ++ body g_blocks ++ open b g_exit
         body blocks = concatMap b (mapElems blocks)
         b :: forall e x . Block n e x -> String
-        b (BFirst  n)     = node n
-        b (BMiddle n)     = node n
-        b (BLast   n)     = node n ++ "\n"
+        b (BlockCO l b1)   = node l ++ "\n" ++ b b1
+        b (BlockCC l b1 n) = node l ++ "\n" ++ b b1 ++ node n ++ "\n"
+        b (BlockOC   b1 n) =           b b1 ++ node n ++ "\n"
+        b (BNil)          = ""
+        b (BMiddle n)     = node n ++ "\n"
         b (BCat b1 b2)    = b b1   ++ b b2
-        b (BHead b1 n)    = b b1   ++ node n ++ "\n"
-        b (BTail n b1)    = node n ++ b b1
-        b (BClosed b1 b2) = b b1   ++ b b2
+        b (BSnoc b1 n)    = b b1   ++ node n ++ "\n"
+        b (BCons n b1)    = node n ++ "\n" ++ b b1
 
 open :: (a -> String) -> MaybeO z a -> String
 open _ NothingO  = ""
diff --git a/src/Compiler/Hoopl/Unique.hs b/src/Compiler/Hoopl/Unique.hs
--- a/src/Compiler/Hoopl/Unique.hs
+++ b/src/Compiler/Hoopl/Unique.hs
@@ -25,14 +25,13 @@
 --		Unique
 -----------------------------------------------------------------------------
 
-data Unique = Unique { uniqueToInt ::  {-# UNPACK #-} !Int }
-  deriving (Eq, Ord)
+type Unique = Int
 
-intToUnique :: Int -> Unique
-intToUnique = Unique
+uniqueToInt :: Unique -> Int
+uniqueToInt = id
 
-instance Show Unique where
-  show (Unique n) = show n
+intToUnique :: Int -> Unique
+intToUnique = id
 
 -----------------------------------------------------------------------------
 -- UniqueSet
@@ -44,22 +43,22 @@
 
   setNull (US s) = S.null s
   setSize (US s) = S.size s
-  setMember (Unique k) (US s) = S.member k s
+  setMember k (US s) = S.member k s
 
   setEmpty = US S.empty
-  setSingleton (Unique k) = US (S.singleton k)
-  setInsert (Unique k) (US s) = US (S.insert k s)
-  setDelete (Unique k) (US s) = US (S.delete k s)
+  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.fold (k . intToUnique) z s
+  setFold k z (US s) = S.fold k z s
 
-  setElems (US s) = map intToUnique (S.elems s)
-  setFromList ks = US (S.fromList (map uniqueToInt ks))
+  setElems (US s) = S.elems s
+  setFromList ks = US (S.fromList ks)
 
 -----------------------------------------------------------------------------
 -- UniqueMap
@@ -71,14 +70,15 @@
 
   mapNull (UM m) = M.null m
   mapSize (UM m) = M.size m
-  mapMember (Unique k) (UM m) = M.member k m
-  mapLookup (Unique k) (UM m) = M.lookup k m
-  mapFindWithDefault def (Unique k) (UM m) = M.findWithDefault def k 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 (Unique k) v = UM (M.singleton k v)
-  mapInsert (Unique k) v (UM m) = UM (M.insert k v m)
-  mapDelete (Unique k) (UM m) = UM (M.delete k m)
+  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)
@@ -92,9 +92,10 @@
   mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m
 
   mapElems (UM m) = M.elems m
-  mapKeys (UM m) = map intToUnique (M.keys m)
-  mapToList (UM m) = [(intToUnique k, v) | (k, v) <- M.toList m]
-  mapFromList assocs = UM (M.fromList [(uniqueToInt k, v) | (k, v) <- assocs])
+  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)
 
 ----------------------------------------------------------------
 -- Monads
@@ -139,4 +140,4 @@
 runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a }
 
 allUniques :: [Unique]
-allUniques = map Unique [1..]
+allUniques = [1..]
diff --git a/src/Compiler/Hoopl/Util.hs b/src/Compiler/Hoopl/Util.hs
deleted file mode 100644
--- a/src/Compiler/Hoopl/Util.hs
+++ /dev/null
@@ -1,271 +0,0 @@
-{-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes, TypeFamilies #-}
-#if __GLASGOW_HASKELL__ >= 701
-{-# LANGUAGE Safe #-}
-#endif
-
-module Compiler.Hoopl.Util
-  ( gUnitOO, gUnitOC, gUnitCO, gUnitCC
-  , catGraphNodeOC, catGraphNodeOO
-  , catNodeCOGraph, catNodeOOGraph
-  , graphMapBlocks
-  , blockMapNodes, blockMapNodes3
-  , blockGraph
-  , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
-  , preorder_dfs, preorder_dfs_from_except
-  , labelsDefined, labelsUsed, externalEntryLabels
-  , LabelsPtr(..)
-  )
-where
-
-import Control.Monad
-
-import Compiler.Hoopl.Collections
-import Compiler.Hoopl.Graph
-import Compiler.Hoopl.Label
-
-
-----------------------------------------------------------------
-
-gUnitOO :: block n O O -> Graph' block n O O
-gUnitOC :: block n O C -> Graph' block n O C
-gUnitCO :: block n C O -> Graph' block n C O
-gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C
-gUnitOO b = GUnit b
-gUnitOC b = GMany (JustO b) emptyBody  NothingO
-gUnitCO b = GMany NothingO  emptyBody (JustO b)
-gUnitCC b = GMany NothingO  (addBlock b emptyBody) NothingO
-
-
-catGraphNodeOO ::            Graph n e O -> n O O -> Graph n e O
-catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C
-catNodeOOGraph ::            n O O -> Graph n O x -> Graph n O x
-catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x
-
-catGraphNodeOO GNil                     n = gUnitOO $ BMiddle n
-catGraphNodeOO (GUnit b)                n = gUnitOO $ b `BCat` BMiddle n
-catGraphNodeOO (GMany e body (JustO x)) n = GMany e body (JustO $ x `BHead` n)
-
-catGraphNodeOC GNil                     n = gUnitOC $ BLast n
-catGraphNodeOC (GUnit b)                n = gUnitOC $ addToLeft b $ BLast n
-  where addToLeft :: Block n O O -> Block n O C -> Block n O C
-        addToLeft (BMiddle m)    g = m `BTail` g
-        addToLeft (b1 `BCat` b2) g = addToLeft b1 $ addToLeft b2 g
-catGraphNodeOC (GMany e body (JustO x)) n = GMany e body' NothingO
-  where body' = addBlock (x `BClosed` BLast n) body
-
-catNodeOOGraph n GNil                     = gUnitOO $ BMiddle n
-catNodeOOGraph n (GUnit b)                = gUnitOO $ BMiddle n `BCat` b
-catNodeOOGraph n (GMany (JustO e) body x) = GMany (JustO $ n `BTail` e) body x
-
-catNodeCOGraph n GNil                     = gUnitCO $ BFirst n
-catNodeCOGraph n (GUnit b)                = gUnitCO $ addToRight (BFirst n) b
-  where addToRight :: Block n C O -> Block n O O -> Block n C O
-        addToRight g (BMiddle m)    = g `BHead` m
-        addToRight g (b1 `BCat` b2) = addToRight (addToRight g b1) b2
-catNodeCOGraph n (GMany (JustO e) body x) = GMany NothingO body' x
-  where body' = addBlock (BFirst n `BClosed` e) body
-
-
-
-
-
-blockGraph :: NonLocal n => Block n e x -> Graph n e x
-blockGraph b@(BFirst  {}) = gUnitCO b
-blockGraph b@(BMiddle {}) = gUnitOO b
-blockGraph b@(BLast   {}) = gUnitOC b
-blockGraph b@(BCat {})    = gUnitOO b
-blockGraph b@(BHead {})   = gUnitCO b
-blockGraph b@(BTail {})   = gUnitOC b
-blockGraph b@(BClosed {}) = gUnitCC b
-
-
--- | Function 'graphMapBlocks' 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.
-graphMapBlocks :: 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)
-
-graphMapBlocks 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)
-
--- | Function 'blockMapNodes' enables a change of nodes in a block.
-blockMapNodes3 :: ( 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
-blockMapNodes3 (f, _, _) (BFirst n)     = BFirst (f n)
-blockMapNodes3 (_, m, _) (BMiddle n)    = BMiddle (m n)
-blockMapNodes3 (_, _, l) (BLast n)      = BLast (l n)
-blockMapNodes3 fs (BCat x y)            = BCat (blockMapNodes3 fs x) (blockMapNodes3 fs y)
-blockMapNodes3 fs@(_, m, _) (BHead x n) = BHead (blockMapNodes3 fs x) (m n)
-blockMapNodes3 fs@(_, m, _) (BTail n x) = BTail (m n) (blockMapNodes3 fs x)
-blockMapNodes3 fs (BClosed x y)         = BClosed (blockMapNodes3 fs x) (blockMapNodes3 fs y)
-
-blockMapNodes :: (forall e x. n e x -> n' e x)
-              -> (Block n e x -> Block n' e x)
-blockMapNodes f = blockMapNodes3 (f, f, f)
-
-----------------------------------------------------------------
-
-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
-
-
--- | 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 :: NonLocal (block n) => Graph' block n O x -> [block n C C]
-preorder_dfs  :: NonLocal (block n) => Graph' block n O x -> [block n C C]
-
--- | 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]
-
-
-graphDfs :: (NonLocal (block n))
-         => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])
-         -> (Graph' block n O x -> [block n C C])
-graphDfs _     (GNil)    = []
-graphDfs _     (GUnit{}) = []
-graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty
-
-postorder_dfs = graphDfs postorder_dfs_from_except
-preorder_dfs  = graphDfs preorder_dfs_from_except
-
-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
-
-
-----------------------------------------------------------------
-
-data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }
-marked :: Label -> VM Bool
-mark   :: Label -> VM ()
-instance Monad VM where
-  return a = VM $ \visited -> (a, visited)
-  m >>= k  = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
-marked l = VM $ \v -> (setMember l v, v)
-mark   l = VM $ \v -> ((), setInsert l v)
-
-preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e)
-                         => LabelMap (block C C) -> e -> LabelSet -> [block C C]
-preorder_dfs_from_except blocks b visited =
-    (fst $ unVM (children (get_children b)) visited) []
-  where children [] = return id
-        children (b:bs) = liftM2 (.) (visit b) (children bs)
-        visit :: block C C -> VM (HL (block C C))
-        visit b = do already <- marked (entryLabel b)
-                     if already then return id
-                      else do mark (entryLabel b)
-                              bs <- children $ get_children b
-                              return $ b `cons` bs
-        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
-
-type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)
-cons :: a -> HL a -> HL a
-cons a as tail = a : as tail
-
-----------------------------------------------------------------
-
-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)
-
-labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x -> LabelSet
-labelsUsed GNil      = setEmpty
-labelsUsed (GUnit{}) = setEmpty
-labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body 
-  where addTargets :: forall e. block n e C -> LabelSet -> LabelSet
-        addTargets block labels = setInsertList (successors block) labels
-        entryTargets :: MaybeO e (block n O C) -> LabelSet
-        entryTargets NothingO = setEmpty
-        entryTargets (JustO b) = addTargets b setEmpty
-
-externalEntryLabels :: forall n .
-                       NonLocal n => LabelMap (Block n C C) -> LabelSet
-externalEntryLabels body = defined `setDifference` used
-  where defined = labelsDefined g
-        used = labelsUsed g
-        g = GMany NothingO body NothingO
diff --git a/src/Compiler/Hoopl/XUtil.hs b/src/Compiler/Hoopl/XUtil.hs
--- a/src/Compiler/Hoopl/XUtil.hs
+++ b/src/Compiler/Hoopl/XUtil.hs
@@ -6,38 +6,30 @@
 -- | Utilities for clients of Hoopl, not used internally.
 
 module Compiler.Hoopl.XUtil
-  ( firstXfer, distributeXfer
+  (
+    -- * Utilities for clients
+    firstXfer, distributeXfer
   , distributeFact, distributeFactBwd
   , successorFacts
   , joinFacts
   , joinOutFacts -- deprecated
   , joinMaps
-  , foldGraphNodes
-  , foldBlockNodesF, foldBlockNodesB, foldBlockNodesF3, foldBlockNodesB3
-  , tfFoldBlock
-  , ScottBlock(ScottBlock), scottFoldBlock
-  , fbnf3
-  , blockToNodeList, blockOfNodeList
-  , blockToNodeList'   -- alternate version using fold
-  , blockToNodeList''  -- alternate version using scottFoldBlock
-  , blockToNodeList''' -- alternate version using tfFoldBlock
   , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody
   , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx
-  , noEntries
-  , BlockResult(..), lookupBlock
   )
 where
 
 import qualified Data.Map as M
 import Data.Maybe
 
-import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Collections
+import Compiler.Hoopl.Checkpoint
 import Compiler.Hoopl.Dataflow
+import Compiler.Hoopl.Block
 import Compiler.Hoopl.Graph
 import Compiler.Hoopl.Label
-import Compiler.Hoopl.Util
 
+-----------------------------------------------------------------------------
 
 -- | Forward dataflow analysis and rewriting for the special case of a Body.
 -- A set of entry points must be supplied; blocks not reachable from
@@ -127,6 +119,7 @@
 distributeXfer lattice xfer n f =
     mkFactBase lattice [ (l, xfer n f) | l <- successors n ]
 
+
 -- | This utility function handles a common case in which a transfer function
 -- for a last node takes the incoming fact unchanged and simply distributes
 -- that fact over the outgoing edges.
@@ -174,338 +167,3 @@
 
 
 
--- | A fold function that relies on the IndexedCO type function.
---   Note that the type parameter e is available to the functions
---   that are applied to the middle and last nodes.
-tfFoldBlock :: forall n bc bo c e x .
-               ( n C O -> bc
-               , n O O -> IndexedCO e bc bo -> IndexedCO e bc bo
-               , n O C -> IndexedCO e bc bo -> c)
-            -> (Block n e x -> bo -> IndexedCO x c (IndexedCO e bc bo))
-tfFoldBlock (f, m, l) bl bo = block bl
-  where block :: forall x . Block n e x -> IndexedCO x c (IndexedCO e bc bo)
-        block (BFirst  n)       = f n
-        block (BMiddle n)       = m n bo
-        block (BLast   n)       = l n bo
-        block (b1 `BCat`    b2) = oblock b2 $ block b1
-        block (b1 `BClosed` b2) = oblock b2 $ block b1
-        block (b1 `BHead` n)    = m n $ block b1
-        block (n `BTail` b2)    = oblock b2 $ m n bo
-        oblock :: forall x . Block n O x -> IndexedCO e bc bo -> IndexedCO x c (IndexedCO e bc bo)
-        oblock (BMiddle n)       = m n
-        oblock (BLast   n)       = l n
-        oblock (b1 `BCat`    b2) = oblock b1 `cat` oblock b2
-        oblock (n `BTail` b2)    = m n       `cat` oblock b2
-        cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c
-        cat f f' = f' . f
-
-
-type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C))
-blockToNodeList''' ::
-  forall n e x. ( IndexedCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n
-                , IndexedCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) =>
-    Block n e x -> NodeList' e x n
-blockToNodeList''' b = (h, reverse ms', t)
-  where
-    (h, ms', t) = tfFoldBlock (f, m, l) b z
-    z :: NodeList' O O n
-    z = (NothingC, [], NothingC)
-    f :: n C O -> NodeList' C O n
-    f n = (JustC n,  [], NothingC)
-    m n (h, ms', t) = (h, n : ms', t)
-    l n (h, ms', _) = (h, ms', JustC n)
-
-
-{-
-data EitherCO' ex a b where
-  LeftCO  :: a -> EitherCO' C a b
-  RightCO :: b -> EitherCO' O a b
--}
-
-  -- should be done with a *backward* fold
-
--- | More general fold
-
-_unused :: Int
-_unused = 3
-  where _a = foldBlockNodesF3'' (Trips undefined undefined undefined)
-        _b = foldBlockNodesF3'
-
-data Trips n a b c = Trips { ff :: forall e . MaybeC e (n C O) -> a -> b
-                           , fm :: n O O            -> b -> b
-                           , fl :: forall x . MaybeC x (n O C) -> b -> c
-                           }
-
-foldBlockNodesF3'' :: forall n a b c .
-                      Trips n a b c -> (forall e x . Block n e x -> a -> c)
-foldBlockNodesF3'' trips = block
-  where block :: Block n e x -> a -> c
-        block (b1 `BClosed` b2) = foldCO b1 `cat` foldOC b2
-        block (BFirst  node)    = ff trips (JustC node)  `cat` missingLast
-        block (b @ BHead {})    = foldCO b `cat` missingLast
-        block (BMiddle node)    = missingFirst `cat` fm trips node  `cat` missingLast
-        block (b @ BCat {})     = missingFirst `cat` foldOO b `cat` missingLast
-        block (BLast   node)    = missingFirst `cat` fl trips (JustC node)
-        block (b @ BTail {})    = missingFirst `cat` foldOC b
-        missingLast = fl trips NothingC
-        missingFirst = ff trips NothingC
-        foldCO :: Block n C O -> a -> b
-        foldOO :: Block n O O -> b -> b
-        foldOC :: Block n O C -> b -> c
-        foldCO (BFirst n)   = ff trips (JustC n)
-        foldCO (BHead b n)  = foldCO b `cat` fm trips n
-        foldOO (BMiddle n)  = fm trips n
-        foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2
-        foldOC (BLast n)    = fl trips (JustC n)
-        foldOC (BTail n b)  = fm trips n `cat` foldOC b
-        cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c
-        f `cat` g = g . f 
-
-data ScottBlock n a = ScottBlock
-   { sb_first :: n C O -> a C O
-   , sb_mid   :: n O O -> a O O
-   , sb_last  :: n O C -> a O C
-   , sb_cat   :: forall e x . a e O -> a O x -> a e x
-   }
-
-scottFoldBlock :: forall n a e x . ScottBlock n a -> Block n e x -> a e x
-scottFoldBlock funs = block
-  where block :: forall e x . Block n e x -> a e x
-        block (BFirst n)  = sb_first  funs n
-        block (BMiddle n) = sb_mid    funs n
-        block (BLast   n) = sb_last   funs n
-        block (BClosed b1 b2) = block b1 `cat` block b2
-        block (BCat    b1 b2) = block b1 `cat` block b2
-        block (BHead   b  n)  = block b  `cat` sb_mid funs n
-        block (BTail   n  b)  = sb_mid funs n `cat` block b
-        cat :: forall e x. a e O -> a O x -> a e x
-        cat = sb_cat funs
-
-newtype NodeList n e x
-    = NL { unList :: (MaybeC e (n C O), [n O O] -> [n O O], MaybeC x (n O C)) }
-
-fbnf3 :: 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)
-fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block
-    where f n = FF3 $ ff n
-          m n = FF3 $ fm n
-          l n = FF3 $ fl n
-          -- XXX Ew.
-          cat :: forall t t1 t2 t3 t4 t5 t6 t7 t8 t9 a b c e x.
-                 (IndexedCO x c b ~ IndexedCO t9 t7 t6,
-                  IndexedCO t8 t5 t6 ~ IndexedCO t4 t2 t1,
-                  IndexedCO t3 t t1 ~ IndexedCO e a b) =>
-                 FF3 t t1 t2 t3 t4 -> FF3 t5 t6 t7 t8 t9 -> FF3 a b c e x
-          FF3 f `cat` FF3 f' = FF3 $ f' . f
-
-newtype FF3 a b c e x = FF3 { unFF3 :: IndexedCO e a b -> IndexedCO x c b }
-
-blockToNodeList'' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
-blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat)
-    where f n = NL (JustC n, id, NothingC)
-          m n = NL (NothingC, (n:), NothingC)
-          l n = NL (NothingC, id, JustC n)
-          cat :: forall n t1 t3. NodeList n t1 O -> NodeList n O t3 -> NodeList n t1 t3
-          NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x)
-          finish :: forall t t1 t2 a. (t, [a] -> t1, t2) -> (t, t1, t2)
-          finish (e, ms, x) = (e, ms [], x)
-
-
-
-blockToNodeList' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
-blockToNodeList' b = unFNL $ foldBlockNodesF3''' ff fm fl b ()
-  where ff :: forall n e. MaybeC e (n C O) -> () -> PNL n e
-        fm :: forall n e. n O O -> PNL n e -> PNL n e
-        fl :: forall n e x. MaybeC x (n O C) -> PNL n e -> FNL n e x
-        ff n () = PNL (n, [])
-        fm n (PNL (first, mids')) = PNL (first, n : mids')
-        fl n (PNL (first, mids')) = FNL (first, reverse mids', n)
-
-   -- newtypes for 'partial node list' and 'final node list'
-newtype PNL n e   = PNL (MaybeC e (n C O), [n O O])
-newtype FNL n e x = FNL {unFNL :: (MaybeC e (n C O), [n O O], MaybeC x (n O C))}
-
-foldBlockNodesF3''' :: forall n a b c .
-                       (forall e   . MaybeC e (n C O) -> a   -> b e)
-                    -> (forall e   .           n O O  -> b e -> b e)
-                    -> (forall e x . MaybeC x (n O C) -> b e -> c e x)
-                    -> (forall e x . Block n e x      -> a   -> c e x)
-foldBlockNodesF3''' ff fm fl = block
-  where block   :: forall e x . Block n e x -> a   -> c e x
-        blockCO ::              Block n C O -> a   -> b C
-        blockOO :: forall e .   Block n O O -> b e -> b e
-        blockOC :: forall e .   Block n O C -> b e -> c e C
-        block (b1 `BClosed` b2) = blockCO b1       `cat` blockOC b2
-        block (BFirst  node)    = ff (JustC node)  `cat` fl NothingC
-        block (b @ BHead {})    = blockCO b        `cat` fl NothingC
-        block (BMiddle node)    = ff NothingC `cat` fm node   `cat` fl NothingC
-        block (b @ BCat {})     = ff NothingC `cat` blockOO b `cat` fl NothingC
-        block (BLast   node)    = ff NothingC `cat` fl (JustC node)
-        block (b @ BTail {})    = ff NothingC `cat` blockOC b
-        blockCO (BFirst n)      = ff (JustC n)
-        blockCO (BHead b n)     = blockCO b `cat` fm n
-        blockOO (BMiddle n)     = fm n
-        blockOO (BCat b1 b2)    = blockOO b1 `cat` blockOO b2
-        blockOC (BLast n)       = fl (JustC n)
-        blockOC (BTail n b)     = fm n `cat` blockOC b
-        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
-        f `cat` g = g . f 
-
-
--- | The following function is easy enough to define but maybe not so useful
-foldBlockNodesF3' :: forall n a b c .
-                   ( n C O -> a -> b
-                   , n O O -> b -> b
-                   , n O C -> b -> c)
-                   -> (a -> b) -- called iff there is no first node
-                   -> (b -> c) -- called iff there is no last node
-                   -> (forall e x . Block n e x -> a -> c)
-foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block
-  where block   :: forall e x . Block n e x -> a -> c
-        blockCO ::              Block n C O -> a -> b
-        blockOO ::              Block n O O -> b -> b
-        blockOC ::              Block n O C -> b -> c
-        block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2
-        block (BFirst  node)    = ff node  `cat` missingLast
-        block (b @ BHead {})    = blockCO b `cat` missingLast
-        block (BMiddle node)    = missingFirst `cat` fm node  `cat` missingLast
-        block (b @ BCat {})     = missingFirst `cat` blockOO b `cat` missingLast
-        block (BLast   node)    = missingFirst `cat` fl node
-        block (b @ BTail {})    = missingFirst `cat` blockOC b
-        blockCO (BFirst n)   = ff n
-        blockCO (BHead b n)  = blockCO b `cat` fm n
-        blockOO (BMiddle n)  = fm n
-        blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2
-        blockOC (BLast n)    = fl n
-        blockOC (BTail n b)  = fm n `cat` blockOC b
-        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
-        f `cat` g = g . f 
-
--- | 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)
--- | Fold a function over every node in a graph.
--- The fold function must be polymorphic in the shape of the nodes.
-
-foldGraphNodes :: forall n a .
-                  (forall e x . n e x       -> a -> a)
-               -> (forall e x . Graph n e x -> 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 (BFirst  node)    = ff node
-        block (BMiddle node)    = fm node
-        block (BLast   node)    = fl node
-        block (b1 `BCat`    b2) = block b1 `cat` block b2
-        block (b1 `BClosed` b2) = block b1 `cat` block b2
-        block (b1 `BHead` n)    = block b1 `cat` fm n
-        block (n `BTail` 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 (BFirst  node)    = ff node
-        block (BMiddle node)    = fm node
-        block (BLast   node)    = fl node
-        block (b1 `BCat`    b2) = block b1 `cat` block b2
-        block (b1 `BClosed` b2) = block b1 `cat` block b2
-        block (b1 `BHead` n)    = block b1 `cat` fm n
-        block (n `BTail` 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)
-
-
-foldGraphNodes f = graph
-    where graph :: forall e x . Graph n e x -> a -> a
-          lift  :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)
-
-          graph GNil              = id
-          graph (GUnit b)         = block b
-          graph (GMany e b x)     = lift block e . body b . lift block x
-          body :: Body n -> a -> a
-          body bdy                = \a -> mapFold block a bdy
-          lift _ NothingO         = id
-          lift f (JustO thing)    = f thing
-
-          block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a
-          block = foldBlockNodesF f
-
-{-# DEPRECATED blockToNodeList, blockOfNodeList 
-  "What justifies these functions?  Can they be eliminated?  Replaced with folds?" #-}
-
-
-
--- | Convert a block to a list of nodes. The entry and exit node
--- is or is not present depending on the shape of the block.
---
--- The blockToNodeList function cannot be currently expressed using
--- foldBlockNodesB, because it returns IndexedCO e a b, which means
--- two different types depending on the shape of the block entry.
--- But blockToNodeList returns one of four possible types, depending
--- on the shape of the block entry *and* exit.
-blockToNodeList :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
-blockToNodeList block = case block of
-  BFirst n    -> (JustC n, [], NothingC)
-  BMiddle n   -> (NothingC, [n], NothingC)
-  BLast n     -> (NothingC, [], JustC n)
-  BCat {}     -> (NothingC, foldOO block [], NothingC)
-  BHead x n   -> case foldCO x [n] of (f, m) -> (f, m, NothingC)
-  BTail n x   -> case foldOC x of (m, l) -> (NothingC, n : m, l)
-  BClosed x y -> case foldOC y of (m, l) -> case foldCO x m of (f, m') -> (f, m', l)
-  where foldCO :: Block n C O -> [n O O] -> (MaybeC C (n C O), [n O O])
-        foldCO (BFirst n) m  = (JustC n, m)
-        foldCO (BHead x n) m = foldCO x (n : m)
-
-        foldOO :: Block n O O -> [n O O] -> [n O O]
-        foldOO (BMiddle n) acc = n : acc
-        foldOO (BCat x y) acc  = foldOO x $ foldOO y acc
-
-        foldOC :: Block n O C -> ([n O O], MaybeC C (n O C))
-        foldOC (BLast n)   = ([], JustC n)
-        foldOC (BTail n x) = case foldOC x of (m, l) -> (n : m, l)
-
--- | Convert a list of nodes to a block. The entry and exit node
--- must or must not be present depending on the shape of the block.
-blockOfNodeList :: (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -> Block n e x
-blockOfNodeList (NothingC, [], NothingC) = error "No nodes to created block from in blockOfNodeList"
-blockOfNodeList (NothingC, m, NothingC)  = foldr1 BCat (map BMiddle m)
-blockOfNodeList (NothingC, m, JustC l)   = foldr BTail (BLast l) m
-blockOfNodeList (JustC f, m, NothingC)   = foldl BHead (BFirst f) m
-blockOfNodeList (JustC f, m, JustC l)    = BClosed (BFirst f) $ foldr BTail (BLast l) m
-
-data BlockResult n x where
-  NoBlock   :: BlockResult n x
-  BodyBlock :: Block n C C -> BlockResult n x
-  ExitBlock :: Block n C O -> BlockResult n O
-
-lookupBlock :: NonLocal n => Graph n e x -> Label -> BlockResult n x
-lookupBlock (GMany _ _ (JustO exit)) lbl
-  | entryLabel exit == lbl = ExitBlock exit
-lookupBlock (GMany _ body _) lbl =
-  case mapLookup lbl body of
-    Just b  -> BodyBlock b
-    Nothing -> NoBlock
-lookupBlock GNil      _ = NoBlock
-lookupBlock (GUnit _) _ = NoBlock