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.

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index fd36c3a..0ba437c 100644 (file)
--- 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 ffd807b..0f1e94a 100644 (file)
--- 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 e08823e..1edeb5b 100644 (file)
--- 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 5eee30b..770baec 100644 (file)
--- 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 a849924..4b63346 100644 (file)
--- 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 c8ce3ee..5f6654e 100644 (file)
--- 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 8137501..c7a49da 100644 (file)
--- 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 4249437..65e2f6f 100644 (file)
--- 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 f0b180d..faa84c2 100644 (file)
--- 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 0a8ac41..5446e45 100644 (file)
--- 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 d54794b..047781e 100644 (file)
--- 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 8fdd31a..86363ed 100644 (file)
--- 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 e1ef465..2d53ffb 100644 (file)
--- 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 71f2ac1..a0bf9ac 100644 (file)
--- 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 ce031b9..7d13f11 100644 (file)
--- 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 1f94e5f..dd3d029 100644 (file)
--- 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 c3a7319..5719328 100644 (file)
--- 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 2bcc6ec..e64dc09 100644 (file)
--- 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 c47ce96..5b867f3 100644 (file)
--- 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]