From 16dc208aaad7aadaea970e47b8055d7d7f8781e5 Mon Sep 17 00:00:00 2001 From: Norman Ramsey Date: Wed, 5 Sep 2007 16:48:02 +0000 Subject: [PATCH] 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. --- compiler/cmm/Cmm.hs | 37 ++++++++++++------------ compiler/cmm/CmmCPS.hs | 4 +-- compiler/cmm/CmmCPSGen.hs | 4 ++- compiler/cmm/CmmInfo.hs | 8 +++--- compiler/cmm/CmmLint.hs | 6 ++-- compiler/cmm/CmmOpt.hs | 4 +-- compiler/cmm/PprC.hs | 2 +- compiler/cmm/PprCmm.hs | 17 ++++++----- compiler/codeGen/CgMonad.lhs | 2 +- compiler/codeGen/CgUtils.hs | 4 +-- compiler/main/GHC.hs | 2 +- compiler/nativeGen/AsmCodeGen.lhs | 30 +++++++++---------- compiler/nativeGen/MachCodeGen.hs | 4 +-- compiler/nativeGen/MachInstrs.hs | 4 +-- compiler/nativeGen/PositionIndependentCode.hs | 12 ++++---- compiler/nativeGen/PprMach.hs | 4 +-- compiler/nativeGen/RegAllocLinear.hs | 8 +++--- compiler/nativeGen/RegCoalesce.hs | 12 ++++---- compiler/nativeGen/RegLiveness.hs | 38 ++++++++++++------------- 19 files changed, 104 insertions(+), 98 deletions(-) diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index fd36c3a..0ba437c 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 ffd807b..0f1e94a 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 e08823e..1edeb5b 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 5eee30b..770baec 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 a849924..4b63346 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 c8ce3ee..5f6654e 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 8137501..c7a49da 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 4249437..65e2f6f 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 f0b180d..faa84c2 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 0a8ac41..5446e45 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 d54794b..047781e 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 8fdd31a..86363ed 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 e1ef465..2d53ffb 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 71f2ac1..a0bf9ac 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 ce031b9..7d13f11 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 1f94e5f..dd3d029 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 c3a7319..5719328 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 2bcc6ec..e64dc09 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 c47ce96..5b867f3 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] -- 1.7.10.4