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 @@
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.
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 ]
......
......@@ -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
......
......@@ -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 ]
-- --------------------------------------------------------------------------
......
......@@ -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 } }
......
......@@ -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
......
......@@ -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
......
......@@ -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] #))
......
......@@ -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
......
......@@ -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
-- -----------------------------------------------------------------------------
......
......@@ -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)
......
......@@ -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
......
......@@ -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.
......
......@@ -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
......
......@@ -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]
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment