change of representation for GenCmm, GenCmmTop, CmmProc

The type parameter to a C-- procedure now represents a control-flow
graph, not a single instruction.  The newtype ListGraph preserves the 
current representation while enabling other representations and a
sensible way of prettyprinting.  Except for a few changes in the
prettyprinter the new compiler binary should be bit-for-bit identical
to the old.

19 files changed, 104 insertions, 98 deletions

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index fd36c3af34..0ba437c982 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -9,6 +9,7 @@
 module Cmm ( 
 	GenCmm(..), Cmm, RawCmm,
 	GenCmmTop(..), CmmTop, RawCmmTop,
+        ListGraph(..),
 	CmmInfo(..), UpdateFrame(..),
         CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
 	GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
@@ -50,45 +51,45 @@ import Data.Word
 -- GenCmm is abstracted over
 --   d, the type of static data elements in CmmData
 --   h, the static info preceding the code of a CmmProc
---   i, the contents of a basic block within a CmmProc
+--   g, the control-flow graph of a CmmProc
 --
 -- We expect there to be two main instances of this type:
 --   (a) C--, i.e. populated with various C-- constructs
 --		(Cmm and RawCmm below)
 --   (b) Native code, populated with data/instructions
 --
-newtype GenCmm d h i = Cmm [GenCmmTop d h i]
+newtype GenCmm d h g = Cmm [GenCmmTop d h g]
 
 -- | A top-level chunk, abstracted over the type of the contents of
 -- the basic blocks (Cmm or instructions are the likely instantiations).
-data GenCmmTop d h i
+data GenCmmTop d h g
   = CmmProc	-- A procedure
      h	               -- Extra header such as the info table
      CLabel            -- Used to generate both info & entry labels
      CmmFormals        -- Argument locals live on entry (C-- procedure params)
-     [GenBasicBlock i] -- Code, may be empty.  The first block is
-                       -- the entry point, and should be labelled by the code gen
-		       -- with the CLabel.  The order is otherwise initially 
-                       -- unimportant, but at some point the code gen will
-                       -- fix the order.
-
-		       -- The BlockId of the first block does not give rise
-		       -- to a label.  To jump to the first block in a Proc,
-		       -- use the appropriate CLabel.
-
-		       -- BlockIds are only unique within a procedure
+     g                 -- Control-flow graph for the procedure's code
 
   | CmmData 	-- Static data
 	Section 
 	[d]
 
+-- | A control-flow graph represented as a list of extended basic blocks.
+newtype ListGraph i = ListGraph [GenBasicBlock i] 
+   -- ^ Code, may be empty.  The first block is the entry point.  The
+   -- order is otherwise initially unimportant, but at some point the
+   -- code gen will fix the order.
+
+   -- BlockIds must be unique across an entire compilation unit, since
+   -- they are translated to assembly-language labels, which scope
+   -- across a whole compilation unit.
+
 -- | Cmm with the info table as a data type
-type Cmm    = GenCmm    CmmStatic CmmInfo CmmStmt
-type CmmTop = GenCmmTop CmmStatic CmmInfo CmmStmt
+type Cmm    = GenCmm    CmmStatic CmmInfo (ListGraph CmmStmt)
+type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt)
 
 -- | Cmm with the info tables converted to a list of 'CmmStatic'
-type RawCmm    = GenCmm    CmmStatic [CmmStatic] CmmStmt
-type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] CmmStmt
+type RawCmm    = GenCmm    CmmStatic [CmmStatic] (ListGraph CmmStmt)
+type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt)
 
 
 -- A basic block containing a single label, at the beginning.
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index ffd807b71e..0f1e94ac97 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -93,7 +93,7 @@ cpsProc uniqSupply proc@(CmmData _ _) = [proc]
 
 -- Empty functions just don't work with the CPS algorithm, but
 -- they don't need the transformation anyway so just output them directly
-cpsProc uniqSupply proc@(CmmProc _ _ _ []) 
+cpsProc uniqSupply proc@(CmmProc _ _ _ (ListGraph []))
   = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
 
 -- CPS transform for those procs that actually need it
@@ -104,7 +104,7 @@ cpsProc uniqSupply proc@(CmmProc _ _ _ [])
 --   * Now break each block into a bunch of blocks (at call sites); 
 --	all but the first will be ContinuationEntry
 --
-cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
+cpsProc uniqSupply (CmmProc info ident params (ListGraph blocks)) = cps_procs
     where
       -- We need to be generating uniques for several things.
       -- We could make this function monadic to handle that
diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs
index e08823e561..1edeb5bf22 100644
--- a/compiler/cmm/CmmCPSGen.hs
+++ b/compiler/cmm/CmmCPSGen.hs
@@ -88,8 +88,10 @@ continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
                    -> CmmTop
 continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
                    (Continuation info label formals _ blocks) =
-    CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False))
+    CmmProc info label formals (ListGraph blocks')
     where
+      blocks' = concat $ zipWith3 continuationToProc' uniques blocks
+                         (True : repeat False)
       curr_format = maybe unknown_block id $ lookup label formats
       unknown_block = panic "unknown BlockId in continuationToProc"
       curr_stack = continuation_frame_size curr_format
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 5eee30bc6b..770baec2ea 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -78,10 +78,10 @@ cmmToRawCmm cmm = do
 
 mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
 mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
-mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
+mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments (ListGraph blocks)) =
     case info of
       -- | Code without an info table.  Easy.
-      CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
+      CmmNonInfoTable -> [CmmProc [] entry_label arguments (ListGraph blocks)]
 
       CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
           let info_label = entryLblToInfoLbl entry_label
@@ -158,7 +158,7 @@ mkInfoTableAndCode :: CLabel
 mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
   | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
   = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
-             entry_lbl args blocks]
+             entry_lbl args (ListGraph blocks)]
 
   | null blocks -- No actual code; only the info table is significant
   =		-- Use a zero place-holder in place of the 
@@ -167,7 +167,7 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
 
   | otherwise	-- Separately emit info table (with the function entry 
   =		-- point as first entry) and the entry code 
-    [CmmProc [] entry_lbl args blocks,
+    [CmmProc [] entry_lbl args (ListGraph blocks),
      mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
 
 mkSRTLit :: CLabel
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index a849924af6..4b63346c0b 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -32,10 +32,10 @@ import Control.Monad
 -- -----------------------------------------------------------------------------
 -- Exported entry points:
 
-cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
+cmmLint :: GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc
 cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
 
-cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc
+cmmLintTop :: GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc
 cmmLintTop top = runCmmLint $ lintCmmTop top
 
 runCmmLint :: CmmLint a -> Maybe SDoc
@@ -44,7 +44,7 @@ runCmmLint l =
 	Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
 	Right _  -> Nothing
 
-lintCmmTop (CmmProc _ lbl _ blocks)
+lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
   = addLintInfo (text "in proc " <> pprCLabel lbl) $
 	mapM_ lintCmmBlock blocks
 lintCmmTop _other
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index c8ce3eef04..5f6654e6f9 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -538,11 +538,11 @@ narrowS _ _ = panic "narrowTo"
 -}
 
 cmmLoopifyForC :: RawCmmTop -> RawCmmTop
-cmmLoopifyForC p@(CmmProc info entry_lbl [] blocks@(BasicBlock top_id _ : _))
+cmmLoopifyForC p@(CmmProc info entry_lbl [] (ListGraph blocks@(BasicBlock top_id _ : _)))
   | null info = p  -- only if there's an info table, ignore case alts
   | otherwise =  
 --  pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
-  CmmProc info entry_lbl [] blocks' 
+  CmmProc info entry_lbl [] (ListGraph blocks')
   where blocks' = [ BasicBlock id (map do_stmt stmts)
 		  | BasicBlock id stmts <- blocks ]
 
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 81375019af..c7a49dadce 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -98,7 +98,7 @@ pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 -- top level procs
 -- 
 pprTop :: RawCmmTop -> SDoc
-pprTop (CmmProc info clbl _params blocks) =
+pprTop (CmmProc info clbl _params (ListGraph blocks)) =
     (if not (null info)
         then pprDataExterns info $$
              pprWordArray (entryLblToInfoLbl clbl) info
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 424943778f..65e2f6feb3 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -59,7 +59,7 @@ import Data.List
 import System.IO
 import Data.Maybe
 
-pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc
+pprCmms :: (Outputable info) => [GenCmm CmmStatic info (ListGraph CmmStmt)] -> SDoc
 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
         where
           separator = space $$ ptext SLIT("-------------------") $$ space
@@ -69,13 +69,16 @@ writeCmms handle cmms = printForC handle (pprCmms cmms)
 
 -----------------------------------------------------------------------------
 
-instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
+instance (Outputable info) => Outputable (GenCmm CmmStatic info (ListGraph CmmStmt)) where
     ppr c = pprCmm c
 
 instance (Outputable d, Outputable info, Outputable i)
 	=> Outputable (GenCmmTop d info i) where
     ppr t = pprTop t
 
+instance Outputable i => Outputable (ListGraph i) where
+    ppr (ListGraph blocks) = vcat (map ppr blocks)
+
 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
     ppr b = pprBBlock b
 
@@ -107,20 +110,20 @@ instance Outputable CmmInfo where
 
 -----------------------------------------------------------------------------
 
-pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
+pprCmm :: (Outputable info) => GenCmm CmmStatic info (ListGraph CmmStmt) -> SDoc
 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
 
 -- --------------------------------------------------------------------------
 -- Top level `procedure' blocks.
 --
-pprTop 	:: (Outputable d, Outputable info, Outputable i)
-	=> GenCmmTop d info i -> SDoc
+pprTop 	:: (Outputable d, Outputable info, Outputable g)
+	=> GenCmmTop d info g -> SDoc
 
-pprTop (CmmProc info lbl params blocks )
+pprTop (CmmProc info lbl params graph)
 
   = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
          , nest 8 $ lbrace <+> ppr info $$ rbrace
-         , nest 4 $ vcat (map ppr blocks)
+         , nest 4 $ ppr graph
          , rbrace ]
 
 -- --------------------------------------------------------------------------
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index f0b180ddc5..faa84c2174 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -745,7 +745,7 @@ emitData sect lits
 
 emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
 emitProc info lbl args blocks
-  = do  { let proc_block = CmmProc info lbl args blocks
+  = do  { let proc_block = CmmProc info lbl args (ListGraph blocks)
 	; state <- getState
 	; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 0a8ac41628..5446e45425 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -562,7 +562,7 @@ emitDataLits :: CLabel -> [CmmLit] -> Code
 emitDataLits lbl lits
   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 
-mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 -- Emit a data-segment data block
 mkDataLits lbl lits
   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
@@ -577,7 +577,7 @@ emitRODataLits lbl lits
         needsRelocation (CmmLabelOff _ _) = True
         needsRelocation _                 = False
 
-mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 mkRODataLits lbl lits
   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
   where section | any needsRelocation lits = RelocatableReadOnlyData
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index d54794b37e..047781eded 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -636,7 +636,7 @@ load2 s@(Session ref) how_much mod_graph = do
 	    partial_mg
 		| LoadDependenciesOf _mod <- how_much
 		= ASSERT( case last partial_mg0 of 
-			    AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False )
+			    AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
 		  List.init partial_mg0
 		| otherwise
 		= partial_mg0
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 8fdd31a40d..86363ed0c1 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -174,7 +174,7 @@ nativeCodeGen dflags h us cmms
 		| dopt Opt_SplitObjs dflags = split_marker : tops
 		| otherwise		    = tops
 
-	split_marker = CmmProc [] mkSplitMarkerLabel [] []
+	split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph [])
 
 
 -- | Do native code generation on all these cmms.
@@ -361,8 +361,8 @@ cmmNativeGen dflags us cmm
 #if i386_TARGET_ARCH
 x86fp_kludge :: NatCmmTop -> NatCmmTop
 x86fp_kludge top@(CmmData _ _) = top
-x86fp_kludge top@(CmmProc info lbl params code) = 
-	CmmProc info lbl params (map bb_i386_insert_ffrees code)
+x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = 
+	CmmProc info lbl params (ListGraph $ map bb_i386_insert_ffrees code)
 	where
 		bb_i386_insert_ffrees (BasicBlock id instrs) =
 			BasicBlock id (i386_insert_ffrees instrs)
@@ -435,8 +435,8 @@ makeImportsDoc imports
 
 sequenceTop :: NatCmmTop -> NatCmmTop
 sequenceTop top@(CmmData _ _) = top
-sequenceTop (CmmProc info lbl params blocks) = 
-  CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
+sequenceTop (CmmProc info lbl params (ListGraph blocks)) = 
+  CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the
@@ -532,10 +532,10 @@ shortcutBranches dflags tops
     mapping = foldr plusUFM emptyUFM mappings
 
 build_mapping top@(CmmData _ _) = (top, emptyUFM)
-build_mapping (CmmProc info lbl params [])
-  = (CmmProc info lbl params [], emptyUFM)
-build_mapping (CmmProc info lbl params (head:blocks))
-  = (CmmProc info lbl params (head:others), mapping)
+build_mapping (CmmProc info lbl params (ListGraph []))
+  = (CmmProc info lbl params (ListGraph []), emptyUFM)
+build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
+  = (CmmProc info lbl params (ListGraph (head:others)), mapping)
         -- drop the shorted blocks, but don't ever drop the first one,
         -- because it is pointed to by a global label.
   where
@@ -554,8 +554,8 @@ apply_mapping ufm (CmmData sec statics)
   = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
   -- we need to get the jump tables, so apply the mapping to the entries
   -- of a CmmData too.
-apply_mapping ufm (CmmProc info lbl params blocks)
-  = CmmProc info lbl params (map short_bb blocks)
+apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
+  = CmmProc info lbl params (ListGraph $ map short_bb blocks)
   where
     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
     short_insn i = shortcutJump (lookupUFM ufm) i
@@ -605,9 +605,9 @@ genMachCode dflags cmm_top
 
 fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
 fixAssignsTop top@(CmmData _ _) = returnUs top
-fixAssignsTop (CmmProc info lbl params blocks) =
+fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) =
   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
-  returnUs (CmmProc info lbl params blocks')
+  returnUs (CmmProc info lbl params (ListGraph blocks'))
 
 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
 fixAssignsBlock (BasicBlock id stmts) =
@@ -662,9 +662,9 @@ Ideas for other things we could do (ToDo):
 
 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])
-cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
+cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do
   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
-  return $ CmmProc info lbl params blocks'
+  return $ CmmProc info lbl params (ListGraph blocks')
 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
 
diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs
index e1ef465e98..2d53ffb58f 100644
--- a/compiler/nativeGen/MachCodeGen.hs
+++ b/compiler/nativeGen/MachCodeGen.hs
@@ -71,10 +71,10 @@ import Data.Int
 type InstrBlock = OrdList Instr
 
 cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop]
-cmmTopCodeGen (CmmProc info lab params blocks) = do
+cmmTopCodeGen (CmmProc info lab params (ListGraph blocks)) = do
   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
   picBaseMb <- getPicBaseMaybeNat
-  let proc = CmmProc info lab params (concat nat_blocks)
+  let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
       tops = proc : concat statics
   case picBaseMb of
       Just picBase -> initializePicBase picBase tops
diff --git a/compiler/nativeGen/MachInstrs.hs b/compiler/nativeGen/MachInstrs.hs
index 71f2ac1b72..a0bf9ac973 100644
--- a/compiler/nativeGen/MachInstrs.hs
+++ b/compiler/nativeGen/MachInstrs.hs
@@ -59,8 +59,8 @@ import GHC.Exts
 -- Our flavours of the Cmm types
 
 -- Type synonyms for Cmm populated with native code
-type NatCmm        = GenCmm CmmStatic [CmmStatic] Instr
-type NatCmmTop     = GenCmmTop CmmStatic [CmmStatic] Instr
+type NatCmm        = GenCmm CmmStatic [CmmStatic] (ListGraph Instr)
+type NatCmmTop     = GenCmmTop CmmStatic [CmmStatic] (ListGraph Instr)
 type NatBasicBlock = GenBasicBlock Instr
 
 -- -----------------------------------------------------------------------------
diff --git a/compiler/nativeGen/PositionIndependentCode.hs b/compiler/nativeGen/PositionIndependentCode.hs
index ce031b90d4..7d13f114e2 100644
--- a/compiler/nativeGen/PositionIndependentCode.hs
+++ b/compiler/nativeGen/PositionIndependentCode.hs
@@ -596,8 +596,8 @@ initializePicBase :: Reg -> [NatCmmTop] -> NatM [NatCmmTop]
 --          call 1f
 --      1:  popl %picReg
 
-initializePicBase picReg (CmmProc info lab params blocks : statics)
-    = return (CmmProc info lab params (b':tail blocks) : statics)
+initializePicBase picReg (CmmProc info lab params (ListGraph blocks) : statics)
+    = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
     where BasicBlock bID insns = head blocks
           b' = BasicBlock bID (FETCHPC picReg : insns)
 
@@ -611,7 +611,7 @@ initializePicBase picReg (CmmProc info lab params blocks : statics)
 -- the (32-bit) offset from our local label to our global offset table
 -- (.LCTOC1 aka gotOffLabel).
 initializePicBase picReg
-    (CmmProc info lab params blocks : statics)
+    (CmmProc info lab params (ListGraph blocks) : statics)
     = do
         gotOffLabel <- getNewLabelNat
         tmp <- getNewRegNat wordRep
@@ -630,7 +630,7 @@ initializePicBase picReg
                                     (AddrRegImm picReg offsetToOffset)
                                : ADD picReg picReg (RIReg tmp)
                                : insns)
-        return (CmmProc info lab params (b' : tail blocks) : gotOffset : statics)
+        return (CmmProc info lab params (ListGraph (b' : tail blocks)) : gotOffset : statics)
 #elif i386_TARGET_ARCH && linux_TARGET_OS
 
 -- We cheat a bit here by defining a pseudo-instruction named FETCHGOT
@@ -640,8 +640,8 @@ initializePicBase picReg
 --              addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg
 -- (See PprMach.lhs)
 
-initializePicBase picReg (CmmProc info lab params blocks : statics)
-    = return (CmmProc info lab params (b':tail blocks) : statics)
+initializePicBase picReg (CmmProc info lab params (ListGraph blocks) : statics)
+    = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
     where BasicBlock bID insns = head blocks
           b' = BasicBlock bID (FETCHGOT picReg : insns)
 
diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs
index 1f94e5fd73..dd3d029a9f 100644
--- a/compiler/nativeGen/PprMach.hs
+++ b/compiler/nativeGen/PprMach.hs
@@ -68,9 +68,9 @@ pprNatCmmTop (CmmData section dats) =
   pprSectionHeader section $$ vcat (map pprData dats)
 
  -- special case for split markers:
-pprNatCmmTop (CmmProc [] lbl _ []) = pprLabel lbl
+pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
 
-pprNatCmmTop (CmmProc info lbl params blocks) = 
+pprNatCmmTop (CmmProc info lbl params (ListGraph blocks)) = 
   pprSectionHeader Text $$
   (if not (null info)
 	then
diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs
index c3a7319102..571932810b 100644
--- a/compiler/nativeGen/RegAllocLinear.hs
+++ b/compiler/nativeGen/RegAllocLinear.hs
@@ -242,12 +242,12 @@ regAlloc (CmmData sec d)
 		( CmmData sec d
 		, Nothing )
 	
-regAlloc (CmmProc (LiveInfo info _ _) lbl params [])
+regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
 	= return
-		( CmmProc info lbl params []
+		( CmmProc info lbl params (ListGraph [])
 		, Nothing )
 	
-regAlloc (CmmProc static lbl params comps)
+regAlloc (CmmProc static lbl params (ListGraph comps))
 	| LiveInfo info (Just first_id) block_live	<- static
 	= do	
  		-- do register allocation on each component.
@@ -263,7 +263,7 @@ regAlloc (CmmProc static lbl params comps)
 		let ((first':_), rest')
 				= partition ((== first_id) . blockId) final_blocks
 
-		return	( CmmProc info lbl params (first' : rest')
+		return	( CmmProc info lbl params (ListGraph (first' : rest'))
 			, Just stats)
 	
 -- bogus. to make non-exhaustive match warning go away.
diff --git a/compiler/nativeGen/RegCoalesce.hs b/compiler/nativeGen/RegCoalesce.hs
index 2bcc6eca56..e64dc09ebe 100644
--- a/compiler/nativeGen/RegCoalesce.hs
+++ b/compiler/nativeGen/RegCoalesce.hs
@@ -61,12 +61,12 @@ slurpJoinMovs :: LiveCmmTop -> Bag (Reg, Reg)
 slurpJoinMovs live
 	= slurpCmm emptyBag live
  where	
-  	slurpCmm   rs  CmmData{}		= rs
-	slurpCmm   rs (CmmProc _ _ _ blocks)	= foldl' slurpComp  rs blocks
-   	slurpComp  rs (BasicBlock _ blocks)	= foldl' slurpBlock rs blocks
-	slurpBlock rs (BasicBlock _ instrs)	= foldl' slurpLI    rs instrs
-		
-	slurpLI    rs (Instr _	Nothing)	= rs
+  	slurpCmm   rs  CmmData{}		         = rs
+	slurpCmm   rs (CmmProc _ _ _ (ListGraph blocks)) = foldl' slurpComp  rs blocks
+   	slurpComp  rs (BasicBlock _ blocks)	         = foldl' slurpBlock rs blocks
+        slurpBlock rs (BasicBlock _ instrs)              = foldl' slurpLI    rs instrs
+                
+        slurpLI    rs (Instr _	Nothing)	         = rs
 	slurpLI    rs (Instr instr (Just live))
 	 	| Just (r1, r2)	<- isRegRegMove instr
 		, elementOfUniqSet r1 $ liveDieRead live
diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index c47ce96006..5b867f3eff 100644
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -69,7 +69,7 @@ type LiveCmmTop
 	= GenCmmTop
 		CmmStatic
 		LiveInfo
-		(GenBasicBlock LiveInstr)
+		(ListGraph (GenBasicBlock LiveInstr))
 			-- the "instructions" here are actually more blocks,
 			--	single blocks are acyclic
 			--	multiple blocks are taken to be cyclic.
@@ -150,9 +150,9 @@ mapBlockTopM
 mapBlockTopM _ cmm@(CmmData{})
 	= return cmm
 
-mapBlockTopM f (CmmProc header label params comps)
+mapBlockTopM f (CmmProc header label params (ListGraph comps))
  = do	comps'	<- mapM (mapBlockCompM f) comps
- 	return	$ CmmProc header label params comps'
+ 	return	$ CmmProc header label params (ListGraph comps')
 
 mapBlockCompM f (BasicBlock i blocks)
  = do	blocks'	<- mapM f blocks
@@ -161,8 +161,8 @@ mapBlockCompM f (BasicBlock i blocks)
 
 -- map a function across all the basic blocks in this code
 mapGenBlockTop
-	:: (GenBasicBlock i -> GenBasicBlock i)
-	-> (GenCmmTop d h i -> GenCmmTop d h i)
+	:: (GenBasicBlock             i -> GenBasicBlock            i)
+	-> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i))
 
 mapGenBlockTop f cmm
 	= evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
@@ -171,15 +171,15 @@ mapGenBlockTop f cmm
 -- | map a function across all the basic blocks in this code (monadic version)
 mapGenBlockTopM
 	:: Monad m
-	=> (GenBasicBlock i -> m (GenBasicBlock i))
-	-> (GenCmmTop d h i -> m (GenCmmTop d h i))
+	=> (GenBasicBlock            i  -> m (GenBasicBlock            i))
+	-> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i)))
 
 mapGenBlockTopM _ cmm@(CmmData{})
 	= return cmm
 
-mapGenBlockTopM f (CmmProc header label params blocks)
+mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
  = do	blocks'	<- mapM f blocks
- 	return	$ CmmProc header label params blocks'
+ 	return	$ CmmProc header label params (ListGraph blocks')
 
 
 -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
@@ -191,7 +191,7 @@ slurpConflicts live
 	= slurpCmm (emptyBag, emptyBag) live
 
  where	slurpCmm   rs  CmmData{}		= rs
- 	slurpCmm   rs (CmmProc info _ _ blocks)	
+ 	slurpCmm   rs (CmmProc info _ _ (ListGraph blocks))
 		= foldl' (slurpComp info) rs blocks
 
 	slurpComp  info rs (BasicBlock _ blocks)	
@@ -250,8 +250,8 @@ stripLive live
 	= stripCmm live
 
  where	stripCmm (CmmData sec ds)	= CmmData sec ds
- 	stripCmm (CmmProc (LiveInfo info _ _) label params comps)
-		= CmmProc info label params (concatMap stripComp comps)
+ 	stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
+		= CmmProc info label params (ListGraph $ concatMap stripComp comps)
 
 	stripComp  (BasicBlock _ blocks)	= map stripBlock blocks
 	stripBlock (BasicBlock i instrs)	= BasicBlock i (map stripLI instrs)
@@ -295,7 +295,7 @@ lifetimeCount cmm
 	= countCmm emptyUFM cmm
  where
 	countCmm fm  CmmData{}		= fm
-	countCmm fm (CmmProc info _ _ blocks)
+	countCmm fm (CmmProc info _ _ (ListGraph blocks))
 		= foldl' (countComp info) fm blocks
 		
 	countComp info fm (BasicBlock _ blocks)
@@ -355,13 +355,13 @@ patchEraseLive patchF cmm
  where
 	patchCmm cmm@CmmData{}	= cmm
 
-	patchCmm (CmmProc info label params comps)
+	patchCmm (CmmProc info label params (ListGraph comps))
 	 | LiveInfo static id blockMap	<- info
 	 = let 	patchRegSet set	= mkUniqSet $ map patchF $ uniqSetToList set
 		blockMap'	= mapUFM patchRegSet blockMap
 
 		info'		= LiveInfo static id blockMap'
-	   in	CmmProc info' label params $ map patchComp comps
+	   in	CmmProc info' label params $ ListGraph $ map patchComp comps
 
 	patchComp (BasicBlock id blocks)
 		= BasicBlock id $ map patchBlock blocks
@@ -425,12 +425,12 @@ regLiveness
 regLiveness (CmmData i d)
 	= returnUs $ CmmData i d
 
-regLiveness (CmmProc info lbl params [])
+regLiveness (CmmProc info lbl params (ListGraph []))
 	= returnUs $ CmmProc
 			(LiveInfo info Nothing emptyUFM)
-			lbl params []
+			lbl params (ListGraph [])
 
-regLiveness (CmmProc info lbl params blocks@(first : _))
+regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
  = let 	first_id		= blockId first
 	sccs			= sccBlocks blocks
 	(ann_sccs, block_live)	= computeLiveness sccs
@@ -445,7 +445,7 @@ regLiveness (CmmProc info lbl params blocks@(first : _))
 
    in	returnUs $ CmmProc
 			(LiveInfo info (Just first_id) block_live)
-			lbl params liveBlocks
+			lbl params (ListGraph liveBlocks)
 
 
 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]