import RegAllocInfo
import NCGMonad
import PositionIndependentCode
-import RegAllocLinear
-import RegAllocStats
import RegLiveness
import RegCoalesce
-import qualified RegSpill as Spill
+import qualified RegAllocLinear as Linear
import qualified RegAllocColor as Color
+import qualified RegAllocStats as Color
import qualified GraphColor as Color
import Cmm
import PprCmm ( pprStmt, pprCmms, pprCmm )
import MachOp
import CLabel
+import State
import UniqFM
import Unique ( Unique, getUnique )
import Outputable
import FastString
import UniqSet
+import ErrUtils
-- DEBUGGING ONLY
--import OrdList
-- NB. We *lazilly* compile each block of code for space reasons.
--------------------
-nativeCodeGen :: DynFlags -> Module -> ModLocation -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
-nativeCodeGen dflags mod modLocation cmms us
- = let (res, _) = initUs us $
- cgCmm (concat (map add_split cmms))
+nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
+nativeCodeGen dflags cmms us
+ = do
+ -- do native code generation on all these cmm things
+ (us', result)
+ <- mapAccumLM (cmmNativeGen dflags) us
+ $ concat $ map add_split cmms
- cgCmm :: [RawCmmTop] -> UniqSM ( [CmmNativeGenDump], Pretty.Doc, [CLabel])
- cgCmm tops =
- lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
- case unzip3 results of { (dump,docs,imps) ->
- returnUs (dump, my_vcat docs, concat imps)
- }
- in
- case res of { (dump, insn_sdoc, imports) -> do
+ let (native, imports, mColorStats, mLinearStats)
+ = unzip4 result
- cmmNativeGenDump dflags mod modLocation dump
+ -- dump global NCG stats for graph coloring allocator
+ (case concat $ catMaybes mColorStats of
+ [] -> return ()
+ stats -> do
+ -- build the global register conflict graph
+ let graphGlobal
+ = foldl Color.union Color.initGraph
+ $ [ Color.raGraph stat
+ | stat@Color.RegAllocStatsStart{} <- stats]
+
+ dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+ $ Color.pprStats stats graphGlobal
- return (insn_sdoc Pretty.$$ dyld_stubs imports
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_conflicts "Register conflict graph"
+ $ Color.dotGraph Color.regDotColor trivColorable
+ $ graphGlobal)
-#if HAVE_SUBSECTIONS_VIA_SYMBOLS
- -- On recent versions of Darwin, the linker supports
- -- dead-stripping of code and data on a per-symbol basis.
- -- There's a hack to make this work in PprMach.pprNatCmmTop.
- Pretty.$$ Pretty.text ".subsections_via_symbols"
-#endif
-#if HAVE_GNU_NONEXEC_STACK
- -- On recent GNU ELF systems one can mark an object file
- -- as not requiring an executable stack. If all objects
- -- linked into a program have this note then the program
- -- will not use an executable stack, which is good for
- -- security. GHC generated code does not need an executable
- -- stack so add the note in:
- Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
-#endif
-#if !defined(darwin_TARGET_OS)
- -- And just because every other compiler does, lets stick in
- -- an identifier directive: .ident "GHC x.y.z"
- Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
- Pretty.text cProjectVersion
- in Pretty.text ".ident" Pretty.<+>
- Pretty.doubleQuotes compilerIdent
-#endif
- )
- }
- where
+ -- dump global NCG stats for linear allocator
+ (case catMaybes mLinearStats of
+ [] -> return ()
+ stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+ $ Linear.pprStats (concat stats))
- add_split (Cmm tops)
- | dopt Opt_SplitObjs dflags = split_marker : tops
- | otherwise = tops
+ return $ makeAsmDoc (concat native) (concat imports)
- split_marker = CmmProc [] mkSplitMarkerLabel [] []
+ where add_split (Cmm tops)
+ | dopt Opt_SplitObjs dflags = split_marker : tops
+ | otherwise = tops
- -- Generate "symbol stubs" for all external symbols that might
- -- come from a dynamic library.
-{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
- map head $ group $ sort imps-}
-
- -- (Hack) sometimes two Labels pretty-print the same, but have
- -- different uniques; so we compare their text versions...
- dyld_stubs imps
- | needImportedSymbols
- = Pretty.vcat $
- (pprGotDeclaration :) $
- map (pprImportedSymbol . fst . head) $
- groupBy (\(_,a) (_,b) -> a == b) $
- sortBy (\(_,a) (_,b) -> compare a b) $
- map doPpr $
- imps
- | otherwise
- = Pretty.empty
-
- where doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
- astyle = mkCodeStyle AsmStyle
+ split_marker = CmmProc [] mkSplitMarkerLabel [] []
-#ifndef NCG_DEBUG
- my_vcat sds = Pretty.vcat sds
-#else
- my_vcat sds = Pretty.vcat (
- intersperse (
- Pretty.char ' '
- Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker")
- Pretty.$$ Pretty.char ' '
- )
- sds
- )
-#endif
+-- | Complete native code generation phase for a single top-level chunk of Cmm.
+-- Dumping the output of each stage along the way.
+-- Global conflict graph and NGC stats
+cmmNativeGen
+ :: DynFlags
+ -> UniqSupply
+ -> RawCmmTop
+ -> IO ( UniqSupply
+ , ( [NatCmmTop]
+ , [CLabel]
+ , Maybe [Color.RegAllocStats]
+ , Maybe [Linear.RegAllocStats]))
+
+cmmNativeGen dflags us cmm
+ = do
+ -- rewrite assignments to global regs
+ let (fixed_cmm, usFix) =
+ initUs us $ fixAssignsTop cmm
--- Carries output of the code generator passes, for dumping.
--- Make sure to only fill the one's we're interested in to avoid
--- creating space leaks.
+ -- cmm to cmm optimisations
+ let (opt_cmm, imports) =
+ cmmToCmm dflags fixed_cmm
-data CmmNativeGenDump
- = CmmNativeGenDump
- { cdCmmOpt :: RawCmmTop
- , cdNative :: [NatCmmTop]
- , cdLiveness :: [LiveCmmTop]
- , cdCoalesce :: Maybe [LiveCmmTop]
- , cdRegAllocStats :: Maybe [RegAllocStats]
- , cdColoredGraph :: Maybe (Color.Graph Reg RegClass Reg)
- , cdAlloced :: [NatCmmTop] }
+ dumpIfSet_dyn dflags
+ Opt_D_dump_opt_cmm "Optimised Cmm"
+ (pprCmm $ Cmm [opt_cmm])
-dchoose dflags opt a b
- | dopt opt dflags = a
- | otherwise = b
-dchooses dflags opts a b
- | or $ map ( (flip dopt) dflags) opts = a
- | otherwise = b
+ -- generate native code from cmm
+ let ((native, lastMinuteImports), usGen) =
+ initUs usFix $ genMachCode dflags opt_cmm
--- | Complete native code generation phase for a single top-level chunk of Cmm.
--- Unless they're being dumped, intermediate data structures are squashed after
--- every stage to avoid creating space leaks.
---
-cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (CmmNativeGenDump, Pretty.Doc, [CLabel])
-cmmNativeGen dflags cmm
- = do
- --
- fixed_cmm
- <- {-# SCC "fixAssigns" #-}
- fixAssignsTop cmm
-
- ---- cmm to cmm optimisations
- (cmm, imports, ppr_cmm)
- <- (\fixed_cmm
- -> {-# SCC "genericOpt" #-}
- do let (cmm, imports) = cmmToCmm dflags fixed_cmm
-
- return ( cmm
- , imports
- , dchoose dflags Opt_D_dump_cmm cmm (CmmData Text []))
- ) fixed_cmm
-
-
- ---- generate native code from cmm
- (native, lastMinuteImports, ppr_native)
- <- (\cmm
- -> {-# SCC "genMachCode" #-}
- do (machCode, lastMinuteImports)
- <- genMachCode dflags cmm
-
- return ( machCode
- , lastMinuteImports
- , dchoose dflags Opt_D_dump_asm_native machCode [])
- ) cmm
-
-
- ---- tag instructions with register liveness information
- (withLiveness, ppr_withLiveness)
- <- (\native
- -> {-# SCC "regLiveness" #-}
- do
- withLiveness <- mapUs regLiveness native
-
- return ( withLiveness
- , dchoose dflags Opt_D_dump_asm_liveness withLiveness []))
- native
-
- ---- allocate registers
- (alloced, ppr_alloced, ppr_coalesce, ppr_regAllocStats, ppr_coloredGraph)
- <- (\withLiveness
- -> {-# SCC "regAlloc" #-}
- do
- if dopt Opt_RegsGraph dflags
- then do
- -- the regs usable for allocation
- let alloc_regs
- = foldr (\r -> plusUFM_C unionUniqSets
- $ unitUFM (regClass r) (unitUniqSet r))
- emptyUFM
- $ map RealReg allocatableRegs
-
- -- aggressively coalesce moves between virtual regs
- coalesced <- regCoalesce withLiveness
-
- -- graph coloring register allocation
- (alloced, regAllocStats)
- <- Color.regAlloc
- alloc_regs
- (mkUniqSet [0..maxSpillSlots])
- coalesced
-
- return ( alloced
- , dchoose dflags Opt_D_dump_asm_regalloc alloced []
- , dchoose dflags Opt_D_dump_asm_coalesce (Just coalesced) Nothing
- , dchooses dflags
- [ Opt_D_dump_asm_regalloc_stages
- , Opt_D_drop_asm_stats]
- (Just regAllocStats) Nothing
- , dchoose dflags Opt_D_dump_asm_conflicts Nothing Nothing)
-
- else do
- -- do linear register allocation
- alloced <- mapUs regAlloc withLiveness
- return ( alloced
- , dchoose dflags Opt_D_dump_asm_regalloc alloced []
- , Nothing
- , Nothing
- , Nothing ))
- withLiveness
-
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_native "Native code"
+ (vcat $ map (docToSDoc . pprNatCmmTop) native)
+
+
+ -- tag instructions with register liveness information
+ let (withLiveness, usLive) =
+ initUs usGen $ mapUs regLiveness native
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_liveness "Liveness annotations added"
+ (vcat $ map ppr withLiveness)
+
+
+ -- allocate registers
+ (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
+ if dopt Opt_RegsGraph dflags
+ then do
+ -- the regs usable for allocation
+ let alloc_regs
+ = foldr (\r -> plusUFM_C unionUniqSets
+ $ unitUFM (regClass r) (unitUniqSet r))
+ emptyUFM
+ $ map RealReg allocatableRegs
+
+ -- aggressively coalesce moves between virtual regs
+ let (coalesced, usCoalesce)
+ = initUs usLive $ regCoalesce withLiveness
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
+ (vcat $ map ppr coalesced)
+
+ -- if any of these dump flags are turned on we want to hang on to
+ -- intermediate structures in the allocator - otherwise ditch
+ -- them early so we don't end up creating space leaks.
+ let generateRegAllocStats = or
+ [ dopt Opt_D_dump_asm_regalloc_stages dflags
+ , dopt Opt_D_dump_asm_stats dflags
+ , dopt Opt_D_dump_asm_conflicts dflags ]
+
+ -- graph coloring register allocation
+ let ((alloced, regAllocStats), usAlloc)
+ = initUs usCoalesce
+ $ Color.regAlloc
+ generateRegAllocStats
+ alloc_regs
+ (mkUniqSet [0..maxSpillSlots])
+ coalesced
+
+ -- dump out what happened during register allocation
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc "Registers allocated"
+ (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc_stages "Build/spill stages"
+ (vcat $ map (\(stage, stats)
+ -> text "-- Stage " <> int stage
+ $$ ppr stats)
+ $ zip [0..] regAllocStats)
+
+ return ( alloced, usAlloc
+ , if dopt Opt_D_dump_asm_stats dflags
+ then Just regAllocStats else Nothing
+ , Nothing)
+
+ else do
+ -- do linear register allocation
+ let ((alloced, regAllocStats), usAlloc)
+ = initUs usLive
+ $ liftM unzip
+ $ mapUs Linear.regAlloc withLiveness
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc "Registers allocated"
+ (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+
+ return ( alloced, usAlloc
+ , Nothing
+ , if dopt Opt_D_dump_asm_stats dflags
+ then Just (catMaybes regAllocStats) else Nothing)
---- shortcut branches
let shorted =
#else
sequenced
#endif
-
- ---- vcat
- let final_sdoc =
- {-# SCC "vcat" #-}
- Pretty.vcat (map pprNatCmmTop final_mach_code)
-
- let dump =
- CmmNativeGenDump
- { cdCmmOpt = ppr_cmm
- , cdNative = ppr_native
- , cdLiveness = ppr_withLiveness
- , cdCoalesce = ppr_coalesce
- , cdRegAllocStats = ppr_regAllocStats
- , cdColoredGraph = ppr_coloredGraph
- , cdAlloced = ppr_alloced }
-
- returnUs (dump, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
+
+ return ( usAlloc
+ , ( final_mach_code
+ , lastMinuteImports ++ imports
+ , ppr_raStatsColor
+ , ppr_raStatsLinear) )
+
#if i386_TARGET_ARCH
x86fp_kludge :: NatCmmTop -> NatCmmTop
#endif
--- Dump output of native code generator passes
--- stripe across the outputs for each block so all the information for a
--- certain stage is concurrent in the dumps.
+-- | Build assembler source file from native code and its imports.
--
-cmmNativeGenDump :: DynFlags -> Module -> ModLocation -> [CmmNativeGenDump] -> IO ()
-cmmNativeGenDump dflags mod modLocation dump
- = do
+makeAsmDoc :: [NatCmmTop] -> [CLabel] -> Pretty.Doc
+makeAsmDoc native imports
+ = Pretty.vcat (map pprNatCmmTop native)
+ Pretty.$$ (Pretty.text "")
+ Pretty.$$ dyld_stubs imports
- dumpIfSet_dyn dflags
- Opt_D_dump_opt_cmm "Optimised Cmm"
- (pprCmm $ Cmm $ map cdCmmOpt dump)
-
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_native "(asm-native) Native code"
- (vcat $ map (docToSDoc . pprNatCmmTop) $ concatMap cdNative dump)
+#if HAVE_SUBSECTIONS_VIA_SYMBOLS
+ -- On recent versions of Darwin, the linker supports
+ -- dead-stripping of code and data on a per-symbol basis.
+ -- There's a hack to make this work in PprMach.pprNatCmmTop.
+ Pretty.$$ Pretty.text ".subsections_via_symbols"
+#endif
+#if HAVE_GNU_NONEXEC_STACK
+ -- On recent GNU ELF systems one can mark an object file
+ -- as not requiring an executable stack. If all objects
+ -- linked into a program have this note then the program
+ -- will not use an executable stack, which is good for
+ -- security. GHC generated code does not need an executable
+ -- stack so add the note in:
+ Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
+#endif
+#if !defined(darwin_TARGET_OS)
+ -- And just because every other compiler does, lets stick in
+ -- an identifier directive: .ident "GHC x.y.z"
+ Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
+ Pretty.text cProjectVersion
+ in Pretty.text ".ident" Pretty.<+>
+ Pretty.doubleQuotes compilerIdent
+#endif
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_liveness "(asm-liveness) Liveness info added"
- (vcat $ map (ppr . cdLiveness) dump)
+ where
+ -- Generate "symbol stubs" for all external symbols that might
+ -- come from a dynamic library.
+ dyld_stubs :: [CLabel] -> Pretty.Doc
+{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
+ map head $ group $ sort imps-}
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_coalesce "(asm-coalesce) Register moves coalesced."
- (vcat $ map (ppr . (\(Just c) -> c) . cdCoalesce) dump)
+ -- (Hack) sometimes two Labels pretty-print the same, but have
+ -- different uniques; so we compare their text versions...
+ dyld_stubs imps
+ | needImportedSymbols
+ = Pretty.vcat $
+ (pprGotDeclaration :) $
+ map (pprImportedSymbol . fst . head) $
+ groupBy (\(_,a) (_,b) -> a == b) $
+ sortBy (\(_,a) (_,b) -> compare a b) $
+ map doPpr $
+ imps
+ | otherwise
+ = Pretty.empty
+
+ doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+ astyle = mkCodeStyle AsmStyle
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_regalloc "(asm-regalloc) Registers allocated"
- (vcat $ map (docToSDoc . pprNatCmmTop) $ concatMap cdAlloced dump)
-
- -- with the graph coloring allocator, show the result of each build/spill stage
- -- for each block in turn.
- mapM_ (\codeGraphs
- -> dumpIfSet_dyn dflags
- Opt_D_dump_asm_regalloc_stages "(asm-regalloc-stages)"
- (vcat $ map (\(stage, stats) ->
- text "-- Stage " <> int stage
- $$ ppr stats)
- (zip [0..] codeGraphs)))
- $ map ((\(Just c) -> c) . cdRegAllocStats) dump
-
- -- Build a global register conflict graph.
- -- If you want to see the graph for just one basic block then use asm-regalloc-stages instead.
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_conflicts "(asm-conflicts) Register conflict graph"
- $ Color.dotGraph Color.regDotColor trivColorable
- $ foldl Color.union Color.initGraph
- $ catMaybes $ map cdColoredGraph dump
-
-
- -- Drop native code gen statistics.
- -- This is potentially a large amount of information, so we make a new file instead
- -- of dumping it to stdout.
- --
- when (dopt Opt_D_drop_asm_stats dflags)
- $ do -- make the drop file name based on the object file name
- let dropFile = (init $ ml_obj_file modLocation) ++ "drop-asm-stats"
-
- -- slurp out all the regalloc stats
- let stats = concat $ catMaybes $ map cdRegAllocStats dump
-
- ---- Spiller
- -- slurp out the stats from all the spiller stages
- let spillStats = [ s | s@RegAllocStatsSpill{} <- stats]
-
- -- build a map of how many spill load/stores were inserted for each vreg
- let spillLS = foldl' (plusUFM_C Spill.accSpillLS) emptyUFM
- $ map (Spill.spillLoadStore . raSpillStats) spillStats
-
- -- print the count of load/spills as a tuple so we can read back from the file easilly
- let pprSpillLS :: (Reg, Int, Int) -> SDoc
- pprSpillLS (r, loads, stores) =
- (parens $ (hcat $ punctuate (text ", ") [doubleQuotes (ppr r), int loads, int stores]))
-
-
- let outSpill = ( text "-- (spills-added)"
- $$ text "-- Spill instructions inserted for each virtual reg."
- $$ text "-- (reg_name, spill_loads_added, spill_stores_added)."
- $$ (vcat $ map pprSpillLS $ eltsUFM spillLS)
- $$ text "\n")
-
- ---- Lifetimes
- -- slurp out the maps of all the reg lifetimes
- let lifetimes = map raLifetimes stats
- let lifeMap = foldl' plusUFM emptyUFM $ map raLifetimes stats
- let lifeBins = binLifetimeCount lifeMap
-
- let outLife = ( text "-- (vreg-population-lifetimes)"
- $$ text "-- Number of vregs which lived for a certain number of instructions"
- $$ text "-- (instruction_count, number_of_vregs_that_lived_that_long)"
- $$ (vcat $ map ppr $ eltsUFM lifeBins)
- $$ text "\n")
-
- -- write out the file
- writeFile dropFile
- (showSDoc $ vcat [outSpill, outLife])
-
- return ()
-
- return ()
-- -----------------------------------------------------------------------------
-- Sequencing the basic blocks