Commit 16dc208a authored by nr@eecs.harvard.edu's avatar nr@eecs.harvard.edu

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.
parent 807b00a7
...@@ -9,6 +9,7 @@ ...@@ -9,6 +9,7 @@
module Cmm ( module Cmm (
GenCmm(..), Cmm, RawCmm, GenCmm(..), Cmm, RawCmm,
GenCmmTop(..), CmmTop, RawCmmTop, GenCmmTop(..), CmmTop, RawCmmTop,
ListGraph(..),
CmmInfo(..), UpdateFrame(..), CmmInfo(..), UpdateFrame(..),
CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
...@@ -50,45 +51,45 @@ import Data.Word ...@@ -50,45 +51,45 @@ import Data.Word
-- GenCmm is abstracted over -- GenCmm is abstracted over
-- d, the type of static data elements in CmmData -- d, the type of static data elements in CmmData
-- h, the static info preceding the code of a CmmProc -- 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: -- We expect there to be two main instances of this type:
-- (a) C--, i.e. populated with various C-- constructs -- (a) C--, i.e. populated with various C-- constructs
-- (Cmm and RawCmm below) -- (Cmm and RawCmm below)
-- (b) Native code, populated with data/instructions -- (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 -- | A top-level chunk, abstracted over the type of the contents of
-- the basic blocks (Cmm or instructions are the likely instantiations). -- the basic blocks (Cmm or instructions are the likely instantiations).
data GenCmmTop d h i data GenCmmTop d h g
= CmmProc -- A procedure = CmmProc -- A procedure
h -- Extra header such as the info table h -- Extra header such as the info table
CLabel -- Used to generate both info & entry labels CLabel -- Used to generate both info & entry labels
CmmFormals -- Argument locals live on entry (C-- procedure params) CmmFormals -- Argument locals live on entry (C-- procedure params)
[GenBasicBlock i] -- Code, may be empty. The first block is g -- Control-flow graph for the procedure's code
-- 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
| CmmData -- Static data | CmmData -- Static data
Section Section
[d] [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 -- | Cmm with the info table as a data type
type Cmm = GenCmm CmmStatic CmmInfo CmmStmt type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt)
type CmmTop = GenCmmTop CmmStatic CmmInfo CmmStmt type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt)
-- | Cmm with the info tables converted to a list of 'CmmStatic' -- | Cmm with the info tables converted to a list of 'CmmStatic'
type RawCmm = GenCmm CmmStatic [CmmStatic] CmmStmt type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt)
type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] CmmStmt type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt)
-- A basic block containing a single label, at the beginning. -- A basic block containing a single label, at the beginning.
......
...@@ -93,7 +93,7 @@ cpsProc uniqSupply proc@(CmmData _ _) = [proc] ...@@ -93,7 +93,7 @@ cpsProc uniqSupply proc@(CmmData _ _) = [proc]
-- Empty functions just don't work with the CPS algorithm, but -- Empty functions just don't work with the CPS algorithm, but
-- they don't need the transformation anyway so just output them directly -- 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] = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
-- CPS transform for those procs that actually need it -- CPS transform for those procs that actually need it
...@@ -104,7 +104,7 @@ cpsProc uniqSupply proc@(CmmProc _ _ _ []) ...@@ -104,7 +104,7 @@ cpsProc uniqSupply proc@(CmmProc _ _ _ [])
-- * Now break each block into a bunch of blocks (at call sites); -- * Now break each block into a bunch of blocks (at call sites);
-- all but the first will be ContinuationEntry -- 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 where
-- We need to be generating uniques for several things. -- We need to be generating uniques for several things.
-- We could make this function monadic to handle that -- We could make this function monadic to handle that
......
...@@ -88,8 +88,10 @@ continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)]) ...@@ -88,8 +88,10 @@ continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
-> CmmTop -> CmmTop
continuationToProc (max_stack, update_frame_size, formats) stack_use uniques continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
(Continuation info label formals _ blocks) = (Continuation info label formals _ blocks) =
CmmProc info label formals (concat $ zipWith3 continuationToProc' uniques blocks (True : repeat False)) CmmProc info label formals (ListGraph blocks')
where where
blocks' = concat $ zipWith3 continuationToProc' uniques blocks
(True : repeat False)
curr_format = maybe unknown_block id $ lookup label formats curr_format = maybe unknown_block id $ lookup label formats
unknown_block = panic "unknown BlockId in continuationToProc" unknown_block = panic "unknown BlockId in continuationToProc"
curr_stack = continuation_frame_size curr_format curr_stack = continuation_frame_size curr_format
......
...@@ -78,10 +78,10 @@ cmmToRawCmm cmm = do ...@@ -78,10 +78,10 @@ cmmToRawCmm cmm = do
mkInfoTable :: Unique -> CmmTop -> [RawCmmTop] mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat] 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 case info of
-- | Code without an info table. Easy. -- | 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 -> CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
let info_label = entryLblToInfoLbl entry_label let info_label = entryLblToInfoLbl entry_label
...@@ -158,7 +158,7 @@ mkInfoTableAndCode :: CLabel ...@@ -158,7 +158,7 @@ mkInfoTableAndCode :: CLabel
mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
| tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
= [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) = [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 | null blocks -- No actual code; only the info table is significant
= -- Use a zero place-holder in place of the = -- Use a zero place-holder in place of the
...@@ -167,7 +167,7 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks ...@@ -167,7 +167,7 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
| otherwise -- Separately emit info table (with the function entry | otherwise -- Separately emit info table (with the function entry
= -- point as first entry) and the entry code = -- 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)] mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
mkSRTLit :: CLabel mkSRTLit :: CLabel
......
...@@ -32,10 +32,10 @@ import Control.Monad ...@@ -32,10 +32,10 @@ import Control.Monad
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- Exported entry points: -- 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 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 cmmLintTop top = runCmmLint $ lintCmmTop top
runCmmLint :: CmmLint a -> Maybe SDoc runCmmLint :: CmmLint a -> Maybe SDoc
...@@ -44,7 +44,7 @@ runCmmLint l = ...@@ -44,7 +44,7 @@ runCmmLint l =
Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err) Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
Right _ -> Nothing Right _ -> Nothing
lintCmmTop (CmmProc _ lbl _ blocks) lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
= addLintInfo (text "in proc " <> pprCLabel lbl) $ = addLintInfo (text "in proc " <> pprCLabel lbl) $
mapM_ lintCmmBlock blocks mapM_ lintCmmBlock blocks
lintCmmTop _other lintCmmTop _other
......
...@@ -538,11 +538,11 @@ narrowS _ _ = panic "narrowTo" ...@@ -538,11 +538,11 @@ narrowS _ _ = panic "narrowTo"
-} -}
cmmLoopifyForC :: RawCmmTop -> RawCmmTop 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 | null info = p -- only if there's an info table, ignore case alts
| otherwise = | otherwise =
-- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $ -- 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) where blocks' = [ BasicBlock id (map do_stmt stmts)
| BasicBlock id stmts <- blocks ] | BasicBlock id stmts <- blocks ]
......
...@@ -98,7 +98,7 @@ pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops ...@@ -98,7 +98,7 @@ pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
-- top level procs -- top level procs
-- --
pprTop :: RawCmmTop -> SDoc pprTop :: RawCmmTop -> SDoc
pprTop (CmmProc info clbl _params blocks) = pprTop (CmmProc info clbl _params (ListGraph blocks)) =
(if not (null info) (if not (null info)
then pprDataExterns info $$ then pprDataExterns info $$
pprWordArray (entryLblToInfoLbl clbl) info pprWordArray (entryLblToInfoLbl clbl) info
......
...@@ -59,7 +59,7 @@ import Data.List ...@@ -59,7 +59,7 @@ import Data.List
import System.IO import System.IO
import Data.Maybe 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)) pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where where
separator = space $$ ptext SLIT("-------------------") $$ space separator = space $$ ptext SLIT("-------------------") $$ space
...@@ -69,13 +69,16 @@ writeCmms handle cmms = printForC handle (pprCmms cmms) ...@@ -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 ppr c = pprCmm c
instance (Outputable d, Outputable info, Outputable i) instance (Outputable d, Outputable info, Outputable i)
=> Outputable (GenCmmTop d info i) where => Outputable (GenCmmTop d info i) where
ppr t = pprTop t 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 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
ppr b = pprBBlock b ppr b = pprBBlock b
...@@ -107,20 +110,20 @@ instance Outputable CmmInfo where ...@@ -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 pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
-- Top level `procedure' blocks. -- Top level `procedure' blocks.
-- --
pprTop :: (Outputable d, Outputable info, Outputable i) pprTop :: (Outputable d, Outputable info, Outputable g)
=> GenCmmTop d info i -> SDoc => 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 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
, nest 8 $ lbrace <+> ppr info $$ rbrace , nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ vcat (map ppr blocks) , nest 4 $ ppr graph
, rbrace ] , rbrace ]
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
......
...@@ -745,7 +745,7 @@ emitData sect lits ...@@ -745,7 +745,7 @@ emitData sect lits
emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
emitProc info lbl args blocks 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 ; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
......
...@@ -562,7 +562,7 @@ emitDataLits :: CLabel -> [CmmLit] -> Code ...@@ -562,7 +562,7 @@ emitDataLits :: CLabel -> [CmmLit] -> Code
emitDataLits lbl lits emitDataLits lbl lits
= emitData Data (CmmDataLabel lbl : map CmmStaticLit 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 -- Emit a data-segment data block
mkDataLits lbl lits mkDataLits lbl lits
= CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
...@@ -577,7 +577,7 @@ emitRODataLits lbl lits ...@@ -577,7 +577,7 @@ emitRODataLits lbl lits
needsRelocation (CmmLabelOff _ _) = True needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False needsRelocation _ = False
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
mkRODataLits lbl lits mkRODataLits lbl lits
= CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
where section | any needsRelocation lits = RelocatableReadOnlyData where section | any needsRelocation lits = RelocatableReadOnlyData
......
...@@ -636,7 +636,7 @@ load2 s@(Session ref) how_much mod_graph = do ...@@ -636,7 +636,7 @@ load2 s@(Session ref) how_much mod_graph = do
partial_mg partial_mg
| LoadDependenciesOf _mod <- how_much | LoadDependenciesOf _mod <- how_much
= ASSERT( case last partial_mg0 of = 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 List.init partial_mg0
| otherwise | otherwise
= partial_mg0 = partial_mg0
......
...@@ -174,7 +174,7 @@ nativeCodeGen dflags h us cmms ...@@ -174,7 +174,7 @@ nativeCodeGen dflags h us cmms
| dopt Opt_SplitObjs dflags = split_marker : tops | dopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops | otherwise = tops
split_marker = CmmProc [] mkSplitMarkerLabel [] [] split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph [])
-- | Do native code generation on all these cmms. -- | Do native code generation on all these cmms.
...@@ -361,8 +361,8 @@ cmmNativeGen dflags us cmm ...@@ -361,8 +361,8 @@ cmmNativeGen dflags us cmm
#if i386_TARGET_ARCH #if i386_TARGET_ARCH
x86fp_kludge :: NatCmmTop -> NatCmmTop x86fp_kludge :: NatCmmTop -> NatCmmTop
x86fp_kludge top@(CmmData _ _) = top x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge top@(CmmProc info lbl params code) = x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) =
CmmProc info lbl params (map bb_i386_insert_ffrees code) CmmProc info lbl params (ListGraph $ map bb_i386_insert_ffrees code)
where where
bb_i386_insert_ffrees (BasicBlock id instrs) = bb_i386_insert_ffrees (BasicBlock id instrs) =
BasicBlock id (i386_insert_ffrees instrs) BasicBlock id (i386_insert_ffrees instrs)
...@@ -435,8 +435,8 @@ makeImportsDoc imports ...@@ -435,8 +435,8 @@ makeImportsDoc imports
sequenceTop :: NatCmmTop -> NatCmmTop sequenceTop :: NatCmmTop -> NatCmmTop
sequenceTop top@(CmmData _ _) = top sequenceTop top@(CmmData _ _) = top
sequenceTop (CmmProc info lbl params blocks) = sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks) CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
-- The algorithm is very simple (and stupid): we make a graph out of -- 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 -- the blocks where there is an edge from one block to another iff the
...@@ -532,10 +532,10 @@ shortcutBranches dflags tops ...@@ -532,10 +532,10 @@ shortcutBranches dflags tops
mapping = foldr plusUFM emptyUFM mappings mapping = foldr plusUFM emptyUFM mappings
build_mapping top@(CmmData _ _) = (top, emptyUFM) build_mapping top@(CmmData _ _) = (top, emptyUFM)
build_mapping (CmmProc info lbl params []) build_mapping (CmmProc info lbl params (ListGraph []))
= (CmmProc info lbl params [], emptyUFM) = (CmmProc info lbl params (ListGraph []), emptyUFM)
build_mapping (CmmProc info lbl params (head:blocks)) build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
= (CmmProc info lbl params (head:others), mapping) = (CmmProc info lbl params (ListGraph (head:others)), mapping)
-- drop the shorted blocks, but don't ever drop the first one, -- drop the shorted blocks, but don't ever drop the first one,
-- because it is pointed to by a global label. -- because it is pointed to by a global label.
where where
...@@ -554,8 +554,8 @@ apply_mapping ufm (CmmData sec statics) ...@@ -554,8 +554,8 @@ apply_mapping ufm (CmmData sec statics)
= CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics) = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
-- we need to get the jump tables, so apply the mapping to the entries -- we need to get the jump tables, so apply the mapping to the entries
-- of a CmmData too. -- of a CmmData too.
apply_mapping ufm (CmmProc info lbl params blocks) apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
= CmmProc info lbl params (map short_bb blocks) = CmmProc info lbl params (ListGraph $ map short_bb blocks)
where where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
short_insn i = shortcutJump (lookupUFM ufm) i short_insn i = shortcutJump (lookupUFM ufm) i
...@@ -605,9 +605,9 @@ genMachCode dflags cmm_top ...@@ -605,9 +605,9 @@ genMachCode dflags cmm_top
fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
fixAssignsTop top@(CmmData _ _) = returnUs top fixAssignsTop top@(CmmData _ _) = returnUs top
fixAssignsTop (CmmProc info lbl params blocks) = fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) =
mapUs fixAssignsBlock blocks `thenUs` \ blocks' -> mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
returnUs (CmmProc info lbl params blocks') returnUs (CmmProc info lbl params (ListGraph blocks'))
fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
fixAssignsBlock (BasicBlock id stmts) = fixAssignsBlock (BasicBlock id stmts) =
...@@ -662,9 +662,9 @@ Ideas for other things we could do (ToDo): ...@@ -662,9 +662,9 @@ Ideas for other things we could do (ToDo):
cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, []) 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) 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] #)) newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
......
...@@ -71,10 +71,10 @@ import Data.Int ...@@ -71,10 +71,10 @@ import Data.Int
type InstrBlock = OrdList Instr type InstrBlock = OrdList Instr
cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop] 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 (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat 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 tops = proc : concat statics
case picBaseMb of case picBaseMb of
Just picBase -> initializePicBase picBase tops Just picBase -> initializePicBase picBase tops
......
...@@ -59,8 +59,8 @@ import GHC.Exts ...@@ -59,8 +59,8 @@ import GHC.Exts
-- Our flavours of the Cmm types -- Our flavours of the Cmm types
-- Type synonyms for Cmm populated with native code -- Type synonyms for Cmm populated with native code
type NatCmm = GenCmm CmmStatic [CmmStatic] Instr type NatCmm = GenCmm CmmStatic [CmmStatic] (ListGraph Instr)
type NatCmmTop = GenCmmTop CmmStatic [CmmStatic] Instr type NatCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph Instr)
type NatBasicBlock = GenBasicBlock Instr type NatBasicBlock = GenBasicBlock Instr
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
...@@ -596,8 +596,8 @@ initializePicBase :: Reg -> [NatCmmTop] -> NatM [NatCmmTop] ...@@ -596,8 +596,8 @@ initializePicBase :: Reg -> [NatCmmTop] -> NatM [NatCmmTop]
-- call 1f -- call 1f
-- 1: popl %picReg -- 1: popl %picReg
initializePicBase picReg (CmmProc info lab params blocks : statics) initializePicBase picReg (CmmProc info lab params (ListGraph blocks) : statics)
= return (CmmProc info lab params (b':tail blocks) : statics) = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
where BasicBlock bID insns = head blocks where BasicBlock bID insns = head blocks
b' = BasicBlock bID (FETCHPC picReg : insns) b' = BasicBlock bID (FETCHPC picReg : insns)
...@@ -611,7 +611,7 @@ initializePicBase picReg (CmmProc info lab params blocks : statics) ...@@ -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 -- the (32-bit) offset from our local label to our global offset table
-- (.LCTOC1 aka gotOffLabel). -- (.LCTOC1 aka gotOffLabel).
initializePicBase picReg initializePicBase picReg
(CmmProc info lab params blocks : statics) (CmmProc info lab params (ListGraph blocks) : statics)
= do = do
gotOffLabel <- getNewLabelNat gotOffLabel <- getNewLabelNat
tmp <- getNewRegNat wordRep tmp <- getNewRegNat wordRep
...@@ -630,7 +630,7 @@ initializePicBase picReg ...@@ -630,7 +630,7 @@ initializePicBase picReg
(AddrRegImm picReg offsetToOffset) (AddrRegImm picReg offsetToOffset)
: ADD picReg picReg (RIReg tmp) : ADD picReg picReg (RIReg tmp)
: insns) : 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 #elif i386_TARGET_ARCH && linux_TARGET_OS
-- We cheat a bit here by defining a pseudo-instruction named FETCHGOT -- We cheat a bit here by defining a pseudo-instruction named FETCHGOT
...@@ -640,8 +640,8 @@ initializePicBase picReg ...@@ -640,8 +640,8 @@ initializePicBase picReg
-- addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg -- addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg
-- (See PprMach.lhs) -- (See PprMach.lhs)
initializePicBase picReg (CmmProc info lab params blocks : statics) initializePicBase picReg (CmmProc info lab params (ListGraph blocks) : statics)
= return (CmmProc info lab params (b':tail blocks) : statics) = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
where BasicBlock bID insns = head blocks where BasicBlock bID insns = head blocks
b' = BasicBlock bID (FETCHGOT picReg : insns) b' = BasicBlock bID (FETCHGOT picReg : insns)
......
...@@ -68,9 +68,9 @@ pprNatCmmTop (CmmData section dats) = ...@@ -68,9 +68,9 @@ pprNatCmmTop (CmmData section dats) =
pprSectionHeader section $$ vcat (map pprData dats) pprSectionHeader section $$ vcat (map pprData dats)
-- special case for split markers: -- 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 $$ pprSectionHeader Text $$
(if not (null info) (if not (null info)
then then
......
...@@ -242,12 +242,12 @@ regAlloc (CmmData sec d) ...@@ -242,12 +242,12 @@ regAlloc (CmmData sec d)
( CmmData sec d ( CmmData sec d
, Nothing ) , Nothing )
regAlloc (CmmProc (LiveInfo info _ _) lbl params []) regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph []))
= return = return
( CmmProc info lbl params [] ( CmmProc info lbl params (ListGraph [])
, Nothing ) , Nothing )
regAlloc (CmmProc static lbl params comps) regAlloc (CmmProc static lbl params (ListGraph comps))
| LiveInfo info (Just first_id) block_live <- static | LiveInfo info (Just first_id) block_live <- static
= do = do
-- do register allocation on each component. -- do register allocation on each component.
...@@ -263,7 +263,7 @@ regAlloc (CmmProc static lbl params comps) ...@@ -263,7 +263,7 @@ regAlloc (CmmProc static lbl params comps)
let ((first':_), rest') let ((first':_), rest')
= partition ((== first_id) . blockId) final_blocks = partition ((== first_id) . blockId) final_blocks
return ( CmmProc info lbl params (first' : rest') return ( CmmProc info lbl params (ListGraph (first' : rest'))
, Just stats) , Just stats)
-- bogus. to make non-exhaustive match warning go away. -- bogus. to make non-exhaustive match warning go away.
......
...@@ -61,12 +61,12 @@ slurpJoinMovs :: LiveCmmTop -> Bag (Reg, Reg) ...@@ -61,12 +61,12 @@ slurpJoinMovs :: LiveCmmTop -> Bag (Reg, Reg)
slurpJoinMovs live slurpJoinMovs live
= slurpCmm emptyBag live = slurpCmm emptyBag live
where where
slurpCmm rs CmmData{} = rs slurpCmm rs CmmData{} = rs
slurpCmm rs (CmmProc _ _ _ blocks) = foldl' slurpComp rs blocks slurpCmm rs (CmmProc _ _ _ (ListGraph blocks)) = foldl' slurpComp rs blocks
slurpComp rs (BasicBlock _ blocks) = foldl' slurpBlock rs blocks slurpComp rs (BasicBlock _ blocks) = foldl' slurpBlock rs blocks
slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs
slurpLI rs (Instr _ Nothing) = rs slurpLI rs (Instr _ Nothing) = rs
slurpLI rs (Instr instr (Just live)) slurpLI rs (Instr instr (Just live))
| Just (r1, r2) <- isRegRegMove instr | Just (r1, r2) <- isRegRegMove instr
, elementOfUniqSet r1 $ liveDieRead live , elementOfUniqSet r1 $ liveDieRead live
......
...@@ -69,7 +69,7 @@ type LiveCmmTop ...@@ -69,7 +69,7 @@ type LiveCmmTop
= GenCmmTop = GenCmmTop
CmmStatic CmmStatic
LiveInfo LiveInfo
(GenBasicBlock LiveInstr) (ListGraph (GenBasicBlock LiveInstr))
-- the "instructions" here are actually more blocks, -- the "instructions" here are actually more blocks,
-- single blocks are acyclic -- single blocks are acyclic
-- multiple blocks are taken to be cyclic. -- multiple blocks are taken to be cyclic.
...@@ -150,9 +150,9 @@ mapBlockTopM ...@@ -150,9 +150,9 @@ mapBlockTopM
mapBlockTopM _ cmm@(CmmData{}) mapBlockTopM _ cmm@(CmmData{})
= return cmm = return cmm
mapBlockTopM f (CmmProc header label params comps) mapBlockTopM f (CmmProc header label params (ListGraph comps))
= do comps' <- mapM (mapBlockCompM f) comps = do comps' <- mapM (mapBlockCompM f) comps
return $ CmmProc header label params comps' return $ CmmProc header label params (ListGraph comps')