X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=f256e5bf5d24a2041af9159460af237490266c05;hp=3036a7ac6a38cba99f2422a7be2e28dd7cfc9fd4;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=81b2276ff9434d97aff683218c34c86479a8d868 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 3036a7a..f256e5b 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -7,6 +7,13 @@ -- ----------------------------------------------------------------------------- \begin{code} +{-# OPTIONS_GHC -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- for details + module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" @@ -16,16 +23,22 @@ import MachInstrs import MachRegs import MachCodeGen import PprMach -import RegisterAlloc import RegAllocInfo import NCGMonad import PositionIndependentCode +import RegLiveness +import RegCoalesce +import qualified RegAllocLinear as Linear +import qualified RegAllocColor as Color +import qualified RegAllocStats as Color +import qualified GraphColor as Color import Cmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm ( pprStmt, pprCmms ) +import PprCmm ( pprStmt, pprCmms, pprCmm ) import MachOp import CLabel +import State import UniqFM import Unique ( Unique, getUnique ) @@ -37,23 +50,25 @@ import DynFlags import StaticFlags ( opt_Static, opt_PIC ) import Util import Config ( cProjectVersion ) +import Module import Digraph import qualified Pretty import Outputable import FastString +import UniqSet +import ErrUtils -- 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 @@ -108,21 +123,212 @@ 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 - = let (res, _) = initUs us $ - cgCmm (concat (map add_split cmms)) - - cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel]) - cgCmm tops = - lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results -> - case unzip3 results of { (cmms,docs,imps) -> - returnUs (Cmm cmms, my_vcat docs, concat imps) - } - in - case res of { (ppr_cmms, insn_sdoc, imports) -> do - dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms]) - return (insn_sdoc Pretty.$$ dyld_stubs imports + = do + -- do native code generation on all these cmm things + (us', result) + <- mapAccumLM (cmmNativeGen dflags) us + $ concat $ map add_split cmms + + let (native, imports, mColorStats, mLinearStats) + = unzip4 result + + -- 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 + + dumpIfSet_dyn dflags + Opt_D_dump_asm_conflicts "Register conflict graph" + $ Color.dotGraph Color.regDotColor trivColorable + $ graphGlobal) + + + -- 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 native) (concat stats)) + + return $ makeAsmDoc (concat native) (concat imports) + + where add_split (Cmm tops) + | dopt Opt_SplitObjs dflags = split_marker : tops + | otherwise = tops + + split_marker = CmmProc [] mkSplitMarkerLabel [] [] + + +-- | 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 + + -- cmm to cmm optimisations + let (opt_cmm, imports) = + cmmToCmm dflags fixed_cmm + + dumpIfSet_dyn dflags + Opt_D_dump_opt_cmm "Optimised Cmm" + (pprCmm $ Cmm [opt_cmm]) + + + -- generate native code from cmm + let ((native, lastMinuteImports), usGen) = + initUs usFix $ genMachCode dflags opt_cmm + + 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 = + {-# SCC "shortcutBranches" #-} + shortcutBranches dflags alloced + + ---- sequence blocks + let sequenced = + {-# SCC "sequenceBlocks" #-} + map sequenceTop shorted + + ---- x86fp_kludge + let final_mach_code = +#if i386_TARGET_ARCH + {-# SCC "x86fp_kludge" #-} + map x86fp_kludge sequenced +#else + sequenced +#endif + + return ( usAlloc + , ( final_mach_code + , lastMinuteImports ++ imports + , ppr_raStatsColor + , ppr_raStatsLinear) ) + + +#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) + where + bb_i386_insert_ffrees (BasicBlock id instrs) = + BasicBlock id (i386_insert_ffrees instrs) +#endif + + +-- | Build assembler source file from native code and its imports. +-- +makeAsmDoc :: [NatCmmTop] -> [CLabel] -> Pretty.Doc +makeAsmDoc native imports + = Pretty.vcat (map pprNatCmmTop native) + Pretty.$$ (Pretty.text "") + Pretty.$$ dyld_stubs imports + #if HAVE_SUBSECTIONS_VIA_SYMBOLS -- On recent versions of Darwin, the linker supports -- dead-stripping of code and data on a per-symbol basis. @@ -146,91 +352,31 @@ nativeCodeGen dflags cmms us in Pretty.text ".ident" Pretty.<+> Pretty.doubleQuotes compilerIdent #endif - ) - } - - where - - add_split (Cmm tops) - | dopt Opt_SplitObjs dflags = split_marker : tops - | otherwise = tops - split_marker = CmmProc [] mkSplitMarkerLabel [] [] - - -- Generate "symbol stubs" for all external symbols that might - -- come from a dynamic library. -{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $ + 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-} - + -- (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 + 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 -#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. - -cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel]) -cmmNativeGen dflags cmm - = {-# SCC "fixAssigns" #-} - fixAssignsTop cmm `thenUs` \ fixed_cmm -> - {-# SCC "genericOpt" #-} - cmmToCmm dflags fixed_cmm `bind` \ (cmm, imports) -> - (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance - then cmm - else CmmData Text []) `bind` \ ppr_cmm -> - {-# SCC "genMachCode" #-} - genMachCode dflags cmm `thenUs` \ (pre_regalloc, lastMinuteImports) -> - {-# SCC "regAlloc" #-} - mapUs regAlloc pre_regalloc `thenUs` \ with_regs -> - {-# SCC "shortcutBranches" #-} - shortcutBranches dflags with_regs `bind` \ shorted -> - {-# SCC "sequenceBlocks" #-} - map sequenceTop shorted `bind` \ sequenced -> - {-# SCC "x86fp_kludge" #-} - map x86fp_kludge sequenced `bind` \ final_mach_code -> - {-# SCC "vcat" #-} - Pretty.vcat (map pprNatCmmTop final_mach_code) `bind` \ final_sdoc -> - - returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports) - where - x86fp_kludge :: NatCmmTop -> NatCmmTop - x86fp_kludge top@(CmmData _ _) = top -#if i386_TARGET_ARCH - x86fp_kludge top@(CmmProc info lbl params code) = - CmmProc info lbl params (map bb_i386_insert_ffrees code) - where - bb_i386_insert_ffrees (BasicBlock id instrs) = - BasicBlock id (i386_insert_ffrees instrs) -#else - x86fp_kludge top = top -#endif -- ----------------------------------------------------------------------------- -- Sequencing the basic blocks @@ -517,16 +663,16 @@ cmmStmtConFold stmt -> do addr' <- cmmExprConFold JumpReference addr return $ CmmJump addr' regs - CmmCall target regs args srt + CmmCall target regs args srt returns -> do target' <- case target of - CmmForeignCall e conv -> do + CmmCallee e conv -> do e' <- cmmExprConFold CallReference e - return $ CmmForeignCall e' conv + return $ CmmCallee e' conv other -> return other args' <- mapM (\(arg, hint) -> do arg' <- cmmExprConFold DataReference arg return (arg', hint)) args - return $ CmmCall target' regs args' srt + return $ CmmCall target' regs args' srt returns CmmCondBranch test dest -> do test' <- cmmExprConFold DataReference test