diff options
Diffstat (limited to 'compiler/nativeGen')
25 files changed, 196 insertions, 171 deletions
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index ff18615b1a..bfeaf9e8e3 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -62,6 +62,7 @@ import DynFlags import StaticFlags import Util +import BasicTypes ( Alignment ) import Digraph import Pretty (Doc) import qualified Pretty @@ -131,31 +132,32 @@ The machine-dependent bits break down as follows: -- ----------------------------------------------------------------------------- -- Top-level of the native codegen -data NcgImpl instr jumpDest = NcgImpl { - cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop instr], - generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr), +data NcgImpl statics instr jumpDest = NcgImpl { + cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop statics instr], + generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr), getJumpDestBlockId :: jumpDest -> Maybe BlockId, canShortcut :: instr -> Maybe jumpDest, - shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic, + shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, - pprNatCmmTop :: NatCmmTop instr -> Doc, + pprNatCmmTop :: NatCmmTop statics instr -> Doc, maxSpillSlots :: Int, allocatableRegs :: [RealReg], - ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr], - ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr], + ncg_x86fp_kludge :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], + ncgExpandTop :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr] } -------------------- nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen dflags h us cmms - = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms + = let nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms x86NcgImpl = NcgImpl { cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId ,canShortcut = X86.Instr.canShortcut - ,shortcutStatic = X86.Instr.shortcutStatic + ,shortcutStatics = X86.Instr.shortcutStatics ,shortcutJump = X86.Instr.shortcutJump ,pprNatCmmTop = X86.Ppr.pprNatCmmTop ,maxSpillSlots = X86.Instr.maxSpillSlots @@ -173,7 +175,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId ,canShortcut = PPC.RegInfo.canShortcut - ,shortcutStatic = PPC.RegInfo.shortcutStatic + ,shortcutStatics = PPC.RegInfo.shortcutStatics ,shortcutJump = PPC.RegInfo.shortcutJump ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop ,maxSpillSlots = PPC.Instr.maxSpillSlots @@ -188,7 +190,7 @@ nativeCodeGen dflags h us cmms ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId ,canShortcut = SPARC.ShortcutJump.canShortcut - ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic + ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics ,shortcutJump = SPARC.ShortcutJump.shortcutJump ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop ,maxSpillSlots = SPARC.Instr.maxSpillSlots @@ -204,9 +206,9 @@ nativeCodeGen dflags h us cmms ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch" -nativeCodeGen' :: (Instruction instr, Outputable instr) +nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen' dflags ncgImpl h us cmms = do @@ -270,20 +272,20 @@ nativeCodeGen' dflags ncgImpl h us cmms -- | Do native code generation on all these cmms. -- -cmmNativeGens :: (Instruction instr, Outputable instr) +cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply -> [RawCmmTop] -> [[CLabel]] - -> [ ([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + -> [ ([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats]) ] -> Int -> IO ( [[CLabel]], - [([NatCmmTop instr], - Maybe [Color.RegAllocStats instr], + [([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], Maybe [Linear.RegAllocStats])] ) cmmNativeGens _ _ _ _ [] impAcc profAcc _ @@ -325,17 +327,17 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats cmmNativeGen - :: (Instruction instr, Outputable instr) + :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags - -> NcgImpl instr jumpDest + -> NcgImpl statics instr jumpDest -> UniqSupply -> RawCmmTop -- ^ the cmm to generate code for -> Int -- ^ sequence number of this top thing -> IO ( UniqSupply - , [NatCmmTop instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + , [NatCmmTop statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators cmmNativeGen dflags ncgImpl us cmm count = do @@ -483,7 +485,7 @@ cmmNativeGen dflags ncgImpl us cmm count , ppr_raStatsLinear) -x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr +x86fp_kludge :: NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top x86fp_kludge (CmmProc info lbl (ListGraph code)) = CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) @@ -556,7 +558,7 @@ makeImportsDoc dflags imports sequenceTop :: Instruction instr - => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr + => NcgImpl statics instr jumpDest -> NatCmmTop statics instr -> NatCmmTop statics instr sequenceTop _ top@(CmmData _ _) = top sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = @@ -670,8 +672,8 @@ makeFarBranches blocks -- Analyzes all native code and generates data sections for all jump -- table instructions. generateJumpTables - :: NcgImpl instr jumpDest - -> [NatCmmTop instr] -> [NatCmmTop instr] + :: NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] -> [NatCmmTop statics instr] generateJumpTables ncgImpl xs = concatMap f xs where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs f p = [p] @@ -682,9 +684,9 @@ generateJumpTables ncgImpl xs = concatMap f xs shortcutBranches :: DynFlags - -> NcgImpl instr jumpDest - -> [NatCmmTop instr] - -> [NatCmmTop instr] + -> NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] + -> [NatCmmTop statics instr] shortcutBranches dflags ncgImpl tops | optLevel dflags < 1 = tops -- only with -O or higher @@ -693,7 +695,7 @@ shortcutBranches dflags ncgImpl tops (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops mapping = foldr plusUFM emptyUFM mappings -build_mapping :: NcgImpl instr jumpDest +build_mapping :: NcgImpl statics instr jumpDest -> GenCmmTop d t (ListGraph instr) -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest) build_mapping _ top@(CmmData _ _) = (top, emptyUFM) @@ -723,14 +725,12 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) mapping = foldl add emptyUFM shortcut_blocks add ufm (id,dest) = addToUFM ufm id dest -apply_mapping :: NcgImpl instr jumpDest +apply_mapping :: NcgImpl statics instr jumpDest -> UniqFM jumpDest - -> GenCmmTop CmmStatic h (ListGraph instr) - -> GenCmmTop CmmStatic h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) apply_mapping ncgImpl ufm (CmmData sec statics) - = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics) - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. + = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) = CmmProc info lbl (ListGraph $ map short_bb blocks) where @@ -761,10 +761,10 @@ apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) genMachCode :: DynFlags - -> (RawCmmTop -> NatM [NatCmmTop instr]) + -> (RawCmmTop -> NatM [NatCmmTop statics instr]) -> RawCmmTop -> UniqSM - ( [NatCmmTop instr] + ( [NatCmmTop statics instr] , [CLabel]) genMachCode dflags cmmTopCodeGen cmm_top diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 918198cb9c..5c85101e8e 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -37,13 +37,13 @@ noUsage = RU [] [] -- Type synonyms for Cmm populated with native code type NatCmm instr = GenCmm - CmmStatic + CmmStatics [CmmStatic] (ListGraph instr) -type NatCmmTop instr +type NatCmmTop statics instr = GenCmmTop - CmmStatic + statics [CmmStatic] (ListGraph instr) diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index c375ab4707..7f59fd6fc9 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -709,8 +709,8 @@ pprImportedSymbol _ _ _ initializePicBase_ppc :: Arch -> OS -> Reg - -> [NatCmmTop PPC.Instr] - -> NatM [NatCmmTop PPC.Instr] + -> [NatCmmTop CmmStatics PPC.Instr] + -> NatM [NatCmmTop CmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg (CmmProc info lab (ListGraph blocks) : statics) @@ -719,8 +719,7 @@ initializePicBase_ppc ArchPPC os picReg gotOffLabel <- getNewLabelNat tmp <- getNewRegNat $ intSize wordWidth let - gotOffset = CmmData Text [ - CmmDataLabel gotOffLabel, + gotOffset = CmmData Text $ Statics gotOffLabel [ CmmStaticLit (CmmLabelDiffOff gotLabel mkPicBaseLabel 0) @@ -762,8 +761,8 @@ initializePicBase_ppc _ _ _ _ initializePicBase_x86 :: Arch -> OS -> Reg - -> [NatCmmTop X86.Instr] - -> NatM [NatCmmTop X86.Instr] + -> [NatCmmTop (Alignment, CmmStatics) X86.Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg (CmmProc info lab (ListGraph blocks) : statics) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index f4c972e4b0..84737310aa 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -67,7 +67,7 @@ import FastString cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop CmmStatics Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -86,7 +86,7 @@ cmmTopCodeGen (CmmData sec dat) = do basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop CmmStatics Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -557,8 +557,8 @@ getRegister' _ (CmmLit (CmmFloat f frep)) = do Amode addr addr_code <- getAmode dynRef let size = floatSize frep code dst = - LDATA ReadOnlyData [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f frep)] + LDATA ReadOnlyData (Statics lbl + [CmmStaticLit (CmmFloat f frep)]) `consOL` (addr_code `snocOL` LD size dst addr) return (Any size code) @@ -1180,7 +1180,7 @@ genSwitch expr ids ] return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (BCTR ids (Just lbl)) = let jumpTable | opt_PIC = map jumpTableEntryRel ids @@ -1190,7 +1190,7 @@ generateJumpTableForInstr (BCTR ids (Just lbl)) = jumpTableEntryRel (Just blockid) = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) where blockLabel = mkAsmTempLabel (getUnique blockid) - in Just (CmmData ReadOnlyData (CmmDataLabel lbl : jumpTable)) + in Just (CmmData ReadOnlyData (Statics lbl jumpTable)) generateJumpTableForInstr _ = Nothing -- ----------------------------------------------------------------------------- @@ -1362,10 +1362,9 @@ coerceInt2FP fromRep toRep x = do Amode addr addr_code <- getAmode dynRef let code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmInt 0x43300000 W32), - CmmStaticLit (CmmInt 0x80000000 W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmInt 0x43300000 W32), + CmmStaticLit (CmmInt 0x80000000 W32)], XORIS itmp src (ImmInt 0x8000), ST II32 itmp (spRel 3), LIS itmp (ImmInt 0x4330), diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 0288f1bf02..d13d6afca6 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -75,7 +75,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- start a new basic block. Useful during -- codegen, removed later. Preceding diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index bd12a8188c..6750985f16 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -49,9 +49,9 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc +pprNatCmmTop :: NatCmmTop CmmStatics Instr -> Doc pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) + pprSectionHeader section $$ pprDatas dats -- special case for split markers: pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl @@ -93,6 +93,10 @@ pprBasicBlock (BasicBlock blockid instrs) = vcat (map pprInstr instrs) + +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (map pprData (CmmDataLabel lbl:dats)) + pprData :: CmmStatic -> Doc pprData (CmmAlign bytes) = pprAlign bytes pprData (CmmDataLabel lbl) = pprLabel lbl diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index bfc712af86..2a30087ab7 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -11,7 +11,7 @@ module PPC.RegInfo ( canShortcut, shortcutJump, - shortcutStatic + shortcutStatics ) where @@ -43,18 +43,24 @@ shortcutJump _ other = other -- Here because it knows about JumpDest -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 1eaf00f3a2..a499e1d562 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -27,8 +27,8 @@ import Data.List -- the same and the move instruction safely erased. regCoalesce :: Instruction instr - => [LiveCmmTop instr] - -> UniqSM [LiveCmmTop instr] + => [LiveCmmTop statics instr] + -> UniqSM [LiveCmmTop statics instr] regCoalesce code = do @@ -61,7 +61,7 @@ sinkReg fm r -- then we can rename the two regs to the same thing and eliminate the move. slurpJoinMovs :: Instruction instr - => LiveCmmTop instr + => LiveCmmTop statics instr -> Bag (Reg, Reg) slurpJoinMovs live diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index cdbe98755a..298b5673d4 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -44,12 +44,12 @@ maxSpinCount = 10 -- | The top level of the graph coloring register allocator. regAlloc - :: (Outputable instr, Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => DynFlags -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. - -> [LiveCmmTop instr] -- ^ code annotated with liveness information. - -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] ) + -> [LiveCmmTop statics instr] -- ^ code annotated with liveness information. + -> UniqSM ( [NatCmmTop statics instr], [RegAllocStats statics instr] ) -- ^ code with registers allocated and stats for each stage of -- allocation @@ -239,7 +239,7 @@ regAlloc_spin -- | Build a graph from the liveness and coalesce information in this code. buildGraph :: Instruction instr - => [LiveCmmTop instr] + => [LiveCmmTop statics instr] -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code @@ -320,9 +320,9 @@ graphAddCoalesce _ _ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (Outputable instr, Instruction instr) + :: (Outputable statics, Outputable instr, Instruction instr) => Color.Graph VirtualReg RegClass RealReg - -> LiveCmmTop instr -> LiveCmmTop instr + -> LiveCmmTop statics instr -> LiveCmmTop statics instr patchRegsFromGraph graph code = let diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 4eabb3b0b4..c4fb783688 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -41,13 +41,13 @@ import qualified Data.Set as Set -- regSpill :: Instruction instr - => [LiveCmmTop instr] -- ^ the code + => [LiveCmmTop statics instr] -- ^ the code -> UniqSet Int -- ^ available stack slots -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM - ([LiveCmmTop instr] -- code with SPILL and RELOAD meta instructions added. - , UniqSet Int -- left over slots - , SpillStats ) -- stats about what happened during spilling + ([LiveCmmTop statics instr] -- code with SPILL and RELOAD meta instructions added. + , UniqSet Int -- left over slots + , SpillStats ) -- stats about what happened during spilling regSpill code slotsFree regs @@ -81,8 +81,8 @@ regSpill code slotsFree regs regSpill_top :: Instruction instr => RegMap Int -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmTop instr -- ^ the top level thing. - -> SpillM (LiveCmmTop instr) + -> LiveCmmTop statics instr -- ^ the top level thing. + -> SpillM (LiveCmmTop statics instr) regSpill_top regSlotMap cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 38c33b708a..710055c045 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -54,7 +54,7 @@ type Slot = Int -- | Clean out unneeded spill\/reloads from this top level thing. cleanSpills :: Instruction instr - => LiveCmmTop instr -> LiveCmmTop instr + => LiveCmmTop statics instr -> LiveCmmTop statics instr cleanSpills cmm = evalState (cleanSpin 0 cmm) initCleanS @@ -63,8 +63,8 @@ cleanSpills cmm cleanSpin :: Instruction instr => Int - -> LiveCmmTop instr - -> CleanM (LiveCmmTop instr) + -> LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) {- cleanSpin spinCount code @@ -282,8 +282,8 @@ cleanReload _ _ _ -- cleanTopBackward :: Instruction instr - => LiveCmmTop instr - -> CleanM (LiveCmmTop instr) + => LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) cleanTopBackward cmm = case cmm of diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 330a410312..8a16b25187 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -64,7 +64,7 @@ plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2) -- slurpSpillCostInfo :: (Outputable instr, Instruction instr) - => LiveCmmTop instr + => LiveCmmTop statics instr -> SpillCostInfo slurpSpillCostInfo cmm diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 5ff7bff91a..f24e876cb2 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -36,36 +36,36 @@ import State import Data.List -data RegAllocStats instr +data RegAllocStats statics instr -- initial graph = RegAllocStatsStart - { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness + { raLiveCmm :: [LiveCmmTop statics instr] -- ^ initial code, with liveness , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill -- a spill stage | RegAllocStatsSpill - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced , raSpillStats :: SpillStats -- ^ spiller stats , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for - , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added + , raSpilled :: [LiveCmmTop statics instr] } -- ^ code with spill instructions added -- a successful coloring | RegAllocStatsColored - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced - , raCodeCoalesced :: [LiveCmmTop instr] -- ^ code with coalescings applied - , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs - , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out - , raFinal :: [NatCmmTop instr] -- ^ final code + , raCodeCoalesced :: [LiveCmmTop statics instr] -- ^ code with coalescings applied + , raPatched :: [LiveCmmTop statics instr] -- ^ code with vregs replaced by hregs + , raSpillClean :: [LiveCmmTop statics instr] -- ^ code with unneeded spill\/reloads cleaned out + , raFinal :: [NatCmmTop statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance Outputable instr => Outputable (RegAllocStats instr) where +instance (Outputable statics, Outputable instr) => Outputable (RegAllocStats statics instr) where ppr (s@RegAllocStatsStart{}) = text "# Start" @@ -147,7 +147,7 @@ instance Outputable instr => Outputable (RegAllocStats instr) where -- | Do all the different analysis on this list of RegAllocStats pprStats - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -> SDoc @@ -162,7 +162,7 @@ pprStats stats graph -- | Dump a table of how many spill loads \/ stores were inserted for each vreg. pprStatsSpills - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsSpills stats = let @@ -180,7 +180,7 @@ pprStatsSpills stats -- | Dump a table of how long vregs tend to live for in the initial code. pprStatsLifetimes - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsLifetimes stats = let info = foldl' plusSpillCostInfo zeroSpillCostInfo @@ -208,7 +208,7 @@ binLifetimeCount fm -- | Dump a table of how many conflicts vregs tend to have in the initial code. pprStatsConflict - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsConflict stats = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) @@ -225,7 +225,7 @@ pprStatsConflict stats -- | For every vreg, dump it's how many conflicts it has and its lifetime -- good for making a scatter plot. pprStatsLifeConflict - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph -> SDoc @@ -256,7 +256,7 @@ pprStatsLifeConflict stats graph -- Lets us see how well the register allocator has done. countSRMs :: Instruction instr - => LiveCmmTop instr -> (Int, Int, Int) + => LiveCmmTop statics instr -> (Int, Int, Int) countSRMs cmm = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 3682ffbe1d..4e54b4744d 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -129,8 +129,8 @@ import Control.Monad regAlloc :: (Outputable instr, Instruction instr) => DynFlags - -> LiveCmmTop instr - -> UniqSM (NatCmmTop instr, Maybe RegAllocStats) + -> LiveCmmTop statics instr + -> UniqSM (NatCmmTop statics instr, Maybe RegAllocStats) regAlloc _ (CmmData sec d) = return diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs index c80f77f893..0c059eac27 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -37,7 +37,7 @@ binSpillReasons reasons -- | Count reg-reg moves remaining in this code. countRegRegMovesNat :: Instruction instr - => NatCmmTop instr -> Int + => NatCmmTop statics instr -> Int countRegRegMovesNat cmm = execState (mapGenBlockTopM countBlock cmm) 0 @@ -58,7 +58,7 @@ countRegRegMovesNat cmm -- | Pretty print some RegAllocStats pprStats :: Instruction instr - => [NatCmmTop instr] -> [RegAllocStats] -> SDoc + => [NatCmmTop statics instr] -> [RegAllocStats] -> SDoc pprStats code statss = let -- sum up all the instrs inserted by the spiller diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index a2030fafa9..a6a3724bfa 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -66,9 +66,9 @@ type BlockMap a = BlockEnv a -- | A top level thing which carries liveness information. -type LiveCmmTop instr +type LiveCmmTop statics instr = GenCmmTop - CmmStatic + statics LiveInfo [SCC (LiveBasicBlock instr)] @@ -224,7 +224,7 @@ instance Outputable LiveInfo where -- mapBlockTop :: (LiveBasicBlock instr -> LiveBasicBlock instr) - -> LiveCmmTop instr -> LiveCmmTop instr + -> LiveCmmTop statics instr -> LiveCmmTop statics instr mapBlockTop f cmm = evalState (mapBlockTopM (\x -> return $ f x) cmm) () @@ -235,7 +235,7 @@ mapBlockTop f cmm mapBlockTopM :: Monad m => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) - -> LiveCmmTop instr -> m (LiveCmmTop instr) + -> LiveCmmTop statics instr -> m (LiveCmmTop statics instr) mapBlockTopM _ cmm@(CmmData{}) = return cmm @@ -283,7 +283,7 @@ mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) -- slurpConflicts :: Instruction instr - => LiveCmmTop instr + => LiveCmmTop statics instr -> (Bag (UniqSet Reg), Bag (Reg, Reg)) slurpConflicts live @@ -357,8 +357,8 @@ slurpConflicts live -- -- slurpReloadCoalesce - :: forall instr. Instruction instr - => LiveCmmTop instr + :: forall statics instr. Instruction instr + => LiveCmmTop statics instr -> Bag (Reg, Reg) slurpReloadCoalesce live @@ -458,9 +458,9 @@ slurpReloadCoalesce live -- | Strip away liveness information, yielding NatCmmTop stripLive - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> NatCmmTop instr + :: (Outputable statics, Outputable instr, Instruction instr) + => LiveCmmTop statics instr + -> NatCmmTop statics instr stripLive live = stripCmm live @@ -525,8 +525,8 @@ stripLiveBlock (BasicBlock i lis) eraseDeltasLive :: Instruction instr - => LiveCmmTop instr - -> LiveCmmTop instr + => LiveCmmTop statics instr + -> LiveCmmTop statics instr eraseDeltasLive cmm = mapBlockTop eraseBlock cmm @@ -543,7 +543,7 @@ eraseDeltasLive cmm patchEraseLive :: Instruction instr => (Reg -> Reg) - -> LiveCmmTop instr -> LiveCmmTop instr + -> LiveCmmTop statics instr -> LiveCmmTop statics instr patchEraseLive patchF cmm = patchCmm cmm @@ -620,8 +620,8 @@ patchRegsLiveInstr patchF li natCmmTopToLive :: Instruction instr - => NatCmmTop instr - -> LiveCmmTop instr + => NatCmmTop statics instr + -> LiveCmmTop statics instr natCmmTopToLive (CmmData i d) = CmmData i d @@ -658,8 +658,8 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph -- regLiveness :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> UniqSM (LiveCmmTop instr) + => LiveCmmTop statics instr + -> UniqSM (LiveCmmTop statics instr) regLiveness (CmmData i d) = returnUs $ CmmData i d @@ -720,7 +720,7 @@ checkIsReverseDependent sccs' -- | If we've compute liveness info for this code already we have to reverse -- the SCCs in each top to get them back to the right order so we can do it again. -reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr +reverseBlocksInTops :: LiveCmmTop statics instr -> LiveCmmTop statics instr reverseBlocksInTops top = case top of CmmData{} -> top diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index a4dbbe8771..72e4649eca 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -51,7 +51,7 @@ import Control.Monad ( mapAndUnzipM ) -- | Top level code generation cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop CmmStatics Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) @@ -75,7 +75,7 @@ cmmTopCodeGen (CmmData sec dat) = do basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop CmmStatics Instr]) basicBlockCodeGen cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -313,8 +313,8 @@ genSwitch expr ids , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label , NOP ] -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop CmmStatics Instr) generateJumpTableForInstr (JMP_TBL _ ids label) = let jumpTable = map jumpTableEntry ids - in Just (CmmData ReadOnlyData (CmmDataLabel label : jumpTable)) + in Just (CmmData ReadOnlyData (Statics label jumpTable)) generateJumpTableForInstr _ = Nothing diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index d4500e8a8e..3e49f5c025 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -21,7 +21,7 @@ import Outputable import OrdList -- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmTop Instr -> NatCmmTop Instr +expandTop :: NatCmmTop CmmStatics Instr -> NatCmmTop CmmStatics Instr expandTop top@(CmmData{}) = top diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 9d6aa5e646..ddeed0508b 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -83,9 +83,8 @@ getRegister (CmmLit (CmmFloat f W32)) = do let code dst = toOL [ -- the data area - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], -- load the literal SETHI (HI (ImmCLbl lbl)) tmp, @@ -97,9 +96,8 @@ getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat d W64)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat d W64)], SETHI (HI (ImmCLbl lbl)) tmp, LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF64 code) diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 93f4d27444..816af9ba2a 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -112,7 +112,7 @@ data Instr -- some static data spat out during code generation. -- Will be extracted before pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- Start a new basic block. Useful during codegen, removed later. -- Preceding instruction should be a jump, as per the invariants diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index d78d1a760e..8563aab4fe 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -47,9 +47,9 @@ import Data.Word -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc +pprNatCmmTop :: NatCmmTop CmmStatics Instr -> Doc pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) + pprSectionHeader section $$ pprDatas dats -- special case for split markers: pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl @@ -91,6 +91,9 @@ pprBasicBlock (BasicBlock blockid instrs) = vcat (map pprInstr instrs) +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (map pprData (CmmDataLabel lbl:dats)) + pprData :: CmmStatic -> Doc pprData (CmmAlign bytes) = pprAlign bytes pprData (CmmDataLabel lbl) = pprLabel lbl diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index 30e48bb377..10e2e9fbaa 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -3,7 +3,7 @@ module SPARC.ShortcutJump ( JumpDest(..), getJumpDestBlockId, canShortcut, shortcutJump, - shortcutStatic, + shortcutStatics, shortBlockId ) @@ -38,16 +38,23 @@ shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr shortcutJump _ other = other -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq))) +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. -shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off) +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) +shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. shortcutStatic _ other_static diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index d191733af1..49ac543e65 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -80,7 +80,7 @@ if_sse2 sse2 x87 = do cmmTopCodeGen :: RawCmmTop - -> NatM [NatCmmTop Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) Instr] cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks @@ -95,13 +95,13 @@ cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do Nothing -> return tops cmmTopCodeGen (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic + return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic basicBlockCodeGen :: CmmBasicBlock -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) + , [NatCmmTop (Alignment, CmmStatics) Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -1123,10 +1123,7 @@ memConstant align lit = do return (addr, addr_code) else return (ripRel (ImmCLbl lbl), nilOL) let code = - LDATA ReadOnlyData - [CmmAlign align, - CmmDataLabel lbl, - CmmStaticLit lit] + LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit]) `consOL` addr_code return (Amode addr code) @@ -2041,11 +2038,11 @@ genSwitch expr ids -- in return code -generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop Instr) +generateJumpTableForInstr :: Instr -> Maybe (NatCmmTop (Alignment, CmmStatics) Instr) generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl) generateJumpTableForInstr _ = Nothing -createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop CmmStatic h g +createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop (Alignment, CmmStatics) h g createJumpTable ids section lbl = let jumpTable | opt_PIC = @@ -2056,7 +2053,7 @@ createJumpTable ids section lbl where blockLabel = mkAsmTempLabel (getUnique blockid) in map jumpTableEntryRel ids | otherwise = map jumpTableEntry ids - in CmmData section (CmmDataLabel lbl : jumpTable) + in CmmData section (1, Statics lbl jumpTable) -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index b9c851a859..0e70dbb503 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -27,6 +27,7 @@ import FastBool import Outputable import Constants (rESERVED_C_STACK_BYTES) +import BasicTypes (Alignment) import CLabel import UniqSet import Unique @@ -151,7 +152,6 @@ bit precision. --SDM 1/2003 -} - data Instr -- comment pseudo-op = COMMENT FastString @@ -159,7 +159,7 @@ data Instr -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section (Alignment, CmmStatics) -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -805,16 +805,24 @@ shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn shortcutJump' _ _ other = other -- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics) +shortcutStatics fn (align, Statics lbl statics) + = (align, Statics lbl $ map (shortcutStatic fn) statics) + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq) + | otherwise = lab + shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (mkBlockId uq))) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (mkBlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 769057ae02..676e4c828b 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -31,6 +31,7 @@ import Reg import PprBase +import BasicTypes (Alignment) import OldCmm import CLabel import Unique ( pprUnique, Uniquable(..) ) @@ -48,9 +49,9 @@ import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc +pprNatCmmTop :: NatCmmTop (Alignment, CmmStatics) Instr -> Doc pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) + pprSectionHeader section $$ pprDatas dats -- special case for split markers: pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl @@ -102,6 +103,9 @@ pprBasicBlock (BasicBlock blockid instrs) = vcat (map pprInstr instrs) +pprDatas :: (Alignment, CmmStatics) -> Doc +pprDatas (align, (Statics lbl dats)) = vcat (map pprData (CmmAlign align:CmmDataLabel lbl:dats)) -- TODO: could remove if align == 1 + pprData :: CmmStatic -> Doc pprData (CmmAlign bytes) = pprAlign bytes pprData (CmmDataLabel lbl) = pprLabel lbl |