Snapshot

13 files changed, 143 insertions, 120 deletions

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index e6d9eea6e6..a58a0ade0f 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -55,7 +55,7 @@ import Platform
 import SMRep
 import UniqSupply
 
-import Compiler.Hoopl
+import Hoopl
 
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -216,7 +216,7 @@ cafTransfers platform = mkBTransfer3 first middle last
 
 cafAnal :: Platform -> CmmGraph -> FuelUniqSM CAFEnv
 cafAnal platform g
-    = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice (cafTransfers platform)
+    = dataflowAnalBwd g [] $ analBwd cafLattice (cafTransfers platform)
 
 -----------------------------------------------------------------------
 -- Building the SRTs
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
index 5b7efe17ba..9b484f9679 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -13,17 +13,16 @@ where
 import BlockId
 import Cmm
 import CmmUtils
+import CmmContFlowOpt
 import Prelude hiding (iterate, succ, unzip, zip)
 
-import Compiler.Hoopl
+import Hoopl hiding (ChangeFlag)
 import Data.Bits
 import qualified Data.List as List
 import Data.Word
 import FastString
-import Control.Monad
 import Outputable
 import UniqFM
-import Unique
 
 my_trace :: String -> SDoc -> a -> a
 my_trace = if False then pprTrace else \_ _ a -> a
@@ -71,7 +70,7 @@ common_block (old_change, bmap, subst) (hash, b) =
                  (Just b', Nothing)                         -> addSubst b'
                  (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
                  _ -> (old_change, addToUFM bmap hash (b : bs), subst)
-    Nothing -> (old_change, (addToUFM bmap hash [b], subst))
+    Nothing -> (old_change, addToUFM bmap hash [b], subst)
   where bid = entryLabel b
         addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
                       (True, bmap, mapInsert bid (entryLabel b') subst)
@@ -142,11 +141,13 @@ lookupBid subst bid = case mapLookup bid subst of
                         Just bid  -> lookupBid subst bid
                         Nothing -> bid
 
--- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
+-- Equality on the body of a block, modulo a function mapping block
+-- IDs to block IDs.
 eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
-eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
-  where (_, middles , JustC last  :: MaybeC C (CmmNode O C)) = blockToNodeList block
-        (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
+eqBlockBodyWith eqBid block block'
+  = blockToList m == blockToList m' && eqLastWith eqBid l l'
+  where (_,m,l)   = blockSplit block
+        (_,m',l') = blockSplit block'
 
 eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
 eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index a4b2bd4750..885e8b54fc 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -3,7 +3,7 @@
 
 module CmmContFlowOpt
     ( cmmCfgOpts
-    , runCmmContFlowOpts
+    , cmmCfgOptsProc
     , removeUnreachableBlocks
     , replaceLabels
     )
@@ -16,9 +16,10 @@ import Digraph
 import Maybes
 import Outputable
 
-import Compiler.Hoopl
+import Hoopl
 import Control.Monad
 import Prelude hiding (succ, unzip, zip)
+import qualified Data.IntMap as Map
 
 -----------------------------------------------------------------------------
 --
@@ -26,12 +27,12 @@ import Prelude hiding (succ, unzip, zip)
 --
 -----------------------------------------------------------------------------
 
-runCmmContFlowOpts :: CmmGroup -> CmmGroup
-runCmmContFlowOpts = map (optProc cmmCfgOpts)
-
 cmmCfgOpts :: CmmGraph -> CmmGraph
 cmmCfgOpts = removeUnreachableBlocks . blockConcat
 
+cmmCfgOptsProc :: CmmDecl -> CmmDecl
+cmmCfgOptsProc = optProc cmmCfgOpts
+
 optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
 optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
 optProc _   top                  = top
@@ -99,22 +100,22 @@ blockConcat g@CmmGraph { g_entry = entry_id }
      maybe_concat :: CmmBlock
                   -> (BlockEnv CmmBlock, BlockEnv BlockId)
                   -> (BlockEnv CmmBlock, BlockEnv BlockId)
-     maybe_concat block unchanged@(blocks, shortcut_map) =
+     maybe_concat block unchanged@(blocks, shortcut_map)
         | CmmBranch b' <- last
         , Just blk' <- mapLookup b' blocks
-        , shouldConcatWith b' blocks
-        -> (mapInsert bid (splice head blk') blocks, shortcut_map)
+        , shouldConcatWith b' blk'
+        = (mapInsert bid (splice head blk') blocks, shortcut_map)
 
         | Just b'   <- callContinuation_maybe last
         , Just blk' <- mapLookup b' blocks
-        , Just dest <- canShortcut b' blk'
-        -> (blocks, mapInsert b' dest shortcut_map)
+        , Just dest <- canShortcut blk'
+        = (blocks, mapInsert b' dest shortcut_map)
            -- replaceLabels will substitute dest for b' everywhere, later
 
         | otherwise = unchanged
         where
-          (head, last) = blockTail block
-          bid = entryLabel b
+          (head, last) = blockSplitTail block
+          bid = entryLabel block
 
      shouldConcatWith b block
        | num_preds b == 1    = True  -- only one predecessor: go for it
@@ -122,20 +123,20 @@ blockConcat g@CmmGraph { g_entry = entry_id }
        | otherwise           = False
        where num_preds bid = mapLookup bid backEdges `orElse` 0
 
-     canShortcut :: Block C C -> Maybe BlockId
+     canShortcut :: CmmBlock -> Maybe BlockId
      canShortcut block
-       | (_, middle, CmmBranch dest) <- blockHeadTail block
+       | (_, middle, CmmBranch dest) <- blockSplit block
        , isEmptyBlock middle
        = Just dest
        | otherwise
        = Nothing
 
      backEdges :: BlockEnv Int -- number of predecessors for each block
-     backEdges = mapMap setSize $ predMap blocks
-                    ToDo: add 1 for the entry id
+     backEdges = mapInsertWith (+) entry_id 1 $ -- add 1 for the entry id
+                   mapMap setSize $ predMap blocks
 
      splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
-     splice head rest = head `cat` snd (blockHead rest)
+     splice head rest = head `blockAppend` snd (blockSplitHead rest)
 
 
 callContinuation_maybe :: CmmNode O C -> Maybe BlockId
@@ -143,9 +144,9 @@ callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
 callContinuation_maybe (CmmForeignCall { succ = b })   = Just b
 callContinuation_maybe _ = Nothing
 
-okToDuplicate :: Block C C -> Bool
+okToDuplicate :: CmmBlock -> Bool
 okToDuplicate block
-  = case blockToNodeList block of (_, m, _) -> null m
+  = case blockSplit block of (_, m, _) -> isEmptyBlock m
   -- cheap and cheerful; we might expand this in the future to
   -- e.g. spot blocks that represent a single instruction or two
 
@@ -155,8 +156,8 @@ okToDuplicate block
 
 replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
 replaceLabels env g
-  | isEmptyMap env = g
-  | otherwise      = replace_eid . mapGraphNodes1 txnode
+  | mapNull env = g
+  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
    where
      replace_eid g = g {g_entry = lookup (g_entry g)}
      lookup id = mapLookup id env `orElse` id
@@ -175,7 +176,7 @@ replaceLabels env g
      exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
      exp e                                      = e
 
-mkCmmCondBranch :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+mkCmmCondBranch :: CmmExpr -> Label -> Label -> CmmNode O C
 mkCmmCondBranch p t f = if t == f then CmmBranch t else CmmCondBranch p t f
 
 ----------------------------------------------------------------
@@ -191,8 +192,6 @@ predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
 -----------------------------------------------------------------------------
 --
 -- Removing unreachable blocks
---
------------------------------------------------------------------------------
 
 removeUnreachableBlocks :: CmmGraph -> CmmGraph
 removeUnreachableBlocks g
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index c82f517849..8faf42b3bb 100644
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -12,7 +12,7 @@ import CmmUtils
 import qualified OldCmm as Old
 import OldPprCmm ()
 
-import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
+import Hoopl hiding ((<*>), mkLabel, mkBranch)
 import Data.Maybe
 import Maybes
 import Outputable
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 9e70a55bfc..f50d9629b7 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -11,9 +11,10 @@ module CmmLint (
   ) where
 
 import Cmm
+import Outputable
 
 cmmLint :: CmmGraph -> IO ()
-cmmLint g = pprTrace "ToDo! CmmLint" return ()
+cmmLint g = return () -- TODO!!
 
 -- Things to check:
 --     - invariant on CmmBlock in CmmExpr (see comment there)
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index 9a5bb2d5ae..50b2bf6ec2 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -18,7 +18,7 @@ import Control.Monad
 import OptimizationFuel
 import PprCmmExpr ()
 
-import Compiler.Hoopl
+import Hoopl
 import Maybes
 import Outputable
 import UniqSet
@@ -45,7 +45,7 @@ type BlockEntryLiveness = BlockEnv CmmLive
 
 cmmLiveness :: CmmGraph -> FuelUniqSM BlockEntryLiveness
 cmmLiveness graph =
-  liftM check $ liftM snd $ dataflowPassBwd graph [] $ analBwd liveLattice xferLive
+  liftM check $ dataflowAnalBwd graph [] $ analBwd liveLattice xferLive
   where entry = g_entry graph
         check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
 
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index e4f9cf98db..9666c2dca7 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -11,6 +11,7 @@ module CmmPipeline (
 
 import CLabel
 import Cmm
+import CmmLint
 import CmmLive
 import CmmBuildInfoTables
 import CmmCommonBlockElim
@@ -74,10 +75,7 @@ cmmPipeline hsc_env (topSRT, rst) prog =
 
      dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms)
 
-     -- SRT is not affected by control flow optimization pass
-     let prog' = runCmmContFlowOpts cmms
-
-     return (topSRT, prog' : rst)
+     return (topSRT, cmms : rst)
 
 {- [Note global fuel]
 ~~~~~~~~~~~~~~~~~~~~~
@@ -98,86 +96,91 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        -- insertLateReloads, rewriteAssignments?
 
        ----------- Control-flow optimisations ---------------
-       g <- return $ cmmCfgOpts g
+       g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
        dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
 
        ----------- Eliminate common blocks -------------------
-       g <- return $ elimCommonBlocks g
+       g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
        dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
        -- Any work storing block Labels must be performed _after_
        -- elimCommonBlocks
 
        ----------- Proc points -------------------
-       let callPPs = callProcPoints g
-       procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g
-       g <- run $ addProcPointProtocols callPPs procPoints g
+       let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
+       procPoints <- {-# SCC "minimalProcPointSet" #-} run $ minimalProcPointSet (targetPlatform dflags) callPPs g
+       g <- {-# SCC "addProcPointProtocols" #-} run $ addProcPointProtocols callPPs procPoints g
        dump Opt_D_dump_cmmz_proc "Post Proc Points Added" g
 
        ----------- Spills and reloads -------------------
-       g <- run $ dualLivenessWithInsertion procPoints g
+       g <- {-# SCC "dualLivenessWithInsertion" #-} run $ dualLivenessWithInsertion procPoints g
        dump Opt_D_dump_cmmz_spills "Post spills and reloads" g
 
        ----------- Sink and inline assignments -------------------
-       g <- runOptimization $ rewriteAssignments platform g
+       g <- {-# SCC "rewriteAssignments" #-} runOptimization $ rewriteAssignments platform g
        dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
 
        ----------- Eliminate dead assignments -------------------
-       g <- runOptimization $ removeDeadAssignments g
+       g <- {-# SCC "removeDeadAssignments" #-} runOptimization $ removeDeadAssignments g
        dump Opt_D_dump_cmmz_dead "Post remove dead assignments" g
 
        ----------- Zero dead stack slots (Debug only) ---------------
        -- Debugging: stubbing slots on death can cause crashes early
        g <- if opt_StubDeadValues
-                then run $ stubSlotsOnDeath g
+                then {-# SCC "stubSlotsOnDeath" #-} run $ stubSlotsOnDeath g
                 else return g
        dump Opt_D_dump_cmmz_stub "Post stub dead stack slots" g
 
        --------------- Stack layout ----------------
-       slotEnv <- run $ liveSlotAnal g
+       slotEnv <- {-# SCC "liveSlotAnal" #-} run $ liveSlotAnal g
        let spEntryMap = getSpEntryMap entry_off g
        mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
-       let areaMap = layout procPoints spEntryMap slotEnv entry_off g
+       let areaMap = {-# SCC "layout" #-} layout procPoints spEntryMap slotEnv entry_off g
        mbpprTrace "areaMap" (ppr areaMap) $ return ()
 
        ------------  Manifest the stack pointer --------
-       g  <- run $ manifestSP spEntryMap areaMap entry_off g
+       g  <- {-# SCC "manifestSP" #-} run $ manifestSP spEntryMap areaMap entry_off g
        dump Opt_D_dump_cmmz_sp "Post manifestSP" g
        -- UGH... manifestSP can require updates to the procPointMap.
        -- We can probably do something quicker here for the update...
 
        ------------- Split into separate procedures ------------
-       procPointMap  <- run $ procPointAnalysis procPoints g
-       dumpWith ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
-       gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
+       procPointMap  <- {-# SCC "procPointAnalysis" #-} run $ procPointAnalysis procPoints g
+       dumpWith dflags ppr Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
+       gs <- {-# SCC "splitAtProcPoints" #-} run $ splitAtProcPoints l callPPs procPoints procPointMap
                                        (CmmProc h l g)
-       mapM_ (dump Opt_D_dump_cmmz_split "Post splitting") gs
+       dumps Opt_D_dump_cmmz_split "Post splitting" gs
 
        ------------- More CAFs and foreign calls ------------
-       cafEnv <- run $ cafAnal platform g
+       cafEnv <- {-# SCC "cafAnal" #-} run $ cafAnal platform g
        let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
        mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
 
-       gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
-       mapM_ (dump Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs
+       gs <- {-# SCC "lowerSafeForeignCalls" #-} run $ mapM (lowerSafeForeignCalls areaMap) gs
+       dumps Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls" gs
 
        ----------- Control-flow optimisations ---------------
-       gs <- return $ map cmmCfgOpts gs
-       mapM_ (dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations") gs
+       gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
+       dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
 
        -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
-       gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs
-       mapM_ (dump Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs
-       gs <- return $ map (bundleCAFs cafEnv) gs
-       mapM_ (dump Opt_D_dump_cmmz_cafs "after bundleCAFs") gs
+       gs <- {-# SCC "setInfoTableStackMap" #-} return $ map (setInfoTableStackMap slotEnv areaMap) gs
+       dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
+       gs <- {-# SCC "bundleCAFs" #-} return $ map (bundleCAFs cafEnv) gs
+       dumps Opt_D_dump_cmmz_cafs "after bundleCAFs" gs
        return (localCAFs, gs)
 
               -- gs        :: [ (CAFSet, CmmDecl) ]
               -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)
 
   where dflags = hsc_dflags hsc_env
-        mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
+        platform = targetPlatform dflags
+        mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
+                         | otherwise = z
         dump = dumpGraph dflags
 
+        dumps flag name
+           = mapM_ (dumpWith dflags (pprPlatform platform) flag name)
+
         -- Runs a required transformation/analysis
         run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
         -- Runs an optional transformation/analysis (and should
@@ -185,20 +188,19 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
         runOptimization = runFuelIO (hsc_OptFuel hsc_env)
 
 
-dumpGraph :: DynFlags -> DynFlag -> CmmGraph -> IO ()
-dumpGraph dflags flag g = do
+dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
+dumpGraph dflags flag name g = do
   cmmLint g
-  dumpWith (pprPlatform platform)
-  where
-        platform = targetPlatform dflags
-
-        dumpWith pprFun flag txt g = do
-            -- ToDo: No easy way of say "dump all the cmmz, *and* split
-            -- them into files."  Also, -ddump-cmmz doesn't play nicely
-            -- with -ddump-to-file, since the headers get omitted.
-            dumpIfSet_dyn dflags flag txt (pprFun g)
-            when (not (dopt flag dflags)) $
-                dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
+  dumpWith dflags (pprPlatform (targetPlatform dflags)) flag name g
+
+dumpWith :: DynFlags -> (a -> SDoc) -> DynFlag -> String -> a -> IO ()
+dumpWith dflags pprFun flag txt g = do
+         -- ToDo: No easy way of say "dump all the cmmz, *and* split
+         -- them into files."  Also, -ddump-cmmz doesn't play nicely
+         -- with -ddump-to-file, since the headers get omitted.
+   dumpIfSet_dyn dflags flag txt (pprFun g)
+   when (not (dopt flag dflags)) $
+      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
 
 -- This probably belongs in CmmBuildInfoTables?
 -- We're just finishing the job here: once we know what CAFs are defined
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 8e329d5217..691fbd8eeb 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -28,7 +28,7 @@ import Platform
 import UniqSet
 import UniqSupply
 
-import Compiler.Hoopl
+import Hoopl
 
 import qualified Data.Map as Map
 
@@ -110,23 +110,23 @@ procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
 -- Once you know what the proc-points are, figure out
 -- what proc-points each block is reachable from
 procPointAnalysis procPoints g =
-  liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward
+  -- pprTrace "procPointAnalysis" (ppr procPoints) $
+  dataflowAnalFwd g initProcPoints $ analFwd lattice forward
   where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
 
 -- transfer equations
 
 forward :: FwdTransfer CmmNode Status
-forward = mkFTransfer transfer
+forward = mkFTransfer3 first middle last
     where
-      transfer :: CmmNode e x -> Status -> Fact x Status
-      transfer n s
-         = case shapeX n of
-             Open   -> case n of
-                         CmmEntry id | ProcPoint <- s
-                                 -> ReachedBy $ setSingleton id
-                         _ -> s
-             Closed ->
-                mkFactBase lattice $ map (\id -> (id, x)) (successors l)
+      first :: CmmNode C O -> Status -> Status
+      first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
+      first  _ x = x
+
+      middle _ x = x
+
+      last :: CmmNode O C -> Status -> FactBase Status
+      last l x = mkFactBase lattice $ map (\id -> (id, x)) (successors l)
 
 lattice :: DataflowLattice Status
 lattice = DataflowLattice "direct proc-point reachability" unreached add_to
@@ -165,6 +165,7 @@ minimalProcPointSet platform callProcPoints g
 extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
 extendPPSet platform g blocks procPoints =
     do env <- procPointAnalysis procPoints g
+       -- pprTrace "extensPPSet" (ppr env) $ return ()
        let add block pps = let id = entryLabel block
                            in  case mapLookup id env of
                                  Just ProcPoint -> setInsert id pps
@@ -331,8 +332,9 @@ add_CopyIns callPPs protos blocks = mapFold maybe_insert_CopyIns mapEmpty blocks
              | not $ setMember bid callPPs
              , Just (Protocol c fs _area) <- mapLookup bid protos
              = let nodes     = copyInSlot c fs
-                   (h, m, l) = blockToNodeList block
-               in insertBlock (blockOfNodeList (h, nodes ++ m, l)) blocks
+                   (h, b) = blockSplitHead block
+                   block' = blockJoinHead h (blockFromList nodes `blockAppend` b)
+               in insertBlock block' blocks
              | otherwise = insertBlock block blocks
            where bid = entryLabel block
 
diff --git a/compiler/cmm/CmmRewriteAssignments.hs b/compiler/cmm/CmmRewriteAssignments.hs
index ecf3f7e0c3..45eb89f9fd 100644
--- a/compiler/cmm/CmmRewriteAssignments.hs
+++ b/compiler/cmm/CmmRewriteAssignments.hs
@@ -27,7 +27,7 @@ import UniqFM
 import Unique
 import BlockId
 
-import Compiler.Hoopl hiding (Unique)
+import Hoopl
 import Data.Maybe
 import Prelude hiding (succ, zip)
 
diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index 9e762fe48a..2610e2cb6e 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -23,7 +23,7 @@ import Outputable hiding (empty)
 import qualified Outputable as PP
 import UniqSet
 
-import Compiler.Hoopl hiding (Unique)
+import Hoopl
 import Data.Maybe
 import Prelude hiding (succ, zip)
 
diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index 8c4f8e3704..dad684bf31 100644
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -39,7 +39,7 @@ import OptimizationFuel
 import Outputable
 import SMRep (ByteOff)
 
-import Compiler.Hoopl
+import Hoopl
 
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -94,7 +94,7 @@ type SlotEnv   = BlockEnv SubAreaSet
   -- The sub-areas live on entry to the block
 
 liveSlotAnal :: CmmGraph -> FuelUniqSM SlotEnv
-liveSlotAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd slotLattice liveSlotTransfers
+liveSlotAnal g = dataflowAnalBwd g [] $ analBwd slotLattice liveSlotTransfers
 
 -- Add the subarea s to the subareas in the list-set (possibly coalescing it with
 -- adjacent subareas), and also return whether s was a new addition.
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index c78fc242f4..cb904624c4 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -66,7 +66,7 @@ module CmmUtils(
         foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
       
         analFwd, analBwd, analRewFwd, analRewBwd,
-        dataflowPassFwd, dataflowPassBwd
+        dataflowPassFwd, dataflowPassBwd, dataflowAnalFwd, dataflowAnalBwd
   ) where
 
 #include "HsVersions.h"
@@ -88,7 +88,7 @@ import Data.Word
 import Data.Maybe
 import Data.Bits
 import Control.Monad
-import Compiler.Hoopl hiding ( Unique )
+import Hoopl
 
 ---------------------------------------------------
 --
@@ -440,18 +440,6 @@ foldGraphBlocks k z g = mapFold k z $ toBlockMap g
 postorderDfs :: CmmGraph -> [CmmBlock]
 postorderDfs g = postorder_dfs_from (toBlockMap g) (g_entry g)
 
--------------------------------------------------
--- Manipulating CmmBlocks
-
-lastNode :: CmmBlock -> CmmNode O C
-lastNode block = foldBlockNodesF3 (nothing, nothing, const) block ()
-  where nothing :: a -> b -> ()
-        nothing _ _ = ()
-
-replaceLastNode :: Block CmmNode e C -> CmmNode O C -> Block CmmNode e C
-replaceLastNode block last = blockOfNodeList (first, middle, JustC last)
-  where (first, middle, _) = blockToNodeList block
-
 ----------------------------------------------------------------------
 ----- Splicing between blocks
 -- Given a middle node, a block, and a successor BlockId,
@@ -499,26 +487,56 @@ insertBetween b ms succId = insert $ lastNode b
 -- Running dataflow analysis and/or rewrites
 
 -- Constructing forward and backward analysis-only pass
-analFwd    :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f
-analBwd    :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f
+analFwd    :: DataflowLattice f -> FwdTransfer n f -> FwdPass FuelUniqSM n f
+analBwd    :: DataflowLattice f -> BwdTransfer n f -> BwdPass FuelUniqSM n f
 
 analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
 analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
 
 -- Constructing forward and backward analysis + rewrite pass
-analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f
-analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f
+analRewFwd :: DataflowLattice f -> FwdTransfer n f
+           -> FwdRewrite FuelUniqSM n f
+           -> FwdPass FuelUniqSM n f
+
+analRewBwd :: DataflowLattice f
+           -> BwdTransfer n f
+           -> BwdRewrite FuelUniqSM n f
+           -> BwdPass FuelUniqSM n f
 
 analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
 analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
 
 -- Running forward and backward dataflow analysis + optional rewrite
-dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
+dataflowPassFwd :: NonLocal n =>
+                   GenCmmGraph n -> [(BlockId, f)]
+                -> FwdPass FuelUniqSM n f
+                -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
 dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
   (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
   return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
 
-dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
+dataflowAnalFwd :: NonLocal n =>
+                   GenCmmGraph n -> [(BlockId, f)]
+                -> FwdPass FuelUniqSM n f
+                -> FuelUniqSM (BlockEnv f)
+dataflowAnalFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
+--  (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
+--  return facts
+  return (analyzeFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts))
+
+dataflowAnalBwd :: NonLocal n =>
+                   GenCmmGraph n -> [(BlockId, f)]
+                -> BwdPass FuelUniqSM n f
+                -> FuelUniqSM (BlockEnv f)
+dataflowAnalBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
+--  (graph, facts, NothingO) <- analyzeAndRewriteBwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
+--  return facts
+  return (analyzeBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts))
+
+dataflowPassBwd :: NonLocal n =>
+                   GenCmmGraph n -> [(BlockId, f)]
+                -> BwdPass FuelUniqSM n f
+                -> FuelUniqSM (GenCmmGraph n, BlockEnv f)
 dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
   (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
   return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 3badef793f..2561eed35b 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -185,7 +185,7 @@ outOfLine ag = withFreshLabel "outOfLine" $ \l ->
                do g <- ag
                   return (case g of
                     Closed (GMany (JustO e) b _) -> note_unreachable e $ Opened $
-                                                      GMany (JustO $ BLast $ CmmBranch l) b (JustO $ BFirst $ CmmEntry l)
+                                                      GMany (JustO $ BlockOC BNil (CmmBranch l)) b (JustO $ BlockCO (CmmEntry l) BNil)
                     _                            -> panic "outOfLine"
                     :: CmmGraphOC)