Along with the merge, the name Node was stolen from underfoot.
authorJoao Dias <dias@cs.tufts.edu>
Wed, 7 Apr 2010 19:28:22 +0000 (15:28 -0400)
committerJoao Dias <dias@cs.tufts.edu>
Wed, 7 Apr 2010 19:28:22 +0000 (15:28 -0400)
Merge branch 'master' of linux:/r/c--/papers/dfopt

Conflicts:
src/Compiler/Hoopl/MkGraph.hs

1  2 
src/Compiler/Hoopl/Dataflow.hs
testing/ConstProp.hs
testing/CunningTransfers.hs
testing/Eval.hs
testing/EvalMonad.hs
testing/Hoopl.hs
testing/IR.hs
testing/Live.hs
testing/OptSupport.hs
testing/Parse.hs
testing/Simplify.hs

Simple merge
@@@ -36,26 -31,24 +36,26 @@@ initFact vars = M.fromList $ [(v, Top) 
  -- at a call site.
  -- Note that we don't need a case for x := y, where y holds a constant.
  -- We can write the simplest solution and rely on the interleaved optimization.
- varHasLit :: FwdTransfer Node ConstFact
 -varHasLit :: ForwardTransfers Node ConstFact
 -varHasLit f (Label _)          = f
 -varHasLit f (Assign x (Lit l)) = M.insert x (Elt l) f
 -varHasLit f (Assign x _)       = M.insert x Top f
 -varHasLit f (Store _ _)        = f
 -varHasLit f (Branch bid)       = [(bid, f)]
 -varHasLit f (Cond (Var x) tid fid) = [(tid, tf), (fid, ff)]
++varHasLit :: FwdTransfer Insn ConstFact
 +varHasLit (Label l)          f = fromMaybe M.empty $ lookupFact f l
 +varHasLit (Assign x (Lit l)) f = M.insert x (Elt l) f
 +varHasLit (Assign x _)       f = M.insert x Top f
 +varHasLit (Store _ _)        f = f
 +varHasLit (Branch bid)       f = mkFactBase [(bid, f)]
 +varHasLit (Cond (Var x) tid fid) f = mkFactBase [(tid, tf), (fid, ff)]
    where tf = M.insert x (bool True)  f
          ff = M.insert x (bool False) f
          bool b = Elt (Bool b)
 -varHasLit f (Cond _ tid fid)   = [(tid, f), (fid, f)]
 -varHasLit _ (Call _ _ _ bid)   = [(bid, fact_bot constLattice)]
 -varHasLit _ (Return _)         = []
 +varHasLit (Cond _ tid fid) f = mkFactBase [(tid, f), (fid, f)]
 +varHasLit (Call _ _ _ bid) _ = mkFactBase [(bid, fact_bot constLattice)]
 +varHasLit (Return _)       _ = mkFactBase []
  
  -- Constant propagation: rewriting
- constProp :: FwdRewrite Node ConstFact
 -constProp :: ForwardRewrites Node ConstFact
 -constProp facts n = map_EN (map_EE rewriteE) n >>= Just . toAGraph
 -  where rewriteE (Var v) = case M.lookup v facts of
 -                             Just (Elt l) -> Just $ Lit l
 -                             _            -> Nothing
 -        rewriteE _ = Nothing
++constProp :: FwdRewrite Insn ConstFact
 +constProp = shallowFwdRw cp 
 +  where
-     cp n facts = map_EN (map_EE $ rewriteE (getFwdFact n facts M.empty)) n >>= Just . nodeToA
++    cp n facts = map_EN (map_EE $ rewriteE (getFwdFact n facts M.empty)) n >>= Just . insnToA
 +    rewriteE facts (Var v) = case M.lookup v facts of
 +                               Just (Elt l) -> Just $ Lit l
 +                               _            -> Nothing
 +    rewriteE _ _ = Nothing
diff --cc testing/CunningTransfers.hs
index 5b6e1a0,5b6e1a0..0000000
deleted file mode 100644,100644
+++ /dev/null
@@@ -1,455 -1,455 +1,0 @@@
--{-# OPTIONS_GHC -Wall #-}
--{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}
--
---- This version uses type families to express the functional dependency
---- between the open/closed-ness of the input graph and the type of the
---- input fact expected for a graph of that shape
--
--module CunningTransfers (BlockId, O, C, Block (..), Graph (..), Exit (..),
--                         BlockEnv, findBEnv, mkBlockEnv, Edges (..)) where
--
--import qualified Data.IntMap as M
--import qualified Data.IntSet as S
--
-------------------------------------------------------------------------------
----            Graphs
-------------------------------------------------------------------------------
--
--data ZOpen
--data ZClosed
--
--type O = ZOpen
--type C = ZClosed
--
---- 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
--
--type Blocks n = [Block n C C]
--
--data Graph n e x where
--  GNil  :: Graph n O O
--  GUnit :: Block n e x -> Graph n e x
--  GMany   { g_entry  :: Block n e C
--          , g_blocks :: Blocks n
--        , g_exit   :: Exit (Block n) x } :: Graph n e x
--
--   -- Invariant:  if g_entry is closed,
--   -- its BlockId cannot be a target of
--   -- branches in the blocks
--
--   -- If a graph has a Tail, then that tail is the only  
--   -- exit from the graph, even if the Tail is closed
--   -- See the definition of successors!
--
--data Exit thing x where
--  NoTail :: Exit thing C
--  Tail   :: thing C x -> Exit thing x
--
--class Edges n where
--  blockId    :: n C x -> BlockId
--  successors :: n e C -> [BlockId]
--
--instance Edges n => Edges (Block n) where
--  blockId    (BUnit n)  = blockId n
--  blockId    (BCat b _) = blockId b
--  successors (BUnit n)  = successors n
--  successors (BCat _ b) = successors b
--
--instance Edges n => Edges (Graph n) where
--  blockId    (GUnit b)  = blockId b
--  blockId    (GMany b _ _) = blockId b
--  successors (GUnit b)            = successors b
--  successors (GMany _ _ (Tail b)) = successors b
--  successors (GMany b bs NoTail) 
--     = blockSetElems (all_succs `minusBlockSet` all_blk_ids)
--     where 
--       all_succs   = mkBlockSet (successors b ++ concatMap successors bs)
--       all_blk_ids = mkBlockSet (map blockId bs)
--
--
--gCat :: Graph n e O -> Graph n O x -> Graph n e x
--gCat GNil g2 = g2
--gCat g1 GNil = g1
--
--gCat (GUnit b1) (GUnit b2)             
--  = GUnit (b1 `BCat` b2)
--
--gCat (GUnit b) (GMany e bs x) 
--  = GMany (b `BCat` e) bs x
--
--gCat (GMany e bs (Tail x)) (GUnit b2) 
--   = GMany e bs (Tail (x `BCat` b2))
--
--gCat (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2)
--   = GMany e1 (x1 `BCat` e2 : bs1 ++ bs2) x2
--
--gCatC :: Graph n e C -> Graph n C x -> Graph n e x
--gCatC (GUnit b1)               (GUnit b2)        = GMany b1 [] (Tail b2)
--gCatC (GUnit b1)               (GMany e2 bs x2)  = GMany b1 (e2:bs) x2
--gCatC (GMany e bs NoTail)      (GUnit b2)        = GMany e bs (Tail b2)
--gCatC (GMany e bs (Tail b1))   (GUnit b2)        = GMany e (b1:bs) (Tail b2)
--gCatC (GMany e1 bs1 NoTail)    (GMany e2 bs2 x2) = GMany e1 (e2 : bs1 ++ bs2) x2
--gCatC (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2) = GMany e1 (x1 : e2 : bs1 ++ bs2) x2
--
--mkGMany :: Graph n e C -> Blocks n -> Exit (Graph n) x -> Graph n e x
--mkGMany e bs x = GMany b_e (bs_e ++ bs ++ bs_x) b_x
--  where
--     (b_e, bs_e) = mkHead e
--     (bs_x, b_x) = mkTail x
--
--mkHead :: Graph n e C -> (Block n e C, Blocks n)
--mkHead (GUnit b)             = (b, [])
--mkHead (GMany e bs NoTail)   = (e, bs)
--mkHead (GMany e bs (Tail b)) = (e, b:bs)
--
--mkTail :: Exit (Graph n) x -> (Blocks n, Exit (Block n) x)
--mkTail NoTail                = ([], NoTail)    
--mkTail (Tail (GUnit b))      = ([], Tail b)
--mkTail (Tail (GMany e bs x)) = (e:bs, x)
--
--flattenG :: Graph n C C -> Blocks n
--flattenG (GUnit b)             = [b]
--flattenG (GMany e bs NoTail)   = e:bs
--flattenG (GMany e bs (Tail x)) = e:x:bs
--
--forwardBlockList :: Blocks n -> Blocks n
---- 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 = blks
--
-------------------------------------------------------------------------------
----            DataflowLattice
-------------------------------------------------------------------------------
--
--data DataflowLattice a = DataflowLattice  { 
--  fact_name       :: String,                 -- Documentation
--  fact_bot        :: a,                      -- Lattice bottom element
--  fact_add_to     :: a -> a -> TxRes a,      -- Lattice join plus change flag
--  fact_do_logging :: Bool                    -- log changes
--}
--
--data ChangeFlag = NoChange | SomeChange
--data TxRes a = TxRes ChangeFlag a
--
-------------------------------------------------------------------------------
----            The main Hoopl API
-------------------------------------------------------------------------------
--
--type ForwardTransfers n f 
--  = forall e x. n e x -> InFact e f -> OutFact x f 
--
--type ForwardRewrites n f 
--  = forall e x. n e x -> InFact e f -> Maybe (AGraph n e x)
--
--type family   InFact e f :: *
--type instance InFact C f = InFactC f
--type instance InFact O f = f
--
--type family   OutFact x f :: *
--type instance OutFact C f = OutFactC f
--type instance OutFact O f = f
--
--type InFactC  fact = BlockId -> fact
--type OutFactC fact = [(BlockId, fact)] 
--
--data AGraph n e x = AGraph    -- Stub for now
--
--
-------------------------------------------------------------------------------
----      TxFactBase: a FactBase with ChangeFlag information
-------------------------------------------------------------------------------
--
---- The TxFactBase is an accumulating parameter, threaded through all
---- the analysis/transformation of each block in the g_blocks of a grpah.
---- It carries a ChangeFlag with it, and a set of BlockIds
---- to monitor. Updates to other BlockIds don't affect the ChangeFlag
--data TxFactBase n fact 
--  = TxFB { tfb_fbase :: BlockEnv fact
--
--         , tfb_cha   :: ChangeFlag
--         , tfb_bids  :: BlockSet   -- Update change flag iff these blocks change
--                                   -- These are BlockIds of the *original* 
--                                   -- (not transformed) blocks
--
--         , tfb_blks  :: Blocks n   -- Transformed blocks
--    }
--
--factBaseInFacts :: DataflowLattice f -> TxFactBase n f -> InFactC f
--factBaseInFacts lattice (TxFB { tfb_fbase = fbase }) 
--  = lookupBEnv lattice fbase
--
--factBaseOutFacts :: TxFactBase n f -> OutFactC f
--factBaseOutFacts (TxFB { tfb_fbase = fbase, tfb_bids = bids }) 
--  = [ (bid, f) | (bid, f) <- blockEnvList fbase
--               , not (bid `elemBlockSet` bids) ]
--  -- The successors of the Graph are the the BlockIds for which
--  -- we hvae facts, that are *not* in the blocks of the graph
--
--updateFact :: DataflowLattice f -> (BlockId, f)
--           -> TxFactBase n f -> TxFactBase n f
---- Update a TxFactBase, setting the change flag iff
----   a) the new fact adds information...
----   b) for a block in the BlockSet in the TxFactBase
--updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids})
--  | NoChange <- cha2        = tx_fb
--  | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange }
--  | otherwise               = tx_fb { tfb_fbase = new_fbase }
--  where
--    old_fact = lookupBEnv lat fbase bid
--    TxRes cha2 res_fact = fact_add_to lat old_fact new_fact
--    new_fbase = extendBEnv fbase bid res_fact
--
--updateFacts :: Edges n
--            => DataflowLattice f 
--            -> GFT_Block n f
--            -> Block n C C
--            -> Trans (TxFactBase n f) (TxFactBase n f)
--updateFacts lat (GFT block_trans) blk
--    tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids, tfb_blks = blks })
--  = do { (graph, out_facts) <- block_trans blk (lookupBEnv lat fbase)
--       ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids (blockId blk)
--                            , tfb_blks = flattenG graph ++ blks }
--       ; return (foldr (updateFact lat) tx_fb' out_facts) }
--
-------------------------------------------------------------------------------
----            The Trans arrow
-------------------------------------------------------------------------------
--
--type Trans a b = a -> FuelMonad b 
-- -- Transform a into b, with facts of type f
-- -- Deals with optimsation fuel and unique supply too
--  
--(>>>) :: Trans a b -> Trans b c -> Trans a c
---- Compose two dataflow transfers in sequence
--(dft1 >>> dft2) f = do { f1 <- dft1 f; f2 <- dft2 f1; return f2 }
--
--liftTrans :: (a->b) -> Trans a b
--liftTrans f x = return (f x)
--
--idTrans :: Trans a a
--idTrans x = return x
--
--fixpointTrans :: forall n f. 
--                 Trans (TxFactBase n f) (TxFactBase n f) 
--              -> Trans (OutFactC f)     (TxFactBase n f)
--fixpointTrans tx_fb_trans out_facts
--  = do { fuel <- getFuel  
--       ; loop fuel (mkBlockEnv out_facts) }
--  where
--    loop :: Fuel -> Trans (BlockEnv f) (TxFactBase n f)
--    loop fuel fbase 
--      = do { tx_fb <- tx_fb_trans (TxFB { tfb_fbase = fbase
--                                        , tfb_cha = NoChange
--                                        , tfb_blks = []
--                                        , tfb_bids = emptyBlockSet })
--           ; case tfb_cha tx_fb of
--               NoChange   -> return tx_fb
--               SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } }
--
-------------------------------------------------------------------------------
----            Transfer functions
-------------------------------------------------------------------------------
--
---- Keys to the castle: a generic transfer function for each shape
---- Here's the idea: we start with single-n transfer functions,
---- move to basic-block transfer functions (we have exactly four shapes),
---- then finally to graph transfer functions (which requires iteration).
--
--newtype GFT thing n f = GFT (GFTR thing n f)
--type GFTR thing n f = forall e x. thing e x -> Trans (InFact e f) (Graph n e x, OutFact x f)
--
--type GFT_Node  n f = GFT n         n f
--type GFT_Block n f = GFT (Block n) n f
--type GFT_Graph n f = GFT (Graph n) n f
-------------------------------------------------------------------------------
--
--gftNodeTransfer :: forall n f . ForwardTransfers n f -> GFT_Node n f
---- Lifts ForwardTransfers to GFT_Node; simple transfer only
--gftNodeTransfer base_trans = GFT node_trans
--    where 
--      node_trans :: GFTR n n f
--      node_trans node f = return (GUnit (BUnit node), base_trans node f)
--
--gftNodeRewrite :: forall n f.
--                  ForwardTransfers n f
--               -> ForwardRewrites n f
--               -> GFT_Graph n f
--               -> GFT_Node n f
---- Lifts (ForwardTransfers,ForwardRewrites) to GFT_Node; 
---- this time we do rewriting as well. 
---- The GFT_Graph parameters specifies what to do with the rewritten graph
--gftNodeRewrite transfers rewrites (GFT graph_trans) 
--  = GFT node_rewrite
--  where
--    node_trans :: GFTR n n f
--    node_trans node f = return (GUnit (BUnit node), transfers node f)
--
--    node_rewrite :: GFTR n n f
--    node_rewrite node f  
--       = case rewrites node f of
--                 Nothing -> node_trans node f
--                 Just g  -> do { out <- fuelExhausted
--                                  ; if out then 
--                              node_trans node f
--                                    else do { decrementFuel
--                                            ; g' <- graphOfAGraph g
--                                            ; graph_trans g' f } }
--
--gftBlock :: forall n f. GFT_Node n f -> GFT_Block n f
---- Lift from nodes to blocks
--gftBlock (GFT node_trans) = GFT block_trans
--  where 
--    block_trans :: GFTR (Block n) n f
--    block_trans (BUnit node)   f = node_trans node f
--    block_trans (BCat hd mids) f = do { (g1,f1) <- block_trans hd f
--                                      ; (g2,f2) <- block_trans mids f1
--                                    ; return (g1 `gCat` g2, f2) }
--
--
--gftGraph :: forall n f. Edges n => DataflowLattice f -> GFT_Block n f -> GFT_Graph n f
---- Lift from blocks to graphs
--gftGraph lattice gft_block@(GFT block_trans) = GFT graph_trans
--  where
--    graph_trans :: GFTR (Graph n) n f
--    graph_trans GNil        f = return (GNil, f)
--    graph_trans (GUnit blk) f = block_trans blk f
--    graph_trans (GMany entry blocks exit) f
--      = do { (entry', f1)  <- block_trans entry f
--           ; tx_fb         <- ft_blocks blocks f1
--           ; (exit', f3)   <- ft_exit exit tx_fb 
--           ; return (mkGMany entry' (tfb_blks tx_fb) exit', f3) }
--
--      -- It's a bit disgusting that the TxFactBase has to be
--        -- preserved as far as the Exit block, becaues the TxFactBase
--        -- is really concerned with the fixpoint calculation
--        -- But I can't see any other tidy way to compute the 
--        -- LastOutFacts in the NoTail case
--    ft_exit :: Exit (Block n) x  -> Trans (TxFactBase n f) (Exit (Graph n) x, OutFact x f)
--    ft_exit (Tail blk) f = do { (blk', f1) <- block_trans blk (factBaseInFacts lattice f)
--                              ; return (Tail blk', f1) }
--    ft_exit NoTail     f = return (NoTail, factBaseOutFacts f)
--
--    ft_block_once :: Block n C C -> Trans (TxFactBase n f) (TxFactBase n f)
--    ft_block_once blk = updateFacts lattice gft_block blk
--
--    ft_blocks_once :: Blocks n -> Trans (TxFactBase n f) (TxFactBase n f)
--    ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks
--
--    ft_blocks :: [Block n C C] -> Trans (OutFactC f) (TxFactBase n f)
--    ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks))
--
------------------------------------------------------------------
----       The pièce de resistance: cunning transfer functions
------------------------------------------------------------------
--
--pureAnalysis :: Edges n => DataflowLattice f -> ForwardTransfers n f -> GFT_Graph n f
--pureAnalysis lattice = gftGraph lattice . gftBlock . gftNodeTransfer
--
--analyseAndRewrite
--   :: forall n f. Edges n
--   => RewritingDepth
--   -> DataflowLattice f
--   -> ForwardTransfers n f
--   -> ForwardRewrites n f
--   -> GFT_Graph n f
--
--data RewritingDepth = RewriteShallow | RewriteDeep
---- When a transformation proposes to rewrite a node, 
---- you can either ask the system to
----  * "shallow": accept the new graph, analyse it without further rewriting
----  * "deep": recursively analyse-and-rewrite the new graph
--
--analyseAndRewrite depth lattice transfers rewrites
--  = gft_graph_cunning
--  where 
--    gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph n f
--
--    gft_graph_base    = gftGraph lattice (gftBlock gft_node_base)
--    gft_graph_cunning = gftGraph lattice (gftBlock gft_node_cunning)
--    gft_graph_recurse = case depth of
--                          RewriteShallow -> gft_graph_base
--                          RewriteDeep    -> gft_graph_cunning
--
--    gft_node_base, gft_node_cunning :: GFT_Node n f
--    gft_node_base    = gftNodeTransfer transfers
--    gft_node_cunning = gftNodeRewrite  transfers rewrites gft_graph_recurse
--
-------------------------------------------------------------------------------
----            The fuel monad
-------------------------------------------------------------------------------
--
--type Uniques = Int
--type Fuel    = Int
--
--newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }
--
--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')
--
--fuelExhausted :: FuelMonad Bool
--fuelExhausted = FM (\f u -> (f <= 0, f, u))
--
--decrementFuel :: FuelMonad ()
--decrementFuel = FM (\f u -> ((), f-1, u))
--
--getFuel :: FuelMonad Fuel
--getFuel = FM (\f u -> (f,f,u))
--
--setFuel :: Fuel -> FuelMonad ()
--setFuel f = FM (\_ u -> ((), f, u))
--
--graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
--graphOfAGraph = error "urk"   -- Stub
--
-------------------------------------------------------------------------------
----            BlockId, BlockEnv, BlockSet
-------------------------------------------------------------------------------
--
--type BlockId = Int
--
--mkBlockId :: Int -> BlockId
--mkBlockId uniq = uniq
--
--type BlockEnv a = M.IntMap a
--
--mkBlockEnv :: [(BlockId, a)] -> BlockEnv a
--mkBlockEnv prs = M.fromList prs
--
--lookupBEnv :: DataflowLattice f -> BlockEnv f -> BlockId -> f
--lookupBEnv lattice env blk_id 
--  = case M.lookup blk_id env of
--      Just f  -> f
--      Nothing -> fact_bot lattice
--
--findBEnv :: BlockEnv a -> BlockId -> Maybe a
--findBEnv env blk_id = M.lookup blk_id env
--
--extendBEnv :: BlockEnv f -> BlockId -> f -> BlockEnv f
--extendBEnv env blk_id f = M.insert blk_id f env
--
--blockEnvList :: BlockEnv f -> [(BlockId, f)]
--blockEnvList env = M.toList env
--
--type BlockSet = S.IntSet
--
--emptyBlockSet :: BlockSet
--emptyBlockSet = S.empty
--
--extendBlockSet :: BlockSet -> BlockId -> BlockSet
--extendBlockSet bids bid = S.insert bid bids
--
--elemBlockSet :: BlockId -> BlockSet -> Bool
--elemBlockSet bid bids = S.member bid bids
--
--blockSetElems :: BlockSet -> [BlockId]
--blockSetElems = S.toList
--
--minusBlockSet :: BlockSet -> BlockSet -> BlockSet
--minusBlockSet = S.difference
--
--mkBlockSet :: [BlockId] -> BlockSet
--mkBlockSet = S.fromList
diff --cc testing/Eval.hs
@@@ -27,31 -28,34 +27,31 @@@ evalProc' (Proc {name=_, args, body, en
    else throwError $ "Param/actual mismatch: " ++ show args ++ " = " ++ show actuals
  
  -- Responsible for allocating and deallocating its own stack frame.
- evalBody :: EvalTarget v => VarEnv v -> Body Node -> Label -> EvalM v [v]
 -evalG :: EvalTarget v => VarEnv v -> Graph Node C C -> BlockId -> EvalM v [v]
 -evalG vars (GMany b bs NoTail) entry =
 -  do ress <- inNewFrame vars (b : map snd (IM.toList bs)) $ get_block entry >>= evalB 
++evalBody :: EvalTarget v => VarEnv v -> Body Insn -> Label -> EvalM v [v]
 +evalBody vars bs entry =
 +  inNewFrame vars (map snd (bodyList bs)) $ get_block entry >>= evalB 
  
 -     return ress
 --- GADT checker can't see that preceding pattern is exhaustive.
 -
--evalB    :: EvalTarget v => Block Node C C -> EvalM v [v]
++evalB    :: EvalTarget v => Block Insn C C -> EvalM v [v]
  evalB    (BCat b1 b2) = evalB_CO b1 >> evalB_OC b2
--evalB    (BUnit _)    = gadtCheck "CC nodes"
++evalB    (BUnit _)    = gadtCheck "CC Insns"
  
--evalB_CO :: EvalTarget v => Block Node C O -> EvalM v ()
++evalB_CO :: EvalTarget v => Block Insn C O -> EvalM v ()
  evalB_CO (BCat b1 b2) = evalB_CO b1 >> evalB_OO b2
  evalB_CO (BUnit n)    = evalN_CO n
  
--evalB_OO :: EvalTarget v => Block Node O O -> EvalM v ()
++evalB_OO :: EvalTarget v => Block Insn O O -> EvalM v ()
  evalB_OO (BCat b1 b2) = evalB_OO b1 >> evalB_OO b2
  evalB_OO (BUnit n)    = evalN_OO n
  
--evalB_OC :: EvalTarget v => Block Node O C -> EvalM v [v]
++evalB_OC :: EvalTarget v => Block Insn O C -> EvalM v [v]
  evalB_OC (BCat b1 b2) = evalB_OO b1 >> evalB_OC b2
  evalB_OC (BUnit n)    = evalN_OC n
  
  
--evalN_CO :: EvalTarget v => Node C O -> EvalM v ()
++evalN_CO :: EvalTarget v => Insn C O -> EvalM v ()
  evalN_CO (Label _) = return ()
  
--evalN_OO :: EvalTarget v => Node O O -> EvalM v ()
++evalN_OO :: EvalTarget v => Insn O O -> EvalM v ()
  evalN_OO (Assign var e) =
    do v_e <- eval e
       set_var var v_e
@@@ -61,7 -65,7 +61,7 @@@ evalN_OO (Store addr e) 
       -- StoreEvt recorded in set_heap
       set_heap v_addr v_e
  
--evalN_OC :: EvalTarget v => Node O C -> EvalM v [v]
++evalN_OC :: EvalTarget v => Insn O C -> EvalM v [v]
  evalN_OC (Branch bid) =
    do b <- get_block bid
       evalB b
@@@ -37,8 -37,8 +37,8 @@@ instance MonadError String (EvalM v) wh
  type VarEnv  v = M.Map Var  v
  type HeapEnv v = M.Map Addr v -- word addressed heap
  type Addr      = Integer
 -type BEnv      = BlockEnv B
 -type B         = Block Node C C
 +type BEnv      = FactBase B
- type B         = Block Node C C
++type B         = Block Insn C C
  type PEnv      = M.Map String Proc
  
  runProg :: [Proc] -> [v] -> EvalM v x -> ErrorM (State v, x)
diff --cc testing/Hoopl.hs
index 84a4221,84a4221..0000000
deleted file mode 100644,100644
+++ /dev/null
@@@ -1,590 -1,590 +1,0 @@@
--{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-}
--
--module Hoopl (BlockId, O, C, Block (..), Graph (..), Tail (..), AGraph,
--              TailFactF (..), TailFactB (..),
--              BlockGraph, BlockMap,
--              BlockEnv, findBEnv, mkBlockEnv, lookupFact, ChangeFlag (..),
--              analyseAndRewriteFwd, analyseAndRewriteBwd, RewritingDepth (..), mkFactBase, agraphOfNode, runFuelMonad,
--              DataflowLattice (..), ForwardTransfers, ForwardRewrites,
--              BackwardTransfers, BackwardRewrites) where
--
--import qualified Data.IntMap as M
--import qualified Data.IntSet as S
--
-------------------------------------------------------------------------------
----            Graphs
-------------------------------------------------------------------------------
--
--data ZOpen
--data ZClosed
--
--type O = ZOpen
--type C = ZClosed
--
---- 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
--
--type BlockGraph n = BlockMap (Block n C C)
--
--data Graph n e x where
--  GNil  :: Graph n O O
--  GUnit :: Block n e O -> Graph n e O
--  GMany :: Block n e C -> BlockGraph n -> Tail n x -> Graph n e x
--
--   -- If a graph has a Tail, then that tail is the only  
--   -- exit from the graph, even if the Tail is closed
--   -- See the definition of successors!
--
--data Tail n x where
--  NoTail :: Tail n C
--  Tail   :: BlockId -> Block n C O -> Tail n O
--
--class LiftNode x where
--   liftNode :: n e x -> Graph n e x
--instance LiftNode ZClosed where
--   liftNode n = GMany (BUnit n) noBlocks NoTail
--instance LiftNode ZOpen where
--   liftNode n = GUnit (BUnit n)
--
--{-    Edges is not currently used
--class Edges thing where
--  successors :: thing e C -> [BlockId]
--
--instance Edges n => Edges (Block n) where
--  successors (BUnit n)  = successors n
--  successors (BCat _ b) = successors b
--
--instance Edges n => Edges (Graph n) where
--  successors (GMany b bs NoTail) 
--     = blockSetElems (all_succs `minusBlockSet` all_blk_ids)
--     where 
--       (bids, blks) = unzip (blocksToList bs)      
--       all_succs   = mkBlockSet (successors b ++ [bid | b <- blks, bid <- successors b])
--       all_blk_ids = mkBlockSet bids
---}
--
--ecGraph :: Graph n e C -> (Block n e C, BlockGraph n)
--ecGraph (GMany b bs NoTail) = (b, bs)
--
--cxGraph :: BlockId -> Graph n C O -> (BlockGraph n, Tail n O)
--cxGraph bid (GUnit b)          = (noBlocks, Tail bid b)
--cxGraph bid (GMany be bs tail) = (addBlock bid be bs, tail)
--
--flattenG :: BlockId -> Graph n C C -> BlockGraph n
--flattenG bid (GMany e bs NoTail) = addBlock bid e bs
--
--gCat :: Graph n e O -> Graph n O x -> Graph n e x
--gCat GNil g2 = g2
--gCat g1 GNil = g1
--
--gCat (GUnit b1) (GUnit b2)             
--  = GUnit (b1 `BCat` b2)
--
--gCat (GUnit b) (GMany e bs x) 
--  = GMany (b `BCat` e) bs x
--
--gCat (GMany e bs (Tail bid x)) (GUnit b2) 
--   = GMany e bs (Tail bid (x `BCat` b2))
--
--gCat (GMany e1 bs1 (Tail bid x1)) (GMany e2 bs2 x2)
--   = GMany e1 (addBlock bid (x1 `BCat` e2) bs1 `unionBlocks` bs2) x2
--
--forwardBlockList, backwardBlockList :: BlockGraph n -> [(BlockId,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 = blocksToList blks
--backwardBlockList blks = blocksToList blks
--
-------------------------------------------------------------------------------
----            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
--
-------------------------------------------------------------------------------
----            The main Hoopl API
-------------------------------------------------------------------------------
--
--type ForwardTransfers n f 
--  = forall e x. f -> n e x -> TailFactF x f 
--
--type ForwardRewrites n f 
--  = forall e x. f -> n e x -> Maybe (AGraph n e x)
--
--type family   TailFactF x f :: *
--type instance TailFactF C f = [(BlockId, f)] 
--type instance TailFactF O f = f
--
--type AGraph n e x = FuelMonad (Graph n e x)
--
--
-------------------------------------------------------------------------------
----      TxFactBase: a FactBase with ChangeFlag information
-------------------------------------------------------------------------------
--
---- The TxFactBase is an accumulating parameter, threaded through all
---- the analysis/transformation of each block in the g_blocks of a grpah.
---- It carries a ChangeFlag with it, and a set of BlockIds
---- to monitor. Updates to other BlockIds don't affect the ChangeFlag
--data TxFactBase n fact 
--  = TxFB { tfb_fbase :: FactBase fact
--
--         , tfb_cha   :: ChangeFlag
--         , tfb_bids  :: BlockSet   -- Update change flag iff these blocks change
--                                   -- These are BlockIds of the *original* 
--                                   -- (not transformed) blocks
--
--         , tfb_blks  :: BlockGraph n   -- Transformed blocks
--    }
--
--factBaseInFacts :: DataflowLattice f -> TxFactBase n f -> BlockId -> f
--factBaseInFacts lattice (TxFB { tfb_fbase = fbase }) bid
--  = lookupFact lattice fbase bid
--
--factBaseOutFacts :: TxFactBase n f -> [(BlockId,f)]
--factBaseOutFacts (TxFB { tfb_fbase = fbase, tfb_bids = bids }) 
--  = [ (bid, f) | (bid, f) <- factBaseList fbase
--               , not (bid `elemBlockSet` bids) ]
--  -- The successors of the Graph are the the BlockIds for which
--  -- we hvae facts, that are *not* in the blocks of the graph
--
--updateFact :: DataflowLattice f -> (BlockId, f)
--           -> TxFactBase n f -> TxFactBase n f
---- Update a TxFactBase, setting the change flag iff
----   a) the new fact adds information...
----   b) for a block in the BlockSet in the TxFactBase
--updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids})
--  | NoChange <- cha2        = tx_fb
--  | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange }
--  | otherwise               = tx_fb { tfb_fbase = new_fbase }
--  where
--    old_fact = lookupFact lat fbase bid
--    (cha2, res_fact) = fact_extend lat new_fact old_fact
--    new_fbase = extendFactBase fbase bid res_fact
--
--updateFacts :: DataflowLattice f 
--          -> BlockId
--            -> (FactBase f -> FuelMonad ([(BlockId,f)], Graph n C C))
--            -> TxFactBase n f -> FuelMonad (TxFactBase n f)
---- Works regardless of direction
--updateFacts lat bid fb_trans
--    tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids, tfb_blks = blks })
--  = do { (out_facts, graph) <- fb_trans fbase
--       ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids bid
--                            , tfb_blks = flattenG bid graph `unionBlocks` blks }
--       ; return (foldr (updateFact lat) tx_fb' out_facts) }
--
-------------------------------------------------------------------------------
----            The Trans arrow
-------------------------------------------------------------------------------
--
--fixpoint :: forall n f. 
--                 (TxFactBase n f -> FuelMonad (TxFactBase n f))
--              -> (FactBase f     -> FuelMonad (TxFactBase n f))
--fixpoint tx_fb_trans init_fbase
--  = do { fuel <- getFuel  
--       ; loop fuel init_fbase }
--  where
--    loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f)
--    loop fuel fbase 
--      = do { tx_fb <- tx_fb_trans (TxFB { tfb_fbase = fbase
--                                        , tfb_cha = NoChange
--                                        , tfb_blks = noBlocks
--                                        , tfb_bids = emptyBlockSet })
--           ; case tfb_cha tx_fb of
--               NoChange   -> return tx_fb
--               SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } }
--
-------------------------------------------------------------------------------
----            Transfer functions
-------------------------------------------------------------------------------
--
---- Keys to the castle: a generic transfer function for each shape
---- Here's the idea: we start with single-n transfer functions,
---- move to basic-block transfer functions (we have exactly four shapes),
---- then finally to graph transfer functions (which requires iteration).
--
--type ARF thing n f = forall e x. LiftNode x 
--                              => f -> thing e x
--                              -> FuelMonad (TailFactF x f, Graph n e x)
--
--type ARF_Node  n f = ARF n         n f
--type ARF_Block n f = ARF (Block n) n f
--type ARF_Graph n f = ARF (Graph n) n f
-------------------------------------------------------------------------------
--
--arfNodeTransfer :: forall n f. ForwardTransfers n f -> ARF_Node n f
---- Lifts ForwardTransfers to ARF_Node; simple transfer only
--arfNodeTransfer transfer_fn f node
--  = return (transfer_fn f node, liftNode node)
--
--arfNodeRewrite :: forall n f.
--                  ForwardTransfers n f
--               -> ForwardRewrites n f
--               -> ARF_Graph n f
--               -> ARF_Node n f
---- Lifts (ForwardTransfers,ForwardRewrites) to ARF_Node; 
---- this time we do rewriting as well. 
---- The ARF_Graph parameters specifies what to do with the rewritten graph
--arfNodeRewrite transfer_fn rewrite_fn graph_trans f node
--  = do { mb_g <- withFuel (rewrite_fn f node)
--       ; case mb_g of
--           Nothing -> arfNodeTransfer transfer_fn f node
--                 Just ag -> do { g <- graphOfAGraph ag
--                               ; graph_trans f g } }
--
--arfBlock :: forall n f. ARF_Node n f -> ARF_Block n f
---- Lift from nodes to blocks
--arfBlock arf_node f (BUnit node)   = arf_node f node
--arfBlock arf_node f (BCat hd mids) = do { (f1,g1) <- arfBlock arf_node f  hd
--                                        ; (f2,g2) <- arfBlock arf_node f1 mids
--                                      ; return (f2, g1 `gCat` g2) }
--
--arfGraph :: forall n f. DataflowLattice f -> ARF_Block n f -> ARF_Graph n f
---- Lift from blocks to graphs
--arfGraph lattice arf_block f GNil        = return (f, GNil)
--arfGraph lattice arf_block f (GUnit blk) = arf_block f blk
--arfGraph lattice arf_block f (GMany entry blocks exit)
--  = do { (f1, entry_g)     <- arf_block f entry
--       ; tx_fb             <- ft_blocks blocks (mkFactBase f1)
--       ; (f3, bs2, exit')  <- ft_exit tx_fb exit 
--       ; let (entry', bs1) = ecGraph entry_g
--             final_bs = bs1 `unionBlocks` tfb_blks tx_fb `unionBlocks` bs2
--       ; return (f3, GMany entry' final_bs exit') }
--  where
--      -- It's a bit disgusting that the TxFactBase has to be
--        -- preserved as far as the Tail block, becaues the TxFactBase
--        -- is really concerned with the fixpoint calculation
--        -- But I can't see any other tidy way to compute the 
--        -- LastOutFacts in the NoTail case
--    ft_exit :: TxFactBase n f -> Tail n x
--            -> FuelMonad (TailFactF x f, BlockGraph n, Tail n x)
--    ft_exit f (Tail bid blk)
--      = do { (f1, g) <- arf_block (factBaseInFacts lattice f bid) blk
--         ; let (bs, exit) = cxGraph bid g
--           ; return (f1, bs, exit) }
--    ft_exit f NoTail
--      = return (factBaseOutFacts f, noBlocks, NoTail)
--
--    ft_block_once :: (BlockId, Block n C C) -> TxFactBase n f
--                  -> FuelMonad (TxFactBase n f)
--    ft_block_once (bid, b) = updateFacts lattice bid $ \fbase ->
--                             arf_block (lookupFact lattice fbase bid) b
--
--    ft_blocks_once :: [(BlockId, Block n C C)] 
--                   -> TxFactBase n f -> FuelMonad (TxFactBase n f)
--    ft_blocks_once []     tx_fb = return tx_fb
--    ft_blocks_once (b:bs) tx_fb = do { tx_fb1 <- ft_block_once b tx_fb
--                                     ; ft_blocks_once bs tx_fb1 }
--
--    ft_blocks :: BlockGraph n -> FactBase f -> FuelMonad (TxFactBase n f)
--    ft_blocks blocks = fixpoint (ft_blocks_once (forwardBlockList blocks))
--
------------------------------------------------------------------
----       The pièce de resistance: cunning transfer functions
------------------------------------------------------------------
--
--pureAnalysis :: DataflowLattice f -> ForwardTransfers n f -> ARF_Graph n f
--pureAnalysis lattice f = arfGraph lattice (arfBlock (arfNodeTransfer f))
--
--analyseAndRewriteFwd
--   :: forall n f. 
--      DataflowLattice f
--   -> ForwardTransfers n f
--   -> ForwardRewrites n f
--   -> RewritingDepth
--   -> ARF_Graph n f
--
--data RewritingDepth = RewriteShallow | RewriteDeep
---- When a transformation proposes to rewrite a node, 
---- you can either ask the system to
----  * "shallow": accept the new graph, analyse it without further rewriting
----  * "deep": recursively analyse-and-rewrite the new graph
--
--analyseAndRewriteFwd lattice transfers rewrites depth
--  = anal_rewrite
--  where 
--    anal_rewrite, anal_only, arf_rec :: ARF_Graph n f
--
--    anal_rewrite = arfGraph lattice $ arfBlock $ 
--                   arfNodeRewrite transfers rewrites arf_rec
--
--    anal_only    = arfGraph lattice $ arfBlock $ 
--                   arfNodeTransfer transfers
--
--    arf_rec = case depth of
--                RewriteShallow -> anal_only
--                RewriteDeep    -> anal_rewrite
--
-------------------------------------------------------------------------------
----            Backward rewriting
-------------------------------------------------------------------------------
--
--type BackwardTransfers n f 
--  = forall e x. TailFactB x f -> n e x -> f 
--type BackwardRewrites n f 
--  = forall e x. TailFactB x f -> n e x -> Maybe (AGraph n e x)
--
--type ARB thing n f = forall e x. LiftNode x 
--                              => TailFactB x f -> thing e x
--                              -> FuelMonad (f, Graph n e x)
--
--type family   TailFactB x f :: *
--type instance TailFactB C f = FactBase f
--type instance TailFactB O f = f
--
--type ARB_Node  n f = ARB n         n f
--type ARB_Block n f = ARB (Block n) n f
--type ARB_Graph n f = ARB (Graph n) n f
--
--arbNodeTransfer :: forall n f . BackwardTransfers n f -> ARB_Node n f
---- Lifts BackwardTransfers to ARB_Node; simple transfer only
--arbNodeTransfer transfer_fn f node
--  = return (transfer_fn f node, liftNode node)
--
--arbNodeRewrite :: forall n f.
--                  BackwardTransfers n f
--               -> BackwardRewrites n f
--               -> ARB_Graph n f
--               -> ARB_Node n f
---- Lifts (BackwardTransfers,BackwardRewrites) to ARB_Node; 
---- this time we do rewriting as well. 
---- The ARB_Graph parameters specifies what to do with the rewritten graph
--arbNodeRewrite transfer_fn rewrite_fn graph_trans f node
--  = do { mb_g <- withFuel (rewrite_fn f node)
--       ; case mb_g of
--           Nothing -> arbNodeTransfer transfer_fn f node
--                 Just ag -> do { g <- graphOfAGraph ag
--                               ; graph_trans f g } }
--
--arbBlock :: forall n f. ARB_Node n f -> ARB_Block n f
---- Lift from nodes to blocks
--arbBlock arb_node f (BUnit node) = arb_node f node
--arbBlock arb_node f (BCat b1 b2) = do { (f2,g2) <- arbBlock arb_node f  b2
--                                      ; (f1,g1) <- arbBlock arb_node f2 b1
--                                    ; return (f1, g1 `gCat` g2) }
--
--arbGraph :: forall n f. DataflowLattice f -> ARB_Block n f -> ARB_Graph n f
--arbGraph lattice arb_block f GNil        = return (f, GNil)
--arbGraph lattice arb_block f (GUnit blk) = arb_block f blk
--arbGraph lattice arb_block f (GMany entry blocks exit)
--  = do { (f1, bs2, exit')  <- bt_exit f exit
--       ; tx_fb             <- bt_blocks blocks f1
--       ; (f3, entry_g)     <- arb_block (tfb_fbase tx_fb) entry 
--       ; let (entry', bs1) = ecGraph entry_g
--             final_bs = bs1 `unionBlocks` tfb_blks tx_fb `unionBlocks` bs2
--       ; return (f3, GMany entry' final_bs exit') }
--  where
--      -- It's a bit disgusting that the TxFactBase has to be
--        -- preserved as far as the Tail block, becaues the TxFactBase
--        -- is really concerned with the fixpoint calculation
--        -- But I can't see any other tidy way to compute the 
--        -- LastOutFacts in the NoTail case
--    bt_exit :: TailFactB x f -> Tail n x
--            -> FuelMonad (FactBase f, BlockGraph n, Tail n x)
--    bt_exit f (Tail bid blk)
--      = do { (f1, g) <- arb_block f blk
--         ; let (bs, exit) = cxGraph bid g
--           ; return (mkFactBase [(bid,f1)], bs, exit) }
--    bt_exit f NoTail
--      = return (f, noBlocks, NoTail)
--
--    bt_block_once :: (BlockId, Block n C C) -> TxFactBase n f
--                  -> FuelMonad (TxFactBase n f)
--    bt_block_once (bid, b) = updateFacts lattice bid $ \fbase ->
--                             do { (f, g) <- arb_block fbase b
--                                ; return ([(bid,f)], g) }
--
--    bt_blocks_once :: [(BlockId,Block n C C)] 
--                   -> TxFactBase n f -> FuelMonad (TxFactBase n f)
--    bt_blocks_once []     tx_fb = return tx_fb
--    bt_blocks_once (b:bs) tx_fb = do { tx_fb' <- bt_block_once b tx_fb
--                                     ; bt_blocks_once bs tx_fb' }
--
--    bt_blocks :: BlockGraph n -> FactBase f -> FuelMonad (TxFactBase n f)
--    bt_blocks blocks = fixpoint (bt_blocks_once (backwardBlockList blocks))
--
--analyseAndRewriteBwd
--   :: forall n f. 
--      DataflowLattice f
--   -> BackwardTransfers n f
--   -> BackwardRewrites n f
--   -> RewritingDepth
--   -> ARB_Graph n f
--
--analyseAndRewriteBwd lattice transfers rewrites depth
--  = anal_rewrite
--  where 
--    anal_rewrite, anal_only, arb_rec :: ARB_Graph n f
--
--    anal_rewrite = arbGraph lattice $ arbBlock $ 
--                   arbNodeRewrite transfers rewrites arb_rec
--
--    anal_only    = arbGraph lattice $ arbBlock $ 
--                   arbNodeTransfer transfers
--
--    arb_rec = case depth of
--                RewriteShallow -> anal_only
--                RewriteDeep    -> anal_rewrite
--
--
-------------------------------------------------------------------------------
----            The fuel monad
-------------------------------------------------------------------------------
--
--type Uniques = Int
--type Fuel    = Int
--
--newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) }
--
--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')
--
--runFuelMonad :: FuelMonad a -> Fuel -> Uniques -> a
--runFuelMonad fm fuel uniqs = a
--  where (a, _, _) = unFM fm fuel uniqs
--
--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))
--
--graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x)
--graphOfAGraph a = a
--
---- Expedient, but not what we really want:
--agraphOfNode :: LiftNode x => n e x -> AGraph n e x
--agraphOfNode = return . liftNode
--
-------------------------------------------------------------------------------
----            BlockId, FactBase, BlockSet
-------------------------------------------------------------------------------
--
--type BlockId = Int
--
--mkBlockId :: Int -> BlockId
--mkBlockId uniq = uniq
--
------------------------
--type BlockMap a = M.IntMap a
--
--noBlocks :: BlockGraph n
--noBlocks = M.empty
--
--addBlock :: BlockId -> Block n C C -> BlockGraph n -> BlockGraph n
--addBlock = M.insert
--
--unionBlocks :: BlockGraph n -> BlockGraph n -> BlockGraph n
--unionBlocks = M.union
--
--blocksToList :: BlockGraph n -> [(BlockId,Block n C C)]
--blocksToList = M.toList
--
------------------------
--type FactBase a = M.IntMap a
--type BlockEnv a = FactBase a
--
--mkBlockEnv, mkFactBase :: [(BlockId, f)] -> FactBase f
--mkFactBase prs = M.fromList prs
--mkBlockEnv = mkFactBase
--
--lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f
--lookupFact lattice env blk_id 
--  = case M.lookup blk_id env of
--      Just f  -> f
--      Nothing -> fact_bot lattice
--
--findBEnv :: BlockEnv a -> BlockId -> Maybe a
--findBEnv env blk_id = M.lookup blk_id env
--
--
--extendFactBase :: FactBase f -> BlockId -> f -> FactBase f
--extendFactBase env blk_id f = M.insert blk_id f env
--
--unionFactBase :: FactBase f -> FactBase f -> FactBase f
--unionFactBase = M.union
--
--factBaseList :: FactBase f -> [(BlockId, f)]
--factBaseList env = M.toList env
--
--
------------------------
--type BlockSet = S.IntSet
--
--emptyBlockSet :: BlockSet
--emptyBlockSet = S.empty
--
--extendBlockSet :: BlockSet -> BlockId -> BlockSet
--extendBlockSet bids bid = S.insert bid bids
--
--elemBlockSet :: BlockId -> BlockSet -> Bool
--elemBlockSet bid bids = S.member bid bids
--
--blockSetElems :: BlockSet -> [BlockId]
--blockSetElems = S.toList
--
--minusBlockSet :: BlockSet -> BlockSet -> BlockSet
--minusBlockSet = S.difference
--
--mkBlockSet :: [BlockId] -> BlockSet
--mkBlockSet = S.fromList
--
------------------------
--
--{-
--data Reachable f = Reachable f
--                 | Unreachable
--instance Monad Reachable where
--  return = Reachable
--  Unreachable >>= _ = Unreachable
--  Reachable a >>= k = k a
--
--reachable :: (DataflowLattice f, ForwardTransfers n f, ForwardRewrites n f)
--          -> (DataflowLattice (Reachable f), ForwardTransfers n (Reachable f),
--                                             ForwardRewrites  n (Reachable f))
--reachable (lattice, transfer, rewrite) = (lat, tr, rew)
--  where lat = DataflowLattice (fact_name lattice) Unreachable add
--                              (fact_do_logging lattice)
--        add Unreachable a = (NoChange,  a)
--        add a Unreachable = (SomeChange, a)
--        add (Reachable new) (Reachable old) =
--            fmap Reachable $ fact_extend lattice new old
--
--        tr f n = transfer f n
--        tx_first id = liftM $ ft_first_out transfers id
--        tx_middle m = liftM $ ft_middle_out transfers m
--        tx_last l in' = -- there must be a cleaner way to do this
--           case in' of Reachable a -> lift_last_outs $ ft_last_outs transfers l a
--                       Unreachable -> LastOutFacts []
--
--        rew = ForwardRewrites rew_first rew_middle rew_last rew_exit
--        rew_first  = rewrite . fr_first  rewrites 
--        rew_middle = rewrite . fr_middle rewrites 
--        rew_last   = rewrite . fr_last   rewrites
--        rew_exit   = rewrite $ fr_exit   rewrites
--                                                    
--
--lift_last_outs :: LastOutFacts a -> LastOutFacts (Reachable a)
--lift_last_outs (LastOutFacts l) = LastOutFacts [ (id, Reachable a) | (id, a) <- l ]
--
--rewrite :: (a -> Maybe b) -> (Reachable a -> Maybe b)
--rewrite _ Unreachable = Nothing
--rewrite f (Reachable a) = f a
---}
diff --cc testing/IR.hs
@@@ -1,11 -1,13 +1,11 @@@
  {-# OPTIONS_GHC -Wall #-}
  {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-}
--module IR (Proc (..), Node (..), Exp (..), Lit (..), Value (..), BinOp(..), Var,
 -           showProc) where
++module IR (Proc (..), Insn (..), Exp (..), Lit (..), Value (..), BinOp(..), Var,
 +           showG, showProc) where
  
 -import qualified Data.IntMap as M
 -import Data.Maybe
  import Prelude hiding (succ)
  
 -import Hoopl
 +import Compiler.Hoopl
  
  data Exp = Lit   Lit
           | Var   Var
@@@ -16,58 -18,72 +16,58 @@@ type Var   = Strin
  data Lit   = Bool Bool | Int Integer deriving Eq
  data Value = B Bool    | I   Integer deriving Eq
  
- data Proc = Proc { name :: String, args :: [Var], entry :: Label, body :: Body Node }
 -data Proc = Proc { name :: String, args :: [Var], entry :: BlockId, body :: Graph Node C C }
++data Proc = Proc { name :: String, args :: [Var], entry :: Label, body :: Body Insn }
  
--data Node e x where
-   Label  :: Label ->                                Node C O
-   Assign :: Var     -> Exp     ->                   Node O O
-   Store  :: Exp     -> Exp     ->                   Node O O
-   Branch :: Label   ->                              Node O C
-   Cond   :: Exp     -> Label   -> Label ->          Node O C
-   Call   :: [Var]   -> String  -> [Exp] -> Label -> Node O C -- String is bogus
-   Return :: [Exp]   ->                              Node O C
 -  Label  :: BlockId ->                                  Node C O
 -  Assign :: Var     -> Exp     ->                       Node O O
 -  Store  :: Exp     -> Exp     ->                       Node O O
 -  Branch :: BlockId ->                                  Node O C
 -  Cond   :: Exp     -> BlockId -> BlockId ->            Node O C
 -  Call   :: [Var]   -> String  -> [Exp]   -> BlockId -> Node O C -- String is bogus
 -  Return :: [Exp]   ->                                  Node O C
++data Insn e x where
++  Label  :: Label ->                                Insn C O
++  Assign :: Var     -> Exp     ->                   Insn O O
++  Store  :: Exp     -> Exp     ->                   Insn O O
++  Branch :: Label   ->                              Insn O C
++  Cond   :: Exp     -> Label   -> Label ->          Insn O C
++  Call   :: [Var]   -> String  -> [Exp] -> Label -> Insn O C -- String is bogus
++  Return :: [Exp]   ->                              Insn O C
 +
- instance Edges Node where
++instance Edges Insn where
 +  entryLabel (Label l)      = l
 +  successors (Branch l)     = [l]
 +  successors (Cond _ t f)   = [t, f]
 +  successors (Call _ _ _ l) = [l]
 +  successors (Return _)     = []
  
  -- Prettyprinting
  
  showProc :: Proc -> String
  showProc proc = name proc ++ tuple (args proc) ++ graph
    where
 -    graph  = " {\n" ++ showG showBID (body proc) ++ "}\n"
 -    -- Get all the block IDs and map them to distinct integers
 -    showBID = show . fromJust . (findBEnv $ mkBlockEnv $ zip bids nats)
 -    nats = [1..] :: [Integer]
 -    bids = foldG getBID (body proc) []
 -    getBID :: forall e' x'.  Node e' x' -> [BlockId] -> [BlockId]
 -    getBID (Label bid)  rst = bid   : rst
 -    getBID (Branch bid) rst = bid   : rst
 -    getBID (Cond _ t f) rst = t : f : rst
 -    getBID _            rst = rst
 -
 -foldG :: (forall e' x'. Node e' x' -> a -> a) -> Graph Node e x -> a -> a
 -foldG _ GNil z = z
 -foldG f (GUnit b) z = foldB f b z
 -foldG f (GMany g_entry g_blocks g_exit) z =
 -  foldB f g_entry $ M.fold (foldB f) (foldTail (foldB f) g_exit z) g_blocks
 -
 -foldTail :: (Block n C O -> a -> a) -> Tail n x -> a -> a
 -foldTail _ NoTail     z = z
 -foldTail f (Tail _ t) z = f t z
 -
 -foldB :: (forall e' x'. Node e' x' -> a -> a) -> Block Node e x -> a -> a
 -foldB f (BUnit n)    z = f n z
 -foldB f (BCat b1 b2) z = foldB f b1 (foldB f b2 z)
 -
 -showG :: (BlockId -> String) -> Graph Node e x -> String
 -showG _ GNil = ""
 -showG b (GUnit block) = showB b block
 -showG b (GMany g_entry g_blocks g_exit) =
 -  showB b g_entry ++ concatMap (showB b) (map snd $ M.toList g_blocks) ++ showTail (showB b) g_exit
 -
 -showTail :: (Block n C O -> String) -> Tail n x -> String
 -showTail _ NoTail     = ""
 -showTail p (Tail _ n) = p n
 -
 -showB :: (BlockId -> String) -> Block Node e x -> String
 -showB b (BUnit n) = showNode b n ++ "\n"
 -showB b (BCat b1 b2) = showB b b1 ++ showB b b2
 -
 -
 -showNode :: (BlockId -> String) -> Node e x -> String
 -showNode b (Label bid)        = b bid ++ ":"
 -showNode _ (Assign v e)       = ind $ v ++ " = " ++ show e
 -showNode _ (Store addr e)     = ind $ "m[" ++ show addr ++ "] = " ++ show e
 -showNode b (Branch bid)       = ind $ "goto " ++ b bid
 -showNode b (Cond e t f)       =
 -  ind $ "if " ++ show e ++ " then goto " ++ b t ++ " else goto " ++ b f
 -showNode b (Call ress f cargs succ) =
 -  ind $ tuple ress ++ " = " ++ f ++ tuple (map show cargs) ++ " goto " ++ b succ
 -showNode _ (Return      rargs) = ind $ "ret " ++ tuple (map show rargs)
 +    graph  = " {\n" ++ showBody (body proc) ++ "}\n"
 +
- showG :: Graph Node e x -> String
++showG :: Graph Insn e x -> String
 +showG GNil = ""
 +showG (GUnit block) = showB block
 +showG (GMany g_entry g_blocks g_exit) =
 +  showOpen showB g_entry ++ showBody g_blocks ++ showOpen showB g_exit
 +
- showBody :: Body Node -> String
++showBody :: Body Insn -> String
 +showBody blocks = concatMap showB (map snd $ bodyList blocks)
 +
 +showOpen :: (Block n e x -> String) -> MaybeO z (Block n e x) -> String
 +showOpen _ NothingO  = ""
 +showOpen p (JustO n) = p n
 +
- showB :: Block Node e x -> String
++showB :: Block Insn e x -> String
 +showB (BUnit n)    = show n ++ "\n"
 +showB (BCat b1 b2) = showB b1 ++ showB b2
 +
- instance Show (Node e x) where
++instance Show (Insn e x) where
 +  show (Label lbl)        = show lbl ++ ":"
 +  show (Assign v e)       = ind $ v ++ " = " ++ show e
 +  show (Store addr e)     = ind $ "m[" ++ show addr ++ "] = " ++ show e
 +  show (Branch lbl)       = ind $ "goto " ++ show lbl
 +  show (Cond e t f)       =
 +    ind $ "if " ++ show e ++ " then goto " ++ show t ++ " else goto " ++ show f
 +  show (Call ress f cargs succ) =
 +    ind $ tuple ress ++ " = " ++ f ++ tuple (map show cargs) ++ " goto " ++ show succ
 +  show (Return      rargs) = ind $ "ret " ++ tuple (map show rargs)
  
  ind :: String -> String
  ind x = "  " ++ x
diff --cc testing/Live.hs
@@@ -22,25 -21,23 +22,25 @@@ liveLattice = DataflowLattic
                j = new `S.union` old
                ch = if S.size j > S.size old then SomeChange else NoChange
  
- liveness :: BwdTransfer Node Live
 -liveness :: BackwardTransfers Node Live
 -liveness outfact n = add_uses (l outfact n) n
++liveness :: BwdTransfer Insn Live
 +liveness n outfact = live outfact n
    where
-     live :: Fact x Live -> Node e x -> Fact e Live
 -    l :: TailFactB x Live -> Node e x -> Live
 -    l f (Assign x _)      = S.delete x f
 -    l f (Label _)         = f
 -    l f (Store _ _)       = f
 -    l f (Branch bid)      = fact f bid
 -    l f (Cond _ tid fid)  = fact f tid `S.union` fact f fid
 -    l f (Call vs _ _ bid) = fact f bid `S.difference` S.fromList vs
 -    l _ (Return _)        = fact_bot liveLattice
 -    fact = lookupFact liveLattice
 -    add_uses = fold_EN (fold_EE add_var)
 -    add_var s (Var v) = S.insert v s
 -    add_var s _       = s
++    live :: Fact x Live -> Insn e x -> Fact e Live
 +    live f (Assign x _)    = addUses (S.delete x f) n
 +    live f (Label l)       = mkFactBase [(l, f)]
 +    live f (Store _ _)     = addUses f n
 +    live f (Branch l)      = addUses (fact f l) n
 +    live f (Cond _ tl fl)  = addUses (fact f tl `S.union` fact f fl) n
 +    live f (Call vs _ _ l) = addUses (fact f l `S.difference` S.fromList vs) n
 +    live _ (Return _)      = addUses (fact_bot liveLattice) n
 +    fact f l = fromMaybe S.empty $ lookupFact f l
 +    addUses = fold_EN (fold_EE addVar)
 +    addVar s (Var v) = S.insert v s
 +    addVar s _       = s
       
- deadAsstElim :: BwdRewrite Node Live
 -deadAsstElim :: BackwardRewrites Node Live
 -deadAsstElim live (Assign x _) =
 -  if x `S.member` live then Nothing else Just (return GNil)
 -deadAsstElim _ _ = Nothing
++deadAsstElim :: BwdRewrite Insn Live
 +deadAsstElim = shallowBwdRw d
 +  where
-     d :: SimpleBwdRewrite Node Live
++    d :: SimpleBwdRewrite Insn Live
 +    d (Assign x _) live = if x `S.member` live then Nothing else Just (return GNil)
 +    d _ _ = Nothing
@@@ -1,6 -1,6 +1,6 @@@
  {-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns -XGADTs -XRankNTypes #-}
 -module OptSupport (WithTop (..), stdMapJoin, combine,
 -                   map_EE, map_EN, fold_EE, fold_EN, toAGraph) where
 +module OptSupport (WithTop (..), stdMapJoin, map_EE, map_EN, fold_EE, fold_EN,
-                    getFwdFact, nodeToA) where
++                   getFwdFact, insnToA) where
  
  import Control.Monad
  import qualified Data.Map as M
@@@ -32,24 -61,20 +32,24 @@@ stdMapJoin eltJoin new old = M.foldWith
                          (NoChange,   _)  -> (ch, joinmap)
  
  ----------------------------------------------
 --- Combine Transformations
 +-- Common code for getting and propagating facts:
  ----------------------------------------------
  
- getFwdFact :: Node e x -> Fact e f -> f -> f
 --- Combine the transformations, executing the 2nd if the 1st does no rewriting.
 -combine :: ForwardRewrites n f -> ForwardRewrites n f -> ForwardRewrites n f
 -combine r1 r2 = \n f -> case r1 n f of Nothing -> r2 n f
 -                                       x -> x
++getFwdFact :: Insn e x -> Fact e f -> f -> f
 +getFwdFact (Label l)      f def = fromMaybe def $ lookupFact f l
 +getFwdFact (Assign _ _)   f _   = f
 +getFwdFact (Store _ _)    f _   = f
 +getFwdFact (Branch _)     f _   = f
 +getFwdFact (Cond _ _ _)   f _   = f
 +getFwdFact (Call _ _ _ _) f _   = f
 +getFwdFact (Return _)     f _   = f
  
  ----------------------------------------------
---- Map/Fold functions for expressions/nodes
++-- Map/Fold functions for expressions/insns
  ----------------------------------------------
  
  map_EE :: (Exp -> Maybe Exp) -> Exp      -> Maybe Exp
--map_EN :: (Exp -> Maybe Exp) -> Node e x -> Maybe (Node e x)
++map_EN :: (Exp -> Maybe Exp) -> Insn e x -> Maybe (Insn e x)
  
  map_EE f e@(Lit _)     = f e
  map_EE f e@(Var _)     = f e
@@@ -84,7 -109,7 +84,7 @@@ map_EN f   (Return es) 
       where es' = map f es
  
  fold_EE :: (a -> Exp -> a) -> a -> Exp      -> a
--fold_EN :: (a -> Exp -> a) -> a -> Node e x -> a
++fold_EN :: (a -> Exp -> a) -> a -> Insn e x -> a
  
  fold_EE f z e@(Lit _)         = f z e
  fold_EE f z e@(Var _)         = f z e
@@@ -100,14 -125,15 +100,14 @@@ fold_EN f z (Call _ _ es _) = foldl f 
  fold_EN f z (Return es)     = foldl f z es
  
  ----------------------------------------------
- -- Lift a node to an AGraph
 --- Common fact/graph operations
++-- Lift a insn to an AGraph
  ----------------------------------------------
  
- nodeToA :: Node e x -> AGraph Node e x
- nodeToA n@(Label _)      = mkFirst n
- nodeToA n@(Assign _ _)   = mkMiddle n
- nodeToA n@(Store _ _)    = mkMiddle n
- nodeToA n@(Branch _)     = mkLast n
- nodeToA n@(Cond _ _ _)   = mkLast n
- nodeToA n@(Call _ _ _ _) = mkLast n
- nodeToA n@(Return _)     = mkLast n
 --- Probably not quite what we want long term
 -toAGraph :: Node e x -> AGraph Node e x
 -toAGraph n@(Label _)      = agraphOfNode n
 -toAGraph n@(Assign _ _)   = agraphOfNode n
 -toAGraph n@(Store _ _)    = agraphOfNode n
 -toAGraph n@(Branch _)     = agraphOfNode n
 -toAGraph n@(Cond _ _ _)   = agraphOfNode n
 -toAGraph n@(Call _ _ _ _) = agraphOfNode n
 -toAGraph n@(Return _)     = agraphOfNode n
++insnToA :: Insn e x -> AGraph Insn e x
++insnToA n@(Label _)      = mkFirst n
++insnToA n@(Assign _ _)   = mkMiddle n
++insnToA n@(Store _ _)    = mkMiddle n
++insnToA n@(Branch _)     = mkLast n
++insnToA n@(Cond _ _ _)   = mkLast n
++insnToA n@(Call _ _ _ _) = mkLast n
++insnToA n@(Return _)     = mkLast n
@@@ -96,30 -97,22 +96,30 @@@ load     = mem >>= return . Loa
  
  
  -- Statements:
 --- THE FOLLOWING IS EVIL, AND WE SHOULD NOT EXPORT THE BLOCKID TYPE.
 --- USE THE MONAD TO MAP LABELS TO BLOCKIDS, AND DO THIS PROPERLY...
 -lbl :: Parser (BlockId, Node C O)
 -lbl = lexeme (do { l <- natural
 -                 ; char' ':'
 -                 ; let bid = fromInteger l
 -                 ; return $ (bid, Label bid)
 -                 })
 -    <?> "label"
 -
 -mid :: Parser (Node O O)
 +type IdLabelMap = M.Map String Label
 +getLbl :: String -> IdLabelMap -> FuelMonad (IdLabelMap, Label)
 +getLbl id lmap =
 +  do { case M.lookup id lmap of
 +         Just l -> return (lmap, l)
 +         Nothing  -> freshLabel >>= \l ->
 +                     return (M.insert id l lmap, l)
 +     }
 +
- labl :: Parser (IdLabelMap -> FuelMonad (IdLabelMap, Label, Node C O))
++labl :: Parser (IdLabelMap -> FuelMonad (IdLabelMap, Label, Insn C O))
 +labl = lexeme (do { id <- identifier
 +                  ; char' ':'
 +                  ; return $ \lmap -> do { (m, l) <- getLbl id lmap
 +                                         ; return (m, l, Label l)
 +                                         }
 +                  })
 +  <?> "label"
 +
- mid :: Parser (Node O O)
++mid :: Parser (Insn O O)
  mid =   asst
      <|> store
      <?> "assignment or store"
  
--asst :: Parser (Node O O)
++asst :: Parser (Insn O O)
  asst = do { v <- lexeme var
            ; lexeme (char' '=')
            ; e <- expr
            }
      <?> "asst"
  
--store :: Parser (Node O O)
++store :: Parser (Insn O O)
  store = do { addr <- lexeme mem
             ; lexeme (char' '=')
             ; e <- expr
             }
       <?> "store"
  
- type LastParse = Parser (IdLabelMap -> FuelMonad (IdLabelMap, Node O C))
 -lst :: Parser (Node O C)
 -lst =   branch
++type LastParse = Parser (IdLabelMap -> FuelMonad (IdLabelMap, Insn O C))
 +last :: LastParse
 +last =  branch
      <|> cond
      <|> call
      <|> ret
@@@ -150,88 -143,62 +150,88 @@@ goto = do { lexeme (reserved "goto"
            }
      <?> "goto"
  
 -branch :: Parser (Node O C)
 -branch = do { l <- goto
 -            ; return $ Branch l -- Integer is bogus...
 -            }
 -      <?> "branch"
 -
 -cond, call, ret :: Parser (Node O C)
 -cond = do { lexeme (reserved "if")
 -          ; cnd <- expr
 -          ; lexeme (reserved "then")
 -          ; thn <- goto
 -          ; lexeme (reserved "else")
 -          ; els <- goto
 -          ; return $ Cond cnd thn els
 -          }
 -    <?> "cond"
 -
 -call = do { results <- tuple var
 -          ; lexeme (char' '=')
 -          ; f <- identifier
 -          ; params  <- tuple expr
 -          ; succ <- goto
 -          ; return $ Call results f params succ
 -          }
 -    <?> "call"
 -
 -ret  = do { lexeme (reserved "ret")
 -          ; results <- tuple expr
 -          ; return $ Return results
 -          }
 -    <?> "ret"
 -
 -block :: Parser (BlockId, Block Node C C)
 -block = do { (bid, f) <- lexeme lbl
 -           ; ms       <- many $ try mid
 -           ; l        <- lexeme lst
 -           ; return $ (bid, BCat (foldl BCat (BUnit f) $ map BUnit ms) (BUnit l))
 -           }
 -     <?> "Expected basic block; maybe you forgot a label following a control-transfer?"
 +branch :: LastParse
 +branch =
 +    do { l <- goto
 +       ; return $ \lmap -> do { (m, lbl) <- getLbl l lmap
 +                              ; return (m, Branch lbl)
 +                              } 
 +       }
 + <?> "branch"
 +
 +cond, call, ret :: LastParse
 +cond =
 +  do { lexeme (reserved "if")
 +     ; cnd <- expr
 +     ; lexeme (reserved "then")
 +     ; thn <- goto
 +     ; lexeme (reserved "else")
 +     ; els <- goto
 +     ; return $ \lmap -> do { (m',  tlbl) <- getLbl thn lmap
 +                            ; (m'', flbl) <- getLbl els m'
 +                            ; return (m'', Cond cnd tlbl flbl)
 +                            }
 +     }
 + <?> "cond"
 +
 +call =
 +  do { results <- tuple var
 +     ; lexeme (char' '=')
 +     ; f <- identifier
 +     ; params  <- tuple expr
 +     ; succ <- goto
 +     ; return $ \lmap -> do { (m',  slbl) <- getLbl succ lmap
 +                            ; return (m', Call results f params slbl)
 +                            }
 +     }
 + <?> "call"
 +
 +ret =
 +  do { lexeme (reserved "ret")
 +     ; results <- tuple expr
 +     ; return $ \lmap -> return (lmap, Return results)
 +     }
 + <?> "ret"
 +
- block :: Parser (IdLabelMap -> FuelMonad (IdLabelMap, Label, Block Node C C))
++block :: Parser (IdLabelMap -> FuelMonad (IdLabelMap, Label, Block Insn C C))
 +block =
 +  do { f   <- lexeme labl
 +     ; ms  <- many $ try mid
 +     ; l   <- lexeme last
 +     ; return $ \lmap -> do { (lmap1, lbl, first) <- f lmap
 +                            ; (lmap2, lst)        <- l lmap1
 +                            ; return (lmap2, lbl, BCat (foldl BCat (BUnit first) $ map BUnit ms) (BUnit lst))
 +                            }
 +     }
 + <?> "Expected basic block; maybe you forgot a label following a control-transfer?"
  
  tuple :: Parser a -> Parser [a]
  tuple = parens . commaSep
  
- procBody :: Parser (IdLabelMap -> FuelMonad (IdLabelMap, Label, Body Node))
 -procBody :: Parser (BlockId, Graph Node C C)
 -procBody = do { (bid, b)  <- block
 -              ; bs        <- many block
 -              ; return $ (bid, GMany b (M.fromList bs) NoTail)
++procBody :: Parser (IdLabelMap -> FuelMonad (IdLabelMap, Label, Body Insn))
 +procBody = do { b  <- block
 +              ; bs <- many block
 +              ; return $ \lmap ->
 +                   do { (lmap1, lbl, b') <- b lmap
 +                      ; (lmap2, bs') <- foldM threadMap (lmap1, BodyEmpty) bs
 +                      ; return (lmap2, lbl, BodyUnit b' `BodyCat` bs')
 +                      }
                }
          <?> "proc body"
-     threadMap :: (IdLabelMap, Body Node) -> (IdLabelMap -> FuelMonad (IdLabelMap, Label, Block Node C C))
-                                          -> FuelMonad (IdLabelMap, Body Node)
 +  where
++    threadMap :: (IdLabelMap, Body Insn) -> (IdLabelMap -> FuelMonad (IdLabelMap, Label, Block Insn C C))
++                                         -> FuelMonad (IdLabelMap, Body Insn)
 +    threadMap (lmap, bdy) f = do (lmap', _, b) <- f lmap
 +                                 return (lmap', BodyUnit b `BodyCat` bdy)
  
 -proc :: Parser Proc
 +proc :: Parser (FuelMonad Proc)
  proc = do { whitespace
 -          ; f           <- identifier
 -          ; params      <- tuple  var
 -          ; (eid, code) <- braces procBody
 -          ; return $ Proc { name = f, args = params, body = code, entry = eid }
 +          ; f      <- identifier
 +          ; params <- tuple  var
 +          ; bdy    <- braces procBody
 +          ; return $ do { (_, lbl, code) <- bdy M.empty
 +                        ; return $ Proc { name = f, args = params, body = code, entry = lbl }
 +                        }
            }
      <?> "proc"
  
@@@ -7,11 -7,10 +7,11 @@@ import I
  import OptSupport
  
  -- Simplification ("constant folding")
- simplify :: FwdRewrite Node a
 -simplify :: ForwardRewrites Node a
 -simplify _ node = s node >>= return . toAGraph
++simplify :: FwdRewrite Insn a
 +simplify = deepFwdRw $ shallowFwdRw simp
    where
-     simp node _ = s node >>= return . nodeToA
--    s :: Node e x -> Maybe (Node e x)
++    simp insn _ = s insn >>= return . insnToA
++    s :: Insn e x -> Maybe (Insn e x)
      s (Cond (Lit (Bool True))  t _) = Just $ Branch t
      s (Cond (Lit (Bool False)) f _) = Just $ Branch f
      s n = map_EN (map_EE s_e) n