-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
--
-- This is the top-level module in the native code generator.
--
-- -----------------------------------------------------------------------------
\begin{code}
module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
#if alpha_TARGET_ARCH
import Alpha.CodeGen
import Alpha.Regs
import Alpha.RegInfo
import Alpha.Instr
#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
import X86.CodeGen
import X86.Regs
import X86.RegInfo
import X86.Instr
import X86.Ppr
#elif sparc_TARGET_ARCH
import SPARC.CodeGen
import SPARC.Regs
import SPARC.Instr
import SPARC.Ppr
import SPARC.ShortcutJump
#elif powerpc_TARGET_ARCH
import PPC.CodeGen
import PPC.Cond
import PPC.Regs
import PPC.RegInfo
import PPC.Instr
import PPC.Ppr
#else
#error "AsmCodeGen: unknown architecture"
#endif
import RegAlloc.Liveness
import qualified RegAlloc.Linear.Main as Linear
import qualified GraphColor as Color
import qualified RegAlloc.Graph.Main as Color
import qualified RegAlloc.Graph.Stats as Color
import qualified RegAlloc.Graph.Coalesce as Color
import qualified RegAlloc.Graph.TrivColorable as Color
import qualified SPARC.CodeGen.Expand as SPARC
import TargetReg
import Platform
import Instruction
import PIC
import Reg
import RegClass
import NCGMonad
import BlockId
import CgUtils ( fixStgRegisters )
import Cmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
import PprCmm
import CLabel
import State
import UniqFM
import Unique ( Unique, getUnique )
import UniqSupply
import DynFlags
#if powerpc_TARGET_ARCH
import StaticFlags ( opt_Static, opt_PIC )
#endif
import Util
import Config ( cProjectVersion )
import Module
import Digraph
import qualified Pretty
import BufWrite
import Outputable
import FastString
import UniqSet
import ErrUtils
import Module
import Data.List
import Data.Int
import Data.Word
import Data.Bits
import Data.Maybe
import GHC.Exts
import Control.Monad
import System.IO
nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
nativeCodeGen dflags h us cmms
= do
let split_cmms = concat $ map add_split cmms
bufh <- newBufHandle h
(imports, prof) <- cmmNativeGens dflags bufh us split_cmms [] [] 0
bFlush bufh
let (native, colorStats, linearStats)
= unzip3 prof
dumpIfSet_dyn dflags
Opt_D_dump_asm "Asm code"
(vcat $ map (docToSDoc . pprNatCmmTop) $ concat native)
(case concat $ catMaybes colorStats of
[] -> return ()
stats -> do
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
targetRegDotColor
(Color.trivColorable
targetVirtualRegSqueeze
targetRealRegSqueeze)
$ graphGlobal)
(case concat $ catMaybes linearStats of
[] -> return ()
stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
$ Linear.pprStats (concat native) stats)
Pretty.printDoc Pretty.LeftMode h
$ makeImportsDoc dflags (concat imports)
return ()
where add_split (Cmm tops)
| dopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops
split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph [])
cmmNativeGens dflags h us [] impAcc profAcc count
= return (reverse impAcc, reverse profAcc)
cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
= do
(us', native, imports, colorStats, linearStats)
<- cmmNativeGen dflags us cmm count
Pretty.bufLeftRender h
$ Pretty.vcat $ map pprNatCmmTop native
lsPprNative <- return $!
if dopt Opt_D_dump_asm dflags
|| dopt Opt_D_dump_asm_stats dflags
then native
else []
count' <- return $! count + 1;
seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
cmmNativeGens dflags h us' cmms
(imports : impAcc)
((lsPprNative, colorStats, linearStats) : profAcc)
count'
where seqString [] = ()
seqString (x:xs) = x `seq` seqString xs `seq` ()
cmmNativeGen
:: DynFlags
-> UniqSupply
-> RawCmmTop
-> Int
-> IO ( UniqSupply
, [NatCmmTop Instr]
, [CLabel]
, Maybe [Color.RegAllocStats Instr]
, Maybe [Linear.RegAllocStats])
cmmNativeGen dflags us cmm count
= do
let fixed_cmm =
fixStgRegisters cmm
let (opt_cmm, imports) =
cmmToCmm dflags fixed_cmm
dumpIfSet_dyn dflags
Opt_D_dump_opt_cmm "Optimised Cmm"
(pprCmm $ Cmm [opt_cmm])
let ((native, lastMinuteImports), usGen) =
initUs us $ genMachCode dflags opt_cmm
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
(vcat $ map (docToSDoc . pprNatCmmTop) native)
let (withLiveness, usLive) =
initUs usGen
$ mapUs regLiveness
$ map natCmmTopToLive native
dumpIfSet_dyn dflags
Opt_D_dump_asm_liveness "Liveness annotations added"
(vcat $ map ppr withLiveness)
(alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
if ( dopt Opt_RegsGraph dflags
|| dopt Opt_RegsIterative dflags)
then do
let (alloc_regs :: UniqFM (UniqSet RealReg))
= foldr (\r -> plusUFM_C unionUniqSets
$ unitUFM (targetClassOfRealReg r) (unitUniqSet r))
emptyUFM
$ allocatableRegs
let ((alloced, regAllocStats), usAlloc)
=
initUs usLive
$ Color.regAlloc
dflags
alloc_regs
(mkUniqSet [0..maxSpillSlots])
withLiveness
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 "# --------------------------"
$$ text "# cmm " <> int count <> text " Stage " <> int stage
$$ ppr stats)
$ zip [0..] regAllocStats)
let mPprStats =
if dopt Opt_D_dump_asm_stats dflags
then Just regAllocStats else Nothing
mPprStats `seq` return ()
return ( alloced, usAlloc
, mPprStats
, Nothing)
else do
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)
let mPprStats =
if dopt Opt_D_dump_asm_stats dflags
then Just (catMaybes regAllocStats) else Nothing
mPprStats `seq` return ()
return ( alloced, usAlloc
, Nothing
, mPprStats)
let shorted =
shortcutBranches dflags alloced
let sequenced =
map sequenceTop shorted
let kludged =
#if i386_TARGET_ARCH
map x86fp_kludge sequenced
#else
sequenced
#endif
#if sparc_TARGET_ARCH
let expanded =
map SPARC.expandTop kludged
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
(vcat $ map (docToSDoc . pprNatCmmTop) expanded)
#else
let expanded =
kludged
#endif
return ( usAlloc
, expanded
, lastMinuteImports ++ imports
, ppr_raStatsColor
, ppr_raStatsLinear)
#if i386_TARGET_ARCH
x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) =
CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
#endif
makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc
makeImportsDoc dflags imports
= dyld_stubs imports
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
Pretty.$$ Pretty.text ".subsections_via_symbols"
#endif
#if HAVE_GNU_NONEXEC_STACK
Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
#endif
#if !defined(darwin_TARGET_OS)
Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
Pretty.text cProjectVersion
in Pretty.text ".ident" Pretty.<+>
Pretty.doubleQuotes compilerIdent
#endif
where
dyld_stubs :: [CLabel] -> Pretty.Doc
arch = platformArch $ targetPlatform dflags
os = platformOS $ targetPlatform dflags
dyld_stubs imps
| needImportedSymbols arch os
= Pretty.vcat $
(pprGotDeclaration arch os :) $
map ( pprImportedSymbol arch os . 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
sequenceTop
:: NatCmmTop Instr
-> NatCmmTop Instr
sequenceTop top@(CmmData _ _) = top
sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
sequenceBlocks
:: Instruction instr
=> [NatBasicBlock instr]
-> [NatBasicBlock instr]
sequenceBlocks [] = []
sequenceBlocks (entry:blocks) =
seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
sccBlocks
:: Instruction instr
=> [NatBasicBlock instr]
-> [SCC ( NatBasicBlock instr
, Unique
, [Unique])]
sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
getOutEdges
:: Instruction instr
=> [instr] -> [Unique]
getOutEdges instrs
= case jumpDestsOfInstr (last instrs) of
[one] -> [getUnique one]
_many -> []
mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
seqBlocks [] = []
seqBlocks ((block,_,[]) : rest)
= block : seqBlocks rest
seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
| can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
| otherwise = block : seqBlocks rest'
where
(can_fallthrough, rest') = reorder next [] rest
seqBlocks _ = panic "AsmCodegen:seqBlocks"
reorder id accum [] = (False, reverse accum)
reorder id accum (b@(block,id',out) : rest)
| id == id' = (True, (block,id,out) : reverse accum ++ rest)
| otherwise = reorder id (b:accum) rest
makeFarBranches
:: [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
#if powerpc_TARGET_ARCH
makeFarBranches blocks
| last blockAddresses < nearLimit = blocks
| otherwise = zipWith handleBlock blockAddresses blocks
where
blockAddresses = scanl (+) 0 $ map blockLen blocks
blockLen (BasicBlock _ instrs) = length instrs
handleBlock addr (BasicBlock id instrs)
= BasicBlock id (zipWith makeFar [addr..] instrs)
makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt
makeFar addr (BCC cond tgt)
| abs (addr targetAddr) >= nearLimit
= BCCFAR cond tgt
| otherwise
= BCC cond tgt
where Just targetAddr = lookupUFM blockAddressMap tgt
makeFar _ other = other
nearLimit = 7000
blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
#else
makeFarBranches = id
#endif
shortcutBranches
:: DynFlags
-> [NatCmmTop Instr]
-> [NatCmmTop Instr]
shortcutBranches dflags tops
| optLevel dflags < 1 = tops
| otherwise = map (apply_mapping mapping) tops'
where
(tops', mappings) = mapAndUnzip build_mapping tops
mapping = foldr plusUFM emptyUFM mappings
build_mapping top@(CmmData _ _) = (top, emptyUFM)
build_mapping (CmmProc info lbl params (ListGraph []))
= (CmmProc info lbl params (ListGraph []), emptyUFM)
build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
= (CmmProc info lbl params (ListGraph (head:others)), mapping)
where
(_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
| Just (DestBlockId dest) <- canShortcut insn,
(elemBlockSet dest s) || dest == id
= (s, shortcut_blocks, b : others)
split (s, shortcut_blocks, others) (BasicBlock id [insn])
| Just dest <- canShortcut insn
= (extendBlockSet s id, (id,dest) : shortcut_blocks, others)
split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
mapping = foldl add emptyUFM shortcut_blocks
add ufm (id,dest) = addToUFM ufm id dest
apply_mapping ufm (CmmData sec statics)
= CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
= CmmProc info lbl params (ListGraph $ map short_bb blocks)
where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
short_insn i = shortcutJump (lookupUFM ufm) i
genMachCode
:: DynFlags
-> RawCmmTop
-> UniqSM
( [NatCmmTop Instr]
, [CLabel])
genMachCode dflags cmm_top
= do { initial_us <- getUs
; let initial_st = mkNatM_State initial_us 0 dflags
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top)
final_delta = natm_delta final_st
final_imports = natm_imports final_st
; if final_delta == 0
then return (new_tops, final_imports)
else pprPanic "genMachCode: nonzero final delta" (int final_delta)
}
cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
return $ CmmProc info lbl params (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
instance Monad CmmOptM where
return x = CmmOptM $ \(imports, _) -> (# x,imports #)
(CmmOptM f) >>= g =
CmmOptM $ \(imports, dflags) ->
case f (imports, dflags) of
(# x, imports' #) ->
case g x of
CmmOptM g' -> g' (imports', dflags)
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
getDynFlagsCmmOpt :: CmmOptM DynFlags
getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
(# result, imports #) -> (result, imports)
cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
cmmBlockConFold (BasicBlock id stmts) = do
stmts' <- mapM cmmStmtConFold stmts
return $ BasicBlock id stmts'
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
-> do src' <- cmmExprConFold DataReference src
return $ case src' of
CmmReg reg' | reg == reg' -> CmmNop
new_src -> CmmAssign reg new_src
CmmStore addr src
-> do addr' <- cmmExprConFold DataReference addr
src' <- cmmExprConFold DataReference src
return $ CmmStore addr' src'
CmmJump addr regs
-> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' regs
CmmCall target regs args srt returns
-> do target' <- case target of
CmmCallee e conv -> do
e' <- cmmExprConFold CallReference e
return $ CmmCallee e' conv
other -> return other
args' <- mapM (\(CmmHinted arg hint) -> do
arg' <- cmmExprConFold DataReference arg
return (CmmHinted arg' hint)) args
return $ CmmCall target' regs args' srt returns
CmmCondBranch test dest
-> do test' <- cmmExprConFold DataReference test
return $ case test' of
CmmLit (CmmInt 0 _) ->
CmmComment (mkFastString ("deleted: " ++
showSDoc (pprStmt stmt)))
CmmLit (CmmInt n _) -> CmmBranch dest
other -> CmmCondBranch test' dest
CmmSwitch expr ids
-> do expr' <- cmmExprConFold DataReference expr
return $ CmmSwitch expr' ids
other
-> return other
cmmExprConFold referenceKind expr
= case expr of
CmmLoad addr rep
-> do addr' <- cmmExprConFold DataReference addr
return $ CmmLoad addr' rep
CmmMachOp mop args
-> do args' <- mapM (cmmExprConFold DataReference) args
return $ cmmMachOpFold mop args'
CmmLit (CmmLabel lbl)
-> do
dflags <- getDynFlagsCmmOpt
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
dflags <- getDynFlagsCmmOpt
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold (MO_Add wordWidth) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) wordWidth)
]
#if powerpc_TARGET_ARCH
CmmReg (CmmGlobal EagerBlackholeInfo)
| not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
| not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| not opt_PIC
-> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
#endif
other
-> return other
\end{code}