X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=13f620fe50b29b4787e16568d8c6b177a2677b4d;hb=dc6cd68f919657139df43136b1bd57520b2a01b2;hp=fa9e77cd05f004c5481776b53c5a126474ece297;hpb=f0d0e9d63ee27a12e80b6f069be5e9d4b55ca545;p=ghc-hetmet.git diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index fa9e77c..13f620f 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -42,6 +42,7 @@ import DynFlags import StaticFlags ( opt_Static, opt_PIC ) import Util import Config ( cProjectVersion ) +import Module import Digraph import qualified Pretty @@ -52,15 +53,13 @@ import UniqSet -- DEBUGGING ONLY --import OrdList -#ifdef NCG_DEBUG -import List ( intersperse ) -#endif - +import Data.List import Data.Int import Data.Word import Data.Bits import Data.Maybe import GHC.Exts +import Control.Monad {- The native-code generator has machine-independent and @@ -116,8 +115,8 @@ The machine-dependent bits break down as follows: -- NB. We *lazilly* compile each block of code for space reasons. -------------------- -nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc -nativeCodeGen dflags cmms us +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)) @@ -130,49 +129,7 @@ nativeCodeGen dflags cmms us in case res of { (dump, insn_sdoc, imports) -> do - -- stripe across the outputs for each block so all the information for a - -- certain stage is concurrent in the dumps. - - 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) - - dumpIfSet_dyn dflags - Opt_D_dump_asm_liveness "(asm-liveness) Liveness info added" - (vcat $ map (ppr . cdLiveness) dump) - - dumpIfSet_dyn dflags - Opt_D_dump_asm_coalesce "(asm-coalesce) Register moves coalesced." - (vcat $ map (ppr . cdCoalesce) dump) - - 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 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 - + cmmNativeGenDump dflags mod modLocation dump return (insn_sdoc Pretty.$$ dyld_stubs imports @@ -255,8 +212,8 @@ data CmmNativeGenDump { cdCmmOpt :: RawCmmTop , cdNative :: [NatCmmTop] , cdLiveness :: [LiveCmmTop] - , cdCoalesce :: [LiveCmmTop] - , cdRegAllocStats :: [RegAllocStats] + , cdCoalesce :: Maybe [LiveCmmTop] + , cdRegAllocStats :: Maybe [RegAllocStats] , cdColoredGraph :: Maybe (Color.Graph Reg RegClass Reg) , cdAlloced :: [NatCmmTop] } @@ -264,6 +221,9 @@ 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 -- | Complete native code generation phase for a single top-level chunk of Cmm. -- Unless they're being dumped, intermediate data structures are squashed after @@ -338,18 +298,21 @@ cmmNativeGen dflags cmm coalesced return ( alloced - , dchoose dflags Opt_D_dump_asm_regalloc alloced [] - , dchoose dflags Opt_D_dump_asm_coalesce coalesced [] - , dchoose dflags Opt_D_dump_asm_regalloc_stages regAllocStats [] - , dchoose dflags Opt_D_dump_asm_conflicts Nothing Nothing) + , 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 @@ -401,6 +364,78 @@ x86fp_kludge top@(CmmProc info lbl params code) = #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. +-- +cmmNativeGenDump :: DynFlags -> Module -> ModLocation -> [CmmNativeGenDump] -> IO () +cmmNativeGenDump dflags mod modLocation dump + = do + dumpIfSet_dyn dflags + Opt_D_dump_opt_cmm "Optimised Cmm" + (pprCmm $ Cmm $ map cdCmmOpt dump) + + dumpIfSet_dyn dflags + Opt_D_dump_asm_native "Native code" + (vcat $ map (docToSDoc . pprNatCmmTop) $ concatMap cdNative dump) + + dumpIfSet_dyn dflags + Opt_D_dump_asm_liveness "Liveness annotations added" + (vcat $ map (ppr . cdLiveness) dump) + + dumpIfSet_dyn dflags + Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced" + (vcat $ map (fromMaybe empty . liftM ppr . cdCoalesce) dump) + + dumpIfSet_dyn dflags + Opt_D_dump_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. + when (dopt Opt_D_dump_asm_regalloc_stages dflags) + $ do mapM_ (\stats + -> printDump + $ vcat $ map (\(stage, stats) -> + text "-- Stage " <> int stage + $$ ppr stats) + (zip [0..] stats)) + $ map (fromMaybe [] . 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 "Register conflict graph" + $ Color.dotGraph Color.regDotColor trivColorable + $ foldl Color.union Color.initGraph + $ catMaybes $ map cdColoredGraph dump + + -- Drop native code generator statistics. + -- This is potentially a large amount of information, and we want to be able + -- to collect it while running nofib. Drop a new file instead of emitting + -- it to stdout/stderr. + -- + 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 + + -- build a global conflict graph + let graph = foldl Color.union Color.initGraph $ map raGraph stats + + -- pretty print the various sections and write out the file. + let outSpills = pprStatsSpills stats + let outLife = pprStatsLifetimes stats + let outConflict = pprStatsConflict stats + let outScatter = pprStatsLifeConflict stats graph + + writeFile dropFile + (showSDoc $ vcat [outSpills, outLife, outConflict, outScatter]) + + return () + -- ----------------------------------------------------------------------------- -- Sequencing the basic blocks