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 )
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
-- NB. We *lazilly* compile each block of code for space reasons.
-nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
+--------------------
+nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
nativeCodeGen dflags cmms us
- = let (res, _) = initUs us $
- cgCmm (concat (map add_split cmms))
-
- cgCmm :: [CmmTop] -> UniqSM (Cmm, 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.
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 -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
-cmmNativeGen dflags cmm
- = {-# SCC "fixAssigns" #-}
- fixAssignsTop cmm `thenUs` \ fixed_cmm ->
- {-# SCC "genericOpt" #-}
- cmmToCmm 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 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
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
-genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
+genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
-genMachCode cmm_top
+genMachCode dflags cmm_top
= do { initial_us <- getUs
- ; let initial_st = mkNatM_State initial_us 0
+ ; let initial_st = mkNatM_State initial_us 0 dflags
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
- final_us = natm_us final_st
final_delta = natm_delta final_st
final_imports = natm_imports final_st
; if final_delta == 0
-- the generic optimiser below, to avoid having two separate passes
-- over the Cmm.
-fixAssignsTop :: CmmTop -> UniqSM CmmTop
+fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
fixAssignsTop top@(CmmData _ _) = returnUs top
fixAssignsTop (CmmProc info lbl params blocks) =
mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
returnUs (concat stmtss)
fixAssign :: CmmStmt -> UniqSM [CmmStmt]
-fixAssign (CmmAssign (CmmGlobal BaseReg) src)
- = panic "cmmStmtConFold: assignment to BaseReg";
-
fixAssign (CmmAssign (CmmGlobal reg) src)
| Left realreg <- reg_or_addr
= returnUs [CmmAssign (CmmGlobal reg) src]
where
reg_or_addr = get_GlobalReg_reg_or_addr reg
-{-
-fixAssign (CmmCall target results args)
- = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
- returnUs (CmmCall target results' args :
- concat stores)
- where
- fixResult g@(CmmGlobal reg,hint) =
- case get_GlobalReg_reg_or_addr reg of
- Left realreg -> returnUs (g, [])
- Right baseRegAddr ->
- getUniqueUs `thenUs` \ uq ->
- let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
- returnUs ((local,hint),
- [CmmStore baseRegAddr (CmmReg local)])
- fixResult other =
- returnUs (other,[])
--}
-
fixAssign other_stmt = returnUs [other_stmt]
-- -----------------------------------------------------------------------------
temp assignments, and certain assigns to mem...)
-}
-cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
-cmmToCmm top@(CmmData _ _) = (top, [])
-cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
+cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
+cmmToCmm _ top@(CmmData _ _) = (top, [])
+cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
return $ CmmProc info lbl params blocks'
-newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
+newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
instance Monad CmmOptM where
- return x = CmmOptM $ \imports -> (# x,imports #)
+ return x = CmmOptM $ \(imports, _) -> (# x,imports #)
(CmmOptM f) >>= g =
- CmmOptM $ \imports ->
- case f imports of
+ CmmOptM $ \(imports, dflags) ->
+ case f (imports, dflags) of
(# x, imports' #) ->
case g x of
- CmmOptM g' -> g' imports'
+ CmmOptM g' -> g' (imports', dflags)
addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
+
+getDynFlagsCmmOpt :: CmmOptM DynFlags
+getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
-runCmmOpt :: CmmOptM a -> (a, [CLabel])
-runCmmOpt (CmmOptM f) = case f [] of
+runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
+runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
(# result, imports #) -> (result, imports)
cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
-> 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
return $ cmmMachOpFold mop args'
CmmLit (CmmLabel lbl)
- -> cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
+ -> do
+ dflags <- getDynFlagsCmmOpt
+ cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
- -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt referenceKind lbl
+ -> do
+ dflags <- getDynFlagsCmmOpt
+ dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold (MO_Add wordRep) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) wordRep)