#include "nativeGen/NCG.h"
-#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
-import X86.CodeGen
-import X86.Regs
-import X86.Instr
-import X86.Ppr
-
-#elif sparc_TARGET_ARCH
-import SPARC.CodeGen
-import SPARC.CodeGen.Expand
-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 qualified X86.CodeGen
+import qualified X86.Regs
+import qualified X86.Instr
+import qualified X86.Ppr
+
+import qualified SPARC.CodeGen
+import qualified SPARC.Regs
+import qualified SPARC.Instr
+import qualified SPARC.Ppr
+import qualified SPARC.ShortcutJump
+import qualified SPARC.CodeGen.Expand
+
+import qualified PPC.CodeGen
+import qualified PPC.Cond
+import qualified PPC.Regs
+import qualified PPC.RegInfo
+import qualified PPC.Instr
+import qualified PPC.Ppr
import RegAlloc.Liveness
import qualified RegAlloc.Linear.Main as Linear
import TargetReg
import Platform
+import Config
import Instruction
import PIC
import Reg
import DynFlags
import StaticFlags
import Util
-import Config
import Digraph
+import Pretty (Doc)
import qualified Pretty
import BufWrite
import Outputable
-- -----------------------------------------------------------------------------
-- Top-level of the native codegen
+data NcgImpl instr jumpDest = NcgImpl {
+ cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop instr],
+ generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr),
+ getJumpDestBlockId :: jumpDest -> Maybe BlockId,
+ canShortcut :: instr -> Maybe jumpDest,
+ shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic,
+ shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
+ pprNatCmmTop :: NatCmmTop instr -> Doc,
+ maxSpillSlots :: Int,
+ allocatableRegs :: [RealReg],
+ ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr],
+ ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr],
+ ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr]
+ }
+
--------------------
nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
nativeCodeGen dflags h us cmms
+ = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
+ x86NcgImpl = NcgImpl {
+ cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
+ ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
+ ,canShortcut = X86.Instr.canShortcut
+ ,shortcutStatic = X86.Instr.shortcutStatic
+ ,shortcutJump = X86.Instr.shortcutJump
+ ,pprNatCmmTop = X86.Ppr.pprNatCmmTop
+ ,maxSpillSlots = X86.Instr.maxSpillSlots
+ ,allocatableRegs = X86.Regs.allocatableRegs
+ ,ncg_x86fp_kludge = id
+ ,ncgExpandTop = id
+ ,ncgMakeFarBranches = id
+ }
+ in case platformArch $ targetPlatform dflags of
+ ArchX86 -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge })
+ ArchX86_64 -> nCG' x86NcgImpl
+ ArchPPC ->
+ nCG' $ NcgImpl {
+ cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
+ ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
+ ,canShortcut = PPC.RegInfo.canShortcut
+ ,shortcutStatic = PPC.RegInfo.shortcutStatic
+ ,shortcutJump = PPC.RegInfo.shortcutJump
+ ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop
+ ,maxSpillSlots = PPC.Instr.maxSpillSlots
+ ,allocatableRegs = PPC.Regs.allocatableRegs
+ ,ncg_x86fp_kludge = id
+ ,ncgExpandTop = id
+ ,ncgMakeFarBranches = makeFarBranches
+ }
+ ArchSPARC ->
+ nCG' $ NcgImpl {
+ cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
+ ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
+ ,canShortcut = SPARC.ShortcutJump.canShortcut
+ ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic
+ ,shortcutJump = SPARC.ShortcutJump.shortcutJump
+ ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop
+ ,maxSpillSlots = SPARC.Instr.maxSpillSlots
+ ,allocatableRegs = SPARC.Regs.allocatableRegs
+ ,ncg_x86fp_kludge = id
+ ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
+ ,ncgMakeFarBranches = id
+ }
+ ArchPPC_64 ->
+ panic "nativeCodeGen: No NCG for PPC 64"
+ ArchUnknown ->
+ panic "nativeCodeGen: No NCG for unknown arch"
+
+nativeCodeGen' :: (Instruction instr, Outputable instr)
+ => DynFlags
+ -> NcgImpl instr jumpDest
+ -> Handle -> UniqSupply -> [RawCmm] -> IO ()
+nativeCodeGen' dflags ncgImpl h us cmms
= do
let split_cmms = concat $ map add_split cmms
-
-- BufHandle is a performance hack. We could hide it inside
-- Pretty if it weren't for the fact that we do lots of little
-- printDocs here (in order to do codegen in constant space).
bufh <- newBufHandle h
- (imports, prof) <- cmmNativeGens dflags bufh us split_cmms [] [] 0
+ (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
bFlush bufh
let (native, colorStats, linearStats)
-- dump native code
dumpIfSet_dyn dflags
Opt_D_dump_asm "Asm code"
- (vcat $ map (docToSDoc . pprNatCmmTop) $ concat native)
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) $ concat native)
-- dump global NCG stats for graph coloring allocator
(case concat $ catMaybes colorStats of
-- | Do native code generation on all these cmms.
--
-cmmNativeGens :: DynFlags
+cmmNativeGens :: (Instruction instr, Outputable instr)
+ => DynFlags
+ -> NcgImpl instr jumpDest
-> BufHandle
-> UniqSupply
-> [RawCmmTop]
-> [[CLabel]]
- -> [ ([NatCmmTop Instr],
- Maybe [Color.RegAllocStats Instr],
+ -> [ ([NatCmmTop instr],
+ Maybe [Color.RegAllocStats instr],
Maybe [Linear.RegAllocStats]) ]
-> Int
-> IO ( [[CLabel]],
- [([NatCmmTop Instr],
- Maybe [Color.RegAllocStats Instr],
+ [([NatCmmTop instr],
+ Maybe [Color.RegAllocStats instr],
Maybe [Linear.RegAllocStats])] )
-cmmNativeGens _ _ _ [] impAcc profAcc _
+cmmNativeGens _ _ _ _ [] impAcc profAcc _
= return (reverse impAcc, reverse profAcc)
-cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
+cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
= do
(us', native, imports, colorStats, linearStats)
- <- cmmNativeGen dflags us cmm count
+ <- cmmNativeGen dflags ncgImpl us cmm count
Pretty.bufLeftRender h
- $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
+ $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl) native
-- carefully evaluate this strictly. Binding it with 'let'
-- and then using 'seq' doesn't work, because the let
-- force evaulation all this stuff to avoid space leaks
seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
- cmmNativeGens dflags h us' cmms
+ cmmNativeGens dflags ncgImpl
+ h us' cmms
(imports : impAcc)
((lsPprNative, colorStats, linearStats) : profAcc)
count'
-- | 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
+cmmNativeGen
+ :: (Instruction instr, Outputable instr)
+ => DynFlags
+ -> NcgImpl instr jumpDest
-> UniqSupply
-> RawCmmTop -- ^ the cmm to generate code for
-> Int -- ^ sequence number of this top thing
-> IO ( UniqSupply
- , [NatCmmTop Instr] -- native code
+ , [NatCmmTop instr] -- native code
, [CLabel] -- things imported by this cmm
- , Maybe [Color.RegAllocStats Instr] -- stats for the coloring register allocator
+ , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator
, Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
-cmmNativeGen dflags us cmm count
+cmmNativeGen dflags ncgImpl us cmm count
= do
-- rewrite assignments to global regs
-- generate native code from cmm
let ((native, lastMinuteImports), usGen) =
{-# SCC "genMachCode" #-}
- initUs us $ genMachCode dflags opt_cmm
+ initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
dumpIfSet_dyn dflags
Opt_D_dump_asm_native "Native code"
- (vcat $ map (docToSDoc . pprNatCmmTop) native)
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) native)
-- tag instructions with register liveness information
let (withLiveness, usLive) =
= foldr (\r -> plusUFM_C unionUniqSets
$ unitUFM (targetClassOfRealReg r) (unitUniqSet r))
emptyUFM
- $ allocatableRegs
+ $ allocatableRegs ncgImpl
-- do the graph coloring register allocation
let ((alloced, regAllocStats), usAlloc)
$ Color.regAlloc
dflags
alloc_regs
- (mkUniqSet [0..maxSpillSlots])
+ (mkUniqSet [0 .. maxSpillSlots ncgImpl])
withLiveness
-- dump out what happened during register allocation
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
- (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc_stages "Build/spill stages"
= {-# SCC "RegAlloc" #-}
initUs usLive
$ liftM unzip
- $ mapUs Linear.regAlloc withLiveness
+ $ mapUs (Linear.regAlloc dflags) withLiveness
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
- (vcat $ map (docToSDoc . pprNatCmmTop) alloced)
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
let mPprStats =
if dopt Opt_D_dump_asm_stats dflags
----
---- NB. must happen before shortcutBranches, because that
---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
- let kludged =
-#if i386_TARGET_ARCH
- {-# SCC "x86fp_kludge" #-}
- map x86fp_kludge alloced
-#else
- alloced
-#endif
+ let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
---- generate jump tables
let tabled =
{-# SCC "generateJumpTables" #-}
- generateJumpTables kludged
+ generateJumpTables ncgImpl kludged
---- shortcut branches
let shorted =
{-# SCC "shortcutBranches" #-}
- shortcutBranches dflags tabled
+ shortcutBranches dflags ncgImpl tabled
---- sequence blocks
let sequenced =
{-# SCC "sequenceBlocks" #-}
- map sequenceTop shorted
+ map (sequenceTop ncgImpl) shorted
---- expansion of SPARC synthetic instrs
-#if sparc_TARGET_ARCH
let expanded =
{-# SCC "sparc_expand" #-}
- map expandTop sequenced
+ ncgExpandTop ncgImpl sequenced
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
- (vcat $ map (docToSDoc . pprNatCmmTop) expanded)
-#else
- let expanded =
- sequenced
-#endif
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) expanded)
return ( usAlloc
, expanded
, ppr_raStatsLinear)
-#if i386_TARGET_ARCH
-x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
+x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr
x86fp_kludge top@(CmmData _ _) = top
x86fp_kludge (CmmProc info lbl (ListGraph code)) =
- CmmProc info lbl (ListGraph $ i386_insert_ffrees code)
-#endif
+ CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
-- | Build a doc for all the imports.
-- 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.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
Pretty.text cProjectVersion
in Pretty.text ".ident" Pretty.<+>
Pretty.doubleQuotes compilerIdent
-#endif
where
-- Generate "symbol stubs" for all external symbols that might
| otherwise
= Pretty.empty
- doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+ doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
astyle = mkCodeStyle AsmStyle
-- fallthroughs.
sequenceTop
- :: NatCmmTop Instr
- -> NatCmmTop Instr
+ :: Instruction instr
+ => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr
-sequenceTop top@(CmmData _ _) = top
-sequenceTop (CmmProc info lbl (ListGraph blocks)) =
- CmmProc info lbl (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
+sequenceTop _ top@(CmmData _ _) = top
+sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
+ CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
-- The algorithm is very simple (and stupid): we make a graph out of
-- the blocks where there is an edge from one block to another iff the
-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
-- big, we have to work around this limitation.
-makeFarBranches
- :: [NatBasicBlock Instr]
- -> [NatBasicBlock Instr]
-
-#if powerpc_TARGET_ARCH
+makeFarBranches
+ :: [NatBasicBlock PPC.Instr.Instr]
+ -> [NatBasicBlock PPC.Instr.Instr]
makeFarBranches blocks
| last blockAddresses < nearLimit = blocks
| otherwise = zipWith handleBlock blockAddresses blocks
handleBlock addr (BasicBlock id instrs)
= BasicBlock id (zipWith makeFar [addr..] instrs)
- makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt
- makeFar addr (BCC cond tgt)
+ makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
+ makeFar addr (PPC.Instr.BCC cond tgt)
| abs (addr - targetAddr) >= nearLimit
- = BCCFAR cond tgt
+ = PPC.Instr.BCCFAR cond tgt
| otherwise
- = BCC cond tgt
+ = PPC.Instr.BCC cond tgt
where Just targetAddr = lookupUFM blockAddressMap tgt
makeFar _ other = other
-- things exactly
blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
-#else
-makeFarBranches = id
-#endif
-- -----------------------------------------------------------------------------
-- Generate jump tables
-- Analyzes all native code and generates data sections for all jump
-- table instructions.
generateJumpTables
- :: [NatCmmTop Instr] -> [NatCmmTop Instr]
-generateJumpTables xs = concatMap f xs
+ :: NcgImpl instr jumpDest
+ -> [NatCmmTop instr] -> [NatCmmTop instr]
+generateJumpTables ncgImpl xs = concatMap f xs
where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
f p = [p]
- g (BasicBlock _ xs) = catMaybes (map generateJumpTableForInstr xs)
+ g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
-- -----------------------------------------------------------------------------
-- Shortcut branches
-shortcutBranches
- :: DynFlags
- -> [NatCmmTop Instr]
- -> [NatCmmTop Instr]
+shortcutBranches
+ :: DynFlags
+ -> NcgImpl instr jumpDest
+ -> [NatCmmTop instr]
+ -> [NatCmmTop instr]
-shortcutBranches dflags tops
+shortcutBranches dflags ncgImpl tops
| optLevel dflags < 1 = tops -- only with -O or higher
- | otherwise = map (apply_mapping mapping) tops'
+ | otherwise = map (apply_mapping ncgImpl mapping) tops'
where
- (tops', mappings) = mapAndUnzip build_mapping tops
+ (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
mapping = foldr plusUFM emptyUFM mappings
-build_mapping :: GenCmmTop d t (ListGraph Instr)
- -> (GenCmmTop d t (ListGraph Instr), UniqFM JumpDest)
-build_mapping top@(CmmData _ _) = (top, emptyUFM)
-build_mapping (CmmProc info lbl (ListGraph []))
+build_mapping :: NcgImpl instr jumpDest
+ -> GenCmmTop d t (ListGraph instr)
+ -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest)
+build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
+build_mapping _ (CmmProc info lbl (ListGraph []))
= (CmmProc info lbl (ListGraph []), emptyUFM)
-build_mapping (CmmProc info lbl (ListGraph (head:blocks)))
+build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
= (CmmProc info lbl (ListGraph (head:others)), mapping)
-- drop the shorted blocks, but don't ever drop the first one,
-- because it is pointed to by a global label.
-- Don't completely eliminate loops here -- that can leave a dangling jump!
(_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
- | Just (DestBlockId dest) <- canShortcut insn,
+ | Just jd <- canShortcut ncgImpl insn,
+ Just dest <- getJumpDestBlockId ncgImpl jd,
(setMember dest s) || dest == id -- loop checks
= (s, shortcut_blocks, b : others)
split (s, shortcut_blocks, others) (BasicBlock id [insn])
- | Just dest <- canShortcut insn
+ | Just dest <- canShortcut ncgImpl insn
= (setInsert id s, (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 :: UniqFM JumpDest
- -> GenCmmTop CmmStatic h (ListGraph Instr)
- -> GenCmmTop CmmStatic h (ListGraph Instr)
-apply_mapping ufm (CmmData sec statics)
- = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
+apply_mapping :: NcgImpl instr jumpDest
+ -> UniqFM jumpDest
+ -> GenCmmTop CmmStatic h (ListGraph instr)
+ -> GenCmmTop CmmStatic h (ListGraph instr)
+apply_mapping ncgImpl ufm (CmmData sec statics)
+ = CmmData sec (map (shortcutStatic ncgImpl (lookupUFM ufm)) statics)
-- we need to get the jump tables, so apply the mapping to the entries
-- of a CmmData too.
-apply_mapping ufm (CmmProc info lbl (ListGraph blocks))
+apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
= CmmProc info lbl (ListGraph $ map short_bb blocks)
where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
- short_insn i = shortcutJump (lookupUFM ufm) i
+ short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
-- shortcutJump should apply the mapping repeatedly,
-- just in case we can short multiple branches.
genMachCode
:: DynFlags
+ -> (RawCmmTop -> NatM [NatCmmTop instr])
-> RawCmmTop
-> UniqSM
- ( [NatCmmTop Instr]
+ ( [NatCmmTop instr]
, [CLabel])
-genMachCode dflags cmm_top
+genMachCode dflags cmmTopCodeGen 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)
+ (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
final_delta = natm_delta final_st
final_imports = natm_imports final_st
; if final_delta == 0
projects / ghc-hetmet.git / blobdiff