diff --git a/Compiler/Hoopl.hs b/Compiler/Hoopl.hs
new file mode 100644
--- /dev/null
+++ b/Compiler/Hoopl.hs
@@ -0,0 +1,14 @@
+module Compiler.Hoopl
+  ( module Compiler.Hoopl.Dataflow
+  , module Compiler.Hoopl.Fuel
+  , module Compiler.Hoopl.Graph
+  , module Compiler.Hoopl.Label
+  , module Compiler.Hoopl.MkGraph
+  )
+where
+
+import Compiler.Hoopl.Dataflow
+import Compiler.Hoopl.Fuel
+import Compiler.Hoopl.Graph
+import Compiler.Hoopl.Label hiding (allLabels)
+import Compiler.Hoopl.MkGraph
diff --git a/Compiler/Hoopl/Dataflow.hs b/Compiler/Hoopl/Dataflow.hs
new file mode 100644
--- /dev/null
+++ b/Compiler/Hoopl/Dataflow.hs
@@ -0,0 +1,493 @@
+{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- bug in GHC
+
+{- Notes about the genesis of Hoopl7
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Hoopl7 has the following major chages
+
+a) GMany has symmetric entry and exit
+b) GMany closed-entry does not record a BlockId
+c) GMany open-exit does not record a BlockId
+d) The body of a GMany is called Body
+e) A Body is just a list of blocks, not a map. I've argued
+   elsewhere that this is consistent with (c)
+
+A consequence is that Graph is no longer an instance of Edges,
+but nevertheless I managed to keep the ARF and ARB signatures
+nice and uniform.
+
+This was made possible by
+
+* ForwardTransfer looks like this:
+    type ForwardTransfer n f
+      = forall e x. n e x -> Fact e f -> Fact x f 
+    type family   Fact x f :: *
+    type instance Fact C f = FactBase f
+    type instance Fact O f = f
+
+  Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6).
+  It's up to the *transfer function* to look up the appropriate fact
+  in the FactBase for a closed-entry node.  Example:
+	constProp (Label l) fb = lookupFact fb l
+  That is how Hoopl can avoid having to know the block-id for the
+  first node: it defers to the client.
+
+  [Side note: that means the client must know about 
+  bottom, in case the looupFact returns Nothing]
+
+* Note also that ForwardTransfer *returns* a Fact too;
+  that is, the types in both directions are symmetrical.
+  Previously we returned a [(BlockId,f)] but I could not see
+  how to make everything line up if we do this.
+
+  Indeed, the main shortcoming of Hoopl7 is that we are more
+  or less forced into this uniform representation of the facts
+  flowing into or out of a closed node/block/graph, whereas
+  previously we had more flexibility.
+
+  In exchange the code is neater, with fewer distinct types.
+  And morally a FactBase is equivalent to [(BlockId,f)] and
+  nearly equivalent to (BlockId -> f).
+
+* I've realised that forwardBlockList and backwardBlockList
+  both need (Edges n), and that goes everywhere.
+
+* I renamed BlockId to Label
+-}
+
+module Compiler.Hoopl.Dataflow 
+  ( DataflowLattice(..)
+  , ChangeFlag(..)
+  , ForwardPass(..),  FwdTransfer, FwdRewrite, SimpleFwdRewrite
+  , noFwdRewrite, thenFwdRw, shallowFwdRw, deepFwdRw
+  , BackwardPass(..), BwdTransfer, BwdRewrite, SimpleBwdRewrite
+  , noBwdRewrite, thenBwdRw, shallowBwdRw, deepBwdRw
+  , Fact
+  , analyzeAndRewriteFwd, analyzeAndRewriteBwd
+  )
+where
+
+import Compiler.Hoopl.Fuel
+import Compiler.Hoopl.Graph
+import qualified Compiler.Hoopl.GraphUtil as U
+import Compiler.Hoopl.Label
+import Compiler.Hoopl.MkGraph (AGraph)
+
+
+-----------------------------------------------------------------------------
+--		DataflowLattice
+-----------------------------------------------------------------------------
+
+data DataflowLattice a = DataflowLattice  { 
+  fact_name       :: String,                   -- Documentation
+  fact_bot        :: a,                        -- Lattice bottom element
+  fact_extend     :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag
+  fact_do_logging :: Bool                      -- log changes
+}
+
+data ChangeFlag = NoChange | SomeChange
+
+-----------------------------------------------------------------------------
+--		Analyze and rewrite forward: the interface
+-----------------------------------------------------------------------------
+
+data ForwardPass n f
+  = FwdPass { fp_lattice  :: DataflowLattice f
+            , fp_transfer :: FwdTransfer n f
+            , fp_rewrite  :: FwdRewrite n f }
+
+type FwdTransfer n f 
+  = forall e x. n e x -> Fact e f -> Fact x f 
+
+type FwdRewrite n f 
+  = forall e x. n e x -> Fact e f -> Maybe (FwdRes n f e x)
+data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f)
+  -- result of a rewrite is a new graph and a (possibly) new rewrite function
+
+type family   Fact x f :: *
+type instance Fact C f = FactBase f
+type instance Fact O f = f
+
+type SimpleFwdRewrite n f 
+  = forall e x. n e x -> Fact e f
+             -> Maybe (AGraph n e x)
+
+noFwdRewrite :: FwdRewrite n f
+noFwdRewrite _ _ = Nothing
+
+shallowFwdRw :: SimpleFwdRewrite n f -> FwdRewrite n f
+shallowFwdRw rw n f = case (rw n f) of
+                         Nothing -> Nothing
+                         Just ag -> Just (FwdRes ag noFwdRewrite)
+
+thenFwdRw :: FwdRewrite n f -> FwdRewrite n f -> FwdRewrite n f
+thenFwdRw rw1 rw2 n f
+  = case rw1 n f of
+      Nothing               -> rw2 n f
+      Just (FwdRes ag rw1a) -> Just (FwdRes ag (rw1a `thenFwdRw` rw2))
+
+deepFwdRw :: FwdRewrite n f -> FwdRewrite n f
+deepFwdRw rw = rw `thenFwdRw` deepFwdRw rw
+
+analyzeAndRewriteFwd
+   :: forall n f. Edges n
+   => ForwardPass n f
+   -> Body n -> FactBase f
+   -> FuelMonad (Body n, FactBase f)
+
+analyzeAndRewriteFwd pass body facts
+  = do { (rg, _) <- arfBody pass body facts
+       ; return (normaliseBody rg) }
+
+----------------------------------------------------------------
+--       Forward Implementation
+----------------------------------------------------------------
+
+
+type ARF thing n 
+  = forall f e x. ForwardPass n f -> thing e x 
+               -> Fact e f -> FuelMonad (RG n f e x, Fact x f)
+
+arfNode :: Edges n => ARF n n
+arfNode pass node f
+  = do { mb_g <- withFuel (fp_rewrite pass node f)
+       ; case mb_g of
+           Nothing -> return (RGUnit f (BUnit node),
+                              fp_transfer pass node f)
+      	   Just (FwdRes ag rw) -> do { g <- graphOfAGraph ag
+                                     ; let pass' = pass { fp_rewrite = rw }
+                                     ; arfGraph pass' g f } }
+
+arfBlock :: Edges n => ARF (Block n) n
+-- Lift from nodes to blocks
+arfBlock pass (BUnit node)   f = arfNode pass node f
+arfBlock pass (BCat hd mids) f = do { (g1,f1) <- arfBlock pass hd   f  
+                                    ; (g2,f2) <- arfBlock pass mids f1 
+	                            ; return (g1 `RGCatO` g2, f2) }
+
+arfBody :: Edges n
+        => ForwardPass n f -> Body n -> FactBase f
+        -> FuelMonad (RG n f C C, FactBase f)
+		-- Outgoing factbase is restricted to Labels *not* in
+		-- in the Body; the facts for Labels
+		-- *in* the Body are in the BodyWithFacts
+arfBody pass blocks init_fbase
+  = fixpoint True (fp_lattice pass) (arfBlock pass) init_fbase $
+    forwardBlockList (factBaseLabels init_fbase) blocks
+
+arfGraph :: Edges n => ARF (Graph n) n
+-- Lift from blocks to graphs
+arfGraph _    GNil        f = return (RGNil, f)
+arfGraph pass (GUnit blk) f = arfBlock pass blk f
+arfGraph pass (GMany NothingO body NothingO) f
+  = do { (body', fb) <- arfBody pass body f
+       ; return (body', fb) }
+arfGraph pass (GMany NothingO body (JustO exit)) f
+  = do { (body', fb) <- arfBody  pass body f
+       ; (exit', fx) <- arfBlock pass exit fb
+       ; return (body' `RGCatC` exit', fx) }
+arfGraph pass (GMany (JustO entry) body NothingO) f
+  = do { (entry', fe) <- arfBlock pass entry f
+       ; (body', fb)  <- arfBody  pass body fe
+       ; return (entry' `RGCatC` body', fb) }
+arfGraph pass (GMany (JustO entry) body (JustO exit)) f
+  = do { (entry', fe) <- arfBlock pass entry f
+       ; (body', fb)  <- arfBody  pass body fe
+       ; (exit', fx)  <- arfBlock pass exit fb
+       ; return (entry' `RGCatC` body' `RGCatC` exit', fx) }
+
+forwardBlockList :: Edges n => [Label] -> Body n -> [(Label,Block n C C)]
+-- This produces a list of blocks in order suitable for forward analysis.
+-- ToDo: Do a topological sort to improve convergence rate of fixpoint
+--       This will require a (HavingSuccessors l) class constraint
+forwardBlockList  _ blks = bodyList blks
+
+-----------------------------------------------------------------------------
+--		Backward analysis and rewriting: the interface
+-----------------------------------------------------------------------------
+
+data BackwardPass n f
+  = BwdPass { bp_lattice  :: DataflowLattice f
+            , bp_transfer :: BwdTransfer n f
+            , bp_rewrite  :: BwdRewrite n f }
+
+type BwdTransfer n f 
+  = forall e x. n e x -> Fact x f -> Fact e f 
+type BwdRewrite n f 
+  = forall e x. n e x -> Fact x f -> Maybe (BwdRes n f e x)
+data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite n f)
+
+type SimpleBwdRewrite n f 
+  = forall e x. n e x -> Fact x f
+             -> Maybe (AGraph n e x)
+
+noBwdRewrite :: BwdRewrite n f
+noBwdRewrite _ _ = Nothing
+
+shallowBwdRw :: SimpleBwdRewrite n f -> BwdRewrite n f
+shallowBwdRw rw n f = case (rw n f) of
+                         Nothing -> Nothing
+                         Just ag -> Just (BwdRes ag noBwdRewrite)
+
+thenBwdRw :: BwdRewrite n f -> BwdRewrite n f -> BwdRewrite n f
+thenBwdRw rw1 rw2 n f
+  = case rw1 n f of
+      Nothing               -> rw2 n f
+      Just (BwdRes ag rw1a) -> Just (BwdRes ag (rw1a `thenBwdRw` rw2))
+
+deepBwdRw :: BwdRewrite n f -> BwdRewrite n f
+deepBwdRw rw = rw `thenBwdRw` deepBwdRw rw
+
+
+-----------------------------------------------------------------------------
+--		Backward implementation
+-----------------------------------------------------------------------------
+
+type ARB thing n 
+  = forall f e x. BackwardPass n f -> thing e x
+               -> Fact x f -> FuelMonad (RG n f e x, Fact e f)
+
+arbNode :: Edges n => ARB n n
+-- Lifts (BwdTransfer,BwdRewrite) to ARB_Node; 
+-- this time we do rewriting as well. 
+-- The ARB_Graph parameters specifies what to do with the rewritten graph
+arbNode pass node f
+  = do { mb_g <- withFuel (bp_rewrite pass node f)
+       ; case mb_g of
+           Nothing -> return (RGUnit entry_f (BUnit node), entry_f)
+                    where
+                      entry_f = bp_transfer pass node f
+      	   Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag
+                                     ; let pass' = pass { bp_rewrite = rw }
+                                     ; arbGraph pass' g f} }
+
+arbBlock :: Edges n => ARB (Block n) n 
+-- Lift from nodes to blocks
+arbBlock pass (BUnit node) f = arbNode pass node f
+arbBlock pass (BCat b1 b2) f = do { (g2,f2) <- arbBlock pass b2 f
+                                  ; (g1,f1) <- arbBlock pass b1 f2
+	                          ; return (g1 `RGCatO` g2, f1) }
+
+arbBody :: Edges n
+        => BackwardPass n f -> Body n -> FactBase f
+        -> FuelMonad (RG n f C C, FactBase f)
+arbBody pass blocks init_fbase
+  = fixpoint False (bp_lattice pass) (arbBlock pass) init_fbase $
+    backwardBlockList (factBaseLabels init_fbase) blocks 
+
+arbGraph :: Edges n => ARB (Graph n) n
+arbGraph _    GNil        f = return (RGNil, f)
+arbGraph pass (GUnit blk) f = arbBlock pass blk f
+arbGraph pass (GMany NothingO body NothingO) f
+  = do { (body', fb) <- arbBody pass body f
+       ; return (body', fb) }
+arbGraph pass (GMany NothingO body (JustO exit)) f
+  = do { (exit', fx) <- arbBlock pass exit f
+       ; (body', fb) <- arbBody  pass body fx
+       ; return (body' `RGCatC` exit', fb) }
+arbGraph pass (GMany (JustO entry) body NothingO) f
+  = do { (body', fb)  <- arbBody  pass body f
+       ; (entry', fe) <- arbBlock pass entry fb
+       ; return (entry' `RGCatC` body', fe) }
+arbGraph pass (GMany (JustO entry) body (JustO exit)) f
+  = do { (exit', fx)  <- arbBlock pass exit f
+       ; (body', fb)  <- arbBody  pass body fx
+       ; (entry', fe) <- arbBlock pass entry fb
+       ; return (entry' `RGCatC` body' `RGCatC` exit', fe) }
+
+backwardBlockList :: Edges n => [Label] -> Body n -> [(Label,Block n C C)]
+-- This produces a list of blocks in order suitable for backward analysis.
+backwardBlockList _ blks = bodyList blks
+
+analyzeAndRewriteBwd
+   :: forall n f. Edges n
+   => BackwardPass n f 
+   -> Body n -> FactBase f 
+   -> FuelMonad (Body n, FactBase f)
+
+analyzeAndRewriteBwd pass body facts
+  = do { (rg, _) <- arbBody pass body facts
+       ; return (normaliseBody rg) }
+
+
+-----------------------------------------------------------------------------
+--      fixpoint: finding fixed points
+-----------------------------------------------------------------------------
+
+data TxFactBase n f
+  = TxFB { tfb_fbase :: FactBase f
+         , tfb_rg  :: RG n f C C -- Transformed blocks
+         , tfb_cha   :: ChangeFlag
+         , tfb_lbls  :: LabelSet }
+ -- Note [TxFactBase change flag]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- Set the tfb_cha flag iff 
+ --   (a) the fact in tfb_fbase for or a block L changes
+ --   (b) L is in tfb_lbls.
+ -- The tfb_lbls are all Labels of the *original* 
+ -- (not transformed) blocks
+
+updateFact :: DataflowLattice f -> LabelSet -> (Label, f)
+           -> (ChangeFlag, FactBase f) 
+           -> (ChangeFlag, FactBase f)
+-- See Note [TxFactBase change flag]
+updateFact lat lbls (lbl, new_fact) (cha, fbase)
+  | NoChange <- cha2        = (cha,        fbase)
+  | lbl `elemLabelSet` lbls = (SomeChange, new_fbase)
+  | otherwise               = (cha,        new_fbase)
+  where
+    (cha2, res_fact) 
+       = case lookupFact fbase lbl of
+           Nothing -> (SomeChange, new_fact)  -- Note [Unreachable blocks]
+           Just old_fact -> fact_extend lat old_fact new_fact
+    new_fbase = extendFactBase fbase lbl res_fact
+
+fixpoint :: forall n f. Edges n
+         => Bool	-- Going forwards?
+         -> DataflowLattice f
+         -> (Block n C C -> FactBase f
+              -> FuelMonad (RG n f C C, FactBase f))
+         -> FactBase f -> [(Label, Block n C C)]
+         -> FuelMonad (RG n f C C, FactBase f)
+fixpoint is_fwd lat do_block init_fbase blocks
+  = do { fuel <- getFuel  
+       ; tx_fb <- loop fuel init_fbase
+       ; return (tfb_rg tx_fb, 
+                 tfb_fbase tx_fb `delFromFactBase` blocks) }
+	     -- The successors of the Graph are the the Labels for which
+	     -- we have facts, that are *not* in the blocks of the graph
+  where
+    tx_blocks :: [(Label, Block n C C)] 
+              -> TxFactBase n f -> FuelMonad (TxFactBase n f)
+    tx_blocks []             tx_fb = return tx_fb
+    tx_blocks ((lbl,blk):bs) tx_fb = tx_block lbl blk tx_fb >>= tx_blocks bs
+
+    tx_block :: Label -> Block n C C 
+             -> TxFactBase n f -> FuelMonad (TxFactBase n f)
+    tx_block lbl blk tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls
+                                 , tfb_rg = blks, tfb_cha = cha })
+      | is_fwd && not (lbl `elemFactBase` fbase)
+      = return tx_fb	-- Note [Unreachable blocks]
+      | otherwise
+      = do { (rg, out_facts) <- do_block blk fbase
+           ; let (cha',fbase') 
+                   = foldr (updateFact lat lbls) (cha,fbase) 
+                           (factBaseList out_facts)
+           ; return (TxFB { tfb_lbls  = extendLabelSet lbls lbl
+                          , tfb_rg  = rg `RGCatC` blks
+                          , tfb_fbase = fbase', tfb_cha = cha' }) }
+
+    loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)
+    loop fuel fbase 
+      = do { let init_tx_fb = TxFB { tfb_fbase = fbase
+                                   , tfb_cha   = NoChange
+                                   , tfb_rg  = RGNil
+                                   , tfb_lbls  = emptyLabelSet }
+           ; tx_fb <- tx_blocks blocks init_tx_fb
+           ; case tfb_cha tx_fb of
+               NoChange   -> return tx_fb
+               SomeChange -> do { setFuel fuel
+                                ; loop fuel (tfb_fbase tx_fb) } }
+
+{- Note [Unreachable blocks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A block that is not in the domain of tfb_fbase is "currently unreachable".
+A currently-unreachable block is not even analyzed.  Reason: consider 
+constant prop and this graph, with entry point L1:
+  L1: x:=3; goto L4
+  L2: x:=4; goto L4
+  L4: if x>3 goto L2 else goto L5
+Here L2 is actually unreachable, but if we process it with bottom input fact,
+we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
+
+* If a currently-unreachable block is not analyzed, then its rewritten
+  graph will not be accumulated in tfb_rg.  And that is good:
+  unreachable blocks simply do not appear in the output.
+
+* Note that clients must be careful to provide a fact (even if bottom)
+  for each entry point. Otherwise useful blocks may be garbage collected.
+
+* Note that updateFact must set the change-flag if a label goes from
+  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the
+  real fact lattice is
+       UNR
+       bottom
+       the points above bottom
+
+* All of this only applies for *forward* fixpoints.  For the backward
+  case we must treat every block as reachable; it might finish with a
+  'return', and therefore have no successors, for example.
+-}
+
+-----------------------------------------------------------------------------
+--	RG: an internal data type for graphs under construction
+--          TOTALLY internal to Hoopl
+-----------------------------------------------------------------------------
+
+data RG n f e x where
+  RGNil   :: RG n f a a
+  RGUnit  :: Fact e f -> Block n e x -> RG n f e x
+  RGCatO  :: RG n f e O -> RG n f O x -> RG n f e x
+  RGCatC  :: RG n f e C -> RG n f C x -> RG n f e x
+
+type BodyWithFacts  n f     = (Body n, FactBase f)
+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
+
+normaliseBody :: Edges n => RG n f C C -> BodyWithFacts n f
+normaliseBody rg = (body, fact_base)
+  where
+    (GMany _ body _, fact_base) = normCC rg
+
+normOO :: Edges n => RG n f O O -> GraphWithFacts n f O O
+normOO RGNil          = (GNil, noFacts)
+normOO (RGUnit _ b)   = (GUnit b, noFacts)
+normOO (RGCatO g1 g2) = normOO g1 `gwfCat` normOO g2
+normOO (RGCatC g1 g2) = normOC g1 `gwfCat` normCO g2
+
+normOC :: Edges n => RG n f O C -> GraphWithFacts n f O C
+normOC (RGUnit _ b)   = (GMany (JustO b) BodyEmpty NothingO, noFacts)
+normOC (RGCatO g1 g2) = normOO g1 `gwfCat` normOC g2
+normOC (RGCatC g1 g2) = normOC g1 `gwfCat` normCC g2
+
+normCO :: Edges n => RG n f C O -> GraphWithFacts n f C O
+normCO (RGUnit f b) = (GMany NothingO BodyEmpty (JustO b), unitFact l f)
+                    where
+                      l = entryLabel b
+normCO (RGCatO g1 g2) = normCO g1 `gwfCat` normOO g2
+normCO (RGCatC g1 g2) = normCC g1 `gwfCat` normCO g2
+
+normCC :: Edges n => RG n f C C -> GraphWithFacts n f C C
+normCC RGNil        = (GMany NothingO BodyEmpty NothingO, noFacts)
+normCC (RGUnit f b) = (GMany NothingO (BodyUnit b) NothingO, unitFact l f)
+                    where
+                      l = entryLabel b
+normCC (RGCatO g1 g2) = normCO g1 `gwfCat` normOC g2
+normCC (RGCatC g1 g2) = normCC g1 `gwfCat` normCC g2
+
+gwfCat :: Edges n => GraphWithFacts n f e a
+                  -> GraphWithFacts n f a x 
+                  -> GraphWithFacts n f e x
+gwfCat (g1, fb1) (g2, fb2) = (g1 `gCat` g2, fb1 `unionFactBase` fb2)
+
+{-
+bwfUnion :: BodyWithFacts n f -> BodyWithFacts n f -> BodyWithFacts n f
+bwfUnion (bg1, fb1) (bg2, fb2) = (bg1 `BodyCat` bg2, fb1 `unionFactBase` fb2)
+-}
+
+-----------------------------------------------------------------------------
+
+graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
+graphOfAGraph ag = ag
+
+
+gCat :: Graph n e a -> Graph n a x -> Graph n e x
+gCat = U.gCatAny
+
+{- Not sure why the following does not work!  ---NR
+gCat g@(GMany _ _ NothingO) g' = U.gCatClosed g g'
+gCat g g'@(GMany NothingO _ _) = U.gCatClosed g g'
+gCat g g' = U.gCat g g'
+-}
+
diff --git a/Compiler/Hoopl/Fuel.hs b/Compiler/Hoopl/Fuel.hs
new file mode 100644
--- /dev/null
+++ b/Compiler/Hoopl/Fuel.hs
@@ -0,0 +1,40 @@
+-----------------------------------------------------------------------------
+--		The fuel monad
+-----------------------------------------------------------------------------
+
+module Compiler.Hoopl.Fuel
+  ( Fuel
+  , FuelMonad, withFuel, getFuel, setFuel
+  , freshLabel
+    
+  , runWithFuel
+  )
+where
+
+import Compiler.Hoopl.Label
+
+type Fuel    = Int
+
+newtype FuelMonad a = FM { unFM :: Fuel -> [Label] -> (a, Fuel, [Label]) }
+
+instance Monad FuelMonad where
+  return x = FM (\f u -> (x,f,u))
+  m >>= k  = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u')
+
+withFuel :: Maybe a -> FuelMonad (Maybe a)
+withFuel Nothing  = return Nothing
+withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u)
+                                else (Just r, f-1, u))
+
+getFuel :: FuelMonad Fuel
+getFuel = FM (\f u -> (f,f,u))
+
+setFuel :: Fuel -> FuelMonad ()
+setFuel f = FM (\_ u -> ((), f, u))
+
+runWithFuel :: Fuel -> FuelMonad a -> a
+runWithFuel fuel m = a
+  where (a, _, _) = unFM m fuel allLabels
+
+freshLabel :: FuelMonad Label
+freshLabel = FM (\f (l:ls) -> (l, f, ls))
diff --git a/Compiler/Hoopl/Graph.hs b/Compiler/Hoopl/Graph.hs
new file mode 100644
--- /dev/null
+++ b/Compiler/Hoopl/Graph.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE GADTs, EmptyDataDecls #-}
+
+module Compiler.Hoopl.Graph 
+  ( O, C, Block(..), Body(..), Graph(..), MaybeO(..)
+  , Edges, entryLabel, successors
+  , addBlock, bodyList
+  )
+where
+
+import Compiler.Hoopl.Label
+
+-----------------------------------------------------------------------------
+--		Graphs
+-----------------------------------------------------------------------------
+
+data O
+data C
+
+-- Blocks are always non-empty
+data Block n e x where
+  BUnit :: n e x -> Block n e x
+  BCat  :: Block n e O -> Block n O x -> Block n e x
+
+data Body n where
+  BodyEmpty :: Body n
+  BodyUnit  :: Block n C C -> Body n
+  BodyCat   :: Body n -> Body n -> Body n
+
+data Graph n e x where
+  GNil  :: Graph n O O
+  GUnit :: Block n O O -> Graph n O O
+  GMany :: MaybeO e (Block n O C) 
+        -> Body n
+        -> MaybeO x (Block n C O)
+        -> Graph n e x
+
+data MaybeO ex t where
+  JustO    :: t -> MaybeO O t
+  NothingO ::      MaybeO C t
+
+-------------------------------
+class Edges thing where
+  entryLabel :: thing C x -> Label
+  successors :: thing e C -> [Label]
+
+instance Edges n => Edges (Block n) where
+  entryLabel (BUnit n) = entryLabel n
+  entryLabel (b `BCat` _) = entryLabel b
+  successors (BUnit n)   = successors n
+  successors (BCat _ b)  = successors b
+
+------------------------------
+addBlock :: Block n C C -> Body n -> Body n
+addBlock b body = BodyUnit b `BodyCat` body
+
+bodyList :: Edges n => Body n -> [(Label,Block n C C)]
+bodyList body = go body []
+  where
+    go BodyEmpty       bs = bs
+    go (BodyUnit b)    bs = (entryLabel b, b) : bs
+    go (BodyCat b1 b2) bs = go b1 (go b2 bs)
+
diff --git a/Compiler/Hoopl/GraphUtil.hs b/Compiler/Hoopl/GraphUtil.hs
new file mode 100644
--- /dev/null
+++ b/Compiler/Hoopl/GraphUtil.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- bug in GHC
+
+-- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint
+
+module Compiler.Hoopl.GraphUtil
+  ( gCat, addEntrySeq, addExitSeq -- , addBasicBlocks
+  , gCatClosed
+  , gCatAny
+  , bodyGraph
+  )
+
+where
+
+import Compiler.Hoopl.Graph
+
+bodyGraph :: Body n -> Graph n C C
+bodyGraph b = GMany NothingO b NothingO
+
+
+gCatAny        :: Graph n e a -> Graph n a x -> Graph n e x
+gCat           :: Graph n e O -> Graph n O x -> Graph n e x
+addEntrySeq    :: Graph n O C -> Graph n C x -> Graph n O x
+addExitSeq     :: Graph n e C -> Graph n C O -> Graph n e O
+--addBasicBlocks :: Graph n e x -> Graph n C C -> Graph n e x
+gCatClosed     :: Graph n e C -> Graph n C x -> Graph n e x
+
+gCatAny GNil g2 = g2
+gCatAny g1 GNil = g1
+
+gCatAny (GUnit b1) (GUnit b2)             
+  = GUnit (b1 `BCat` b2)
+
+gCatAny (GUnit b) (GMany (JustO e) bs x) 
+  = GMany (JustO (b `BCat` e)) bs x
+
+gCatAny (GMany e bs (JustO x)) (GUnit b2) 
+  = GMany e bs (JustO (x `BCat` b2))
+
+gCatAny (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) bs2 x2)
+  = GMany e1 (addBlock (x1 `BCat` e2) bs1 `BodyCat` bs2) x2
+
+gCatAny (GMany e1 bs1 NothingO) (GMany NothingO bs2 x2)
+   = GMany e1 (bs1 `BodyCat` bs2) x2
+
+gCat = gCatAny
+addEntrySeq = gCatAny
+addExitSeq = gCatAny
+gCatClosed = gCatAny
+
+{-
+addEntrySeq (GMany entry body NothingO) (GMany NothingO body' exit) 
+  = GMany entry (body `BodyCat` body') exit
+  
+addExitSeq  (GMany entry body NothingO) (GMany NothingO body' exit) 
+  = GMany entry (body `BodyCat` body') exit
+  
+--addBasicBlocks GNil g2 = g2
+
+
+gCatClosed (GMany e1 bs1 NothingO) (GMany NothingO bs2 x2)
+   = GMany e1 (bs1 `BodyCat` bs2) x2
+-}
diff --git a/Compiler/Hoopl/Label.hs b/Compiler/Hoopl/Label.hs
new file mode 100644
--- /dev/null
+++ b/Compiler/Hoopl/Label.hs
@@ -0,0 +1,98 @@
+module Compiler.Hoopl.Label
+  ( Label
+  , allLabels -- to be used only by the Fuel monad
+  , LabelMap
+  , FactBase, noFacts, mkFactBase, unitFact, lookupFact, extendFactBase
+            , delFromFactBase, unionFactBase
+            , elemFactBase, factBaseLabels, factBaseList
+  , LabelSet, emptyLabelSet, extendLabelSet, mkLabelSet, elemLabelSet, labelSetElems
+            , minusLabelSet, unionLabelSet
+  )
+
+where
+
+import qualified Data.IntMap as M
+import qualified Data.IntSet as S
+
+newtype Label = Label { unLabel :: Int }
+  deriving (Eq, Ord)
+
+instance Show Label where
+  show (Label n) = "L" ++ show n
+
+
+allLabels :: [Label]
+allLabels = map Label [1..]
+
+type LabelMap a = M.IntMap a
+
+
+
+-----------------------------------------------------------------------------
+--		Label, FactBase, LabelSet
+-----------------------------------------------------------------------------
+
+
+----------------------
+type FactBase a = M.IntMap a
+
+mapFst :: (a->b) -> (a, c) -> (b, c)
+mapFst f (a, c) = (f a, c)
+
+noFacts :: FactBase f
+noFacts = M.empty
+
+mkFactBase :: [(Label, f)] -> FactBase f
+mkFactBase prs = M.fromList $ map (mapFst unLabel) prs
+
+unitFact :: Label -> FactBase f -> FactBase f
+-- Restrict a fact base to a single fact
+unitFact (Label l) fb = case M.lookup l fb of
+                  Just f  -> M.singleton l f
+                  Nothing -> M.empty
+
+lookupFact :: FactBase f -> Label -> Maybe f
+lookupFact env (Label blk_id) = M.lookup blk_id env
+
+extendFactBase :: FactBase f -> Label -> f -> FactBase f
+extendFactBase env (Label blk_id) f = M.insert blk_id f env
+
+unionFactBase :: FactBase f -> FactBase f -> FactBase f
+unionFactBase = M.union
+
+elemFactBase :: Label -> FactBase f -> Bool
+elemFactBase (Label l) = M.member l
+
+factBaseLabels :: FactBase f -> [Label]
+factBaseLabels = map Label . M.keys
+
+factBaseList :: FactBase f -> [(Label, f)]
+factBaseList = map (mapFst Label) . M.toList 
+
+delFromFactBase :: FactBase f -> [(Label,a)] -> FactBase f
+delFromFactBase fb blks = foldr (M.delete . unLabel . fst) fb blks
+
+----------------------
+type LabelSet = S.IntSet
+
+emptyLabelSet :: LabelSet
+emptyLabelSet = S.empty
+
+extendLabelSet :: LabelSet -> Label -> LabelSet
+extendLabelSet lbls (Label bid) = S.insert bid lbls
+
+elemLabelSet :: Label -> LabelSet -> Bool
+elemLabelSet (Label bid) lbls = S.member bid lbls
+
+labelSetElems :: LabelSet -> [Label]
+labelSetElems = map Label . S.toList
+
+minusLabelSet :: LabelSet -> LabelSet -> LabelSet
+minusLabelSet = S.difference
+
+unionLabelSet :: LabelSet -> LabelSet -> LabelSet
+unionLabelSet = S.union
+
+mkLabelSet :: [Label] -> LabelSet
+mkLabelSet = S.fromList . map unLabel
+
diff --git a/Compiler/Hoopl/MkGraph.hs b/Compiler/Hoopl/MkGraph.hs
new file mode 100644
--- /dev/null
+++ b/Compiler/Hoopl/MkGraph.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Compiler.Hoopl.MkGraph
+    ( AGraph, (<*>)
+    , emptyAGraph, withFreshLabels
+    , mkMiddle, mkMiddles, mkLast, mkEntry, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
+    , addEntrySeq, addExitSeq, catAGraphs
+    , IfThenElseable
+    )
+where
+
+import Compiler.Hoopl.Label (Label)
+import Compiler.Hoopl.Graph
+import Compiler.Hoopl.Fuel
+import qualified Compiler.Hoopl.GraphUtil as U
+
+import Control.Monad (liftM2)
+
+type AGraph n e x = FuelMonad (Graph n e x)
+
+infixr 3 <*>
+(<*>) :: AGraph n e O -> AGraph n O x -> AGraph n e x
+
+class Labels l where
+  withFreshLabels :: (l -> AGraph n e x) -> AGraph n e x
+
+emptyAGraph :: AGraph n O O
+emptyAGraph = return GNil
+
+addEntrySeq    :: AGraph n O C -> AGraph n C x -> AGraph n O x
+addExitSeq     :: AGraph n e C -> AGraph n C O -> AGraph n e O
+gCatClosed     :: AGraph n e C -> AGraph n C x -> AGraph n e x
+
+addEntrySeq = liftM2 U.addEntrySeq
+addExitSeq  = liftM2 U.addExitSeq
+gCatClosed  = liftM2 U.gCatClosed
+
+mkFirst  :: n C O -> AGraph n C O
+mkMiddle :: n O O -> AGraph n O O
+mkLast   :: n O C -> AGraph n O C
+
+mkLabel :: (Node n) => Label -> AGraph n C O -- graph contains the label
+
+-- below for convenience
+mkMiddles :: [n O O] -> AGraph n O O
+mkEntry   :: Block n O C -> AGraph n O C
+mkExit    :: Block n C O -> AGraph n C O
+
+class Edges n => Node n where
+  mkBranchNode :: Label -> n O C
+  mkLabelNode  :: Label -> n C O
+
+mkBranch :: (Node n) => Label -> AGraph n O C
+
+class IfThenElseable x where
+  mkIfThenElse :: Node n
+               => (Label -> Label -> AGraph n O C) -- branch condition
+               -> AGraph n O x   -- code in the 'then' branch
+               -> AGraph n O x   -- code in the 'else' branch 
+               -> AGraph n O x   -- resulting if-then-else construct
+{-
+  fallThroughTo :: Node n
+                => Label -> AGraph n e x -> AGraph n e C
+-}
+
+mkWhileDo    :: (Node n)
+                => (Label -> Label -> AGraph n O C) -- loop condition
+                -> AGraph n O O  -- body of the bloop
+                -> AGraph n O O -- the final while loop
+
+-- ================================================================
+--                          IMPLEMENTATION
+-- ================================================================
+
+(<*>) = liftM2 U.gCat 
+
+catAGraphs :: [AGraph n O O] -> AGraph n O O
+catAGraphs = foldr (<*>) emptyAGraph
+
+-------------------------------------
+-- constructors
+
+mkLabel  id     = mkFirst $ mkLabelNode id
+mkBranch target = mkLast  $ mkBranchNode target
+mkMiddles ms = foldr (<*>) (return GNil) (map mkMiddle ms)
+
+
+{-
+outOfLine (AGraph g :: AGraph n C C) = AGraph g'
+  where g' :: UniqSM (Graph n O O)
+        g' = do zgraph <- g
+                case zgraph of
+                  GF (Z.ZE_C _) _ Z.ZX_C ->
+                      do id <- freshLabel "outOfLine"
+                         return $ Z.mkLast (mkBranchNode id) <**> zgraph <**>
+                                  Z.mkLabel id
+                  _ -> panic "tried to outOfLine a graph open at one or both ends"
+-}
+
+instance IfThenElseable O where
+  mkIfThenElse cbranch tbranch fbranch = do
+    endif  <- freshLabel
+    ltrue  <- freshLabel
+    lfalse <- freshLabel
+    cbranch ltrue lfalse `addEntrySeq`
+      (mkLabel ltrue  <*> tbranch <*> mkBranch endif) `gCatClosed`
+      (mkLabel lfalse <*> fbranch <*> mkBranch endif) `gCatClosed`
+      mkLabel endif
+
+{-
+  fallThroughTo id g = g <*> mkBranch id
+-}
+
+instance IfThenElseable C where
+  mkIfThenElse cbranch tbranch fbranch = do
+    ltrue  <- freshLabel
+    lfalse <- freshLabel
+    cbranch ltrue lfalse `gCatClosed`
+       mkLabel ltrue  <*> tbranch `gCatClosed`
+       mkLabel lfalse <*> fbranch
+{-
+  fallThroughTo _ g = g
+-}
+
+mkWhileDo cbranch body = do
+  test <- freshLabel
+  head <- freshLabel
+  endwhile <- freshLabel
+     -- Forrest Baskett's while-loop layout
+  mkBranch test `gCatClosed`
+    mkLabel head <*> body <*> mkBranch test `gCatClosed`
+    mkLabel test <*> cbranch head endwhile  `gCatClosed`
+    mkLabel endwhile
+
+-------------------------------------
+-- Debugging
+
+{-
+pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph n e x -> UniqSM SDoc
+pprAGraph g = graphOfAGraph g >>= return . ppr
+-}
+
+{-
+Note [Branch follows branch]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Why do we say it's ok for a Branch to follow a Branch?
+Because the standard constructor mkLabel-- has fall-through
+semantics. So if you do a mkLabel, you finish the current block,
+giving it a label, and start a new one that branches to that label.
+Emitting a Branch at this point is fine: 
+       goto L1; L2: ...stuff... 
+-}
+
+
+instance Labels Label where
+  withFreshLabels f = freshLabel >>= f
+
+instance (Labels l1, Labels l2) => Labels (l1, l2) where
+  withFreshLabels f = withFreshLabels $ \l1 ->
+                      withFreshLabels $ \l2 ->
+                      f (l1, l2)
+
+instance (Labels l1, Labels l2, Labels l3) => Labels (l1, l2, l3) where
+  withFreshLabels f = withFreshLabels $ \l1 ->
+                      withFreshLabels $ \l2 ->
+                      withFreshLabels $ \l3 ->
+                      f (l1, l2, l3)
+
+instance (Labels l1, Labels l2, Labels l3, Labels l4) => Labels (l1, l2, l3, l4) where
+  withFreshLabels f = withFreshLabels $ \l1 ->
+                      withFreshLabels $ \l2 ->
+                      withFreshLabels $ \l3 ->
+                      withFreshLabels $ \l4 ->
+                      f (l1, l2, l3, l4)
+
+
+mkExit   block = return $ GMany NothingO      BodyEmpty (JustO block)
+mkEntry  block = return $ GMany (JustO block) BodyEmpty NothingO
+
+mkFirst  = mkExit  . BUnit
+mkLast   = mkEntry . BUnit
+mkMiddle = return  . GUnit . BUnit
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,33 @@
+Copyright (c) 2010, João Dias, Simon Peyton Jones, and Norman Ramsey
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+Neither the name of Tufts University nor the names of its
+contributors may be used to endorse or promote products derived from
+this software without specific prior written permission.
+
+Neither the name of Microsoft nor the names of its
+contributors may be used to endorse or promote products derived from
+this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/hoopl.cabal b/hoopl.cabal
new file mode 100644
--- /dev/null
+++ b/hoopl.cabal
@@ -0,0 +1,19 @@
+Name:                hoopl
+Version:             3.7.0.0
+Description:         Higher-order optimization library
+License:             BSD3
+License-file:        LICENSE
+Author:              Norman Ramsey, João Dias, and Simon Peyton Jones
+Maintainer:          nr@cs.tufts.edu
+Build-Type:          Simple
+Cabal-Version:       >=1.2
+Synopsis:            A library to support dataflow analysis and optimization
+Category:            Compilers/Interpeters
+
+Library
+  Build-Depends:     base >= 3 && < 5, containers
+  Exposed-modules:   Compiler.Hoopl,
+                     Compiler.Hoopl.Dataflow, Compiler.Hoopl.Graph, 
+                     Compiler.Hoopl.GraphUtil, Compiler.Hoopl.MkGraph,
+                     Compiler.Hoopl.Fuel, Compiler.Hoopl.Label
+  ghc-options:       -Wall -fno-warn-name-shadowing