X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=119e1181efc36b77526f13caf6c901f90e280717;hb=31a9d04804d9cacda35695c5397590516b964964;hp=29f4be42fe22413a9293e3954cea9a4a91edd74f;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69;p=ghc-hetmet.git diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 29f4be4..119e118 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -19,19 +19,56 @@ module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" #include "nativeGen/NCG.h" -import MachInstrs -import MachRegs -import MachCodeGen -import PprMach -import RegAllocInfo + +#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 TargetReg as Target + +import Platform +import Instruction +import PIC +import Reg 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 ) @@ -53,6 +90,7 @@ import Module import Digraph import qualified Pretty +import BufWrite import Outputable import FastString import UniqSet @@ -127,8 +165,12 @@ nativeCodeGen dflags h us cmms = do let split_cmms = concat $ map add_split cmms - (imports, prof) - <- cmmNativeGens dflags h us split_cmms [] [] 0 + -- 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 + bFlush bufh let (native, colorStats, linearStats) = unzip3 prof @@ -153,7 +195,7 @@ nativeCodeGen dflags h us cmms dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" - $ Color.dotGraph Color.regDotColor trivColorable + $ Color.dotGraph Target.targetRegDotColor (Color.trivColorable Target.targetRegClass) $ graphGlobal) @@ -165,7 +207,7 @@ nativeCodeGen dflags h us cmms -- write out the imports Pretty.printDoc Pretty.LeftMode h - $ makeImportsDoc (concat imports) + $ makeImportsDoc dflags (concat imports) return () @@ -186,7 +228,7 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count (us', native, imports, colorStats, linearStats) <- cmmNativeGen dflags us cmm count - Pretty.printDoc Pretty.LeftMode h + Pretty.bufLeftRender h $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native let lsPprNative = @@ -218,13 +260,13 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count cmmNativeGen :: DynFlags -> UniqSupply - -> RawCmmTop -- ^ the cmm to generate code for - -> Int -- ^ sequence number of this top thing + -> RawCmmTop -- ^ the cmm to generate code for + -> Int -- ^ sequence number of this top thing -> IO ( UniqSupply - , [NatCmmTop] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + , [NatCmmTop Instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats Instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators cmmNativeGen dflags us cmm count = do @@ -359,7 +401,7 @@ cmmNativeGen dflags us cmm count #if i386_TARGET_ARCH -x86fp_kludge :: NatCmmTop -> NatCmmTop +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) @@ -368,8 +410,8 @@ x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = -- | Build a doc for all the imports. -- -makeImportsDoc :: [CLabel] -> Pretty.Doc -makeImportsDoc imports +makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc +makeImportsDoc dflags imports = dyld_stubs imports #if HAVE_SUBSECTIONS_VIA_SYMBOLS @@ -403,13 +445,16 @@ makeImportsDoc imports {- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $ map head $ group $ sort imps-} + arch = platformArch $ targetPlatform dflags + os = platformOS $ targetPlatform dflags + -- (Hack) sometimes two Labels pretty-print the same, but have -- different uniques; so we compare their text versions... dyld_stubs imps - | needImportedSymbols + | needImportedSymbols arch os = Pretty.vcat $ - (pprGotDeclaration :) $ - map (pprImportedSymbol . fst . head) $ + (pprGotDeclaration arch os :) $ + map ( pprImportedSymbol arch os . fst . head) $ groupBy (\(_,a) (_,b) -> a == b) $ sortBy (\(_,a) (_,b) -> compare a b) $ map doPpr $ @@ -430,7 +475,10 @@ makeImportsDoc imports -- such that as many of the local jumps as possible turn into -- fallthroughs. -sequenceTop :: NatCmmTop -> NatCmmTop +sequenceTop + :: NatCmmTop Instr + -> NatCmmTop Instr + sequenceTop top@(CmmData _ _) = top sequenceTop (CmmProc info lbl params (ListGraph blocks)) = CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks) @@ -445,21 +493,36 @@ sequenceTop (CmmProc info lbl params (ListGraph blocks)) = -- FYI, the classic layout for basic blocks uses postorder DFS; this -- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007). -sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock] +sequenceBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [NatBasicBlock instr] + sequenceBlocks [] = [] sequenceBlocks (entry:blocks) = seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks))) -- the first block is the entry point ==> it must remain at the start. -sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])] + +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC ( NatBasicBlock instr + , Unique + , [Unique])] + sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks) -getOutEdges :: [Instr] -> [Unique] -getOutEdges instrs = case jumpDests (last instrs) [] of - [one] -> [getUnique one] - _many -> [] - -- we're only interested in the last instruction of - -- the block, and only if it has a single destination. +-- we're only interested in the last instruction of +-- the block, and only if it has a single destination. +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) @@ -487,7 +550,9 @@ reorder id accum (b@(block,id',out) : rest) -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too -- big, we have to work around this limitation. -makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock] +makeFarBranches + :: [NatBasicBlock Instr] + -> [NatBasicBlock Instr] #if powerpc_TARGET_ARCH makeFarBranches blocks @@ -523,7 +588,11 @@ makeFarBranches = id -- ----------------------------------------------------------------------------- -- Shortcut branches -shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop] +shortcutBranches + :: DynFlags + -> [NatCmmTop Instr] + -> [NatCmmTop Instr] + shortcutBranches dflags tops | optLevel dflags < 1 = tops -- only with -O or higher | otherwise = map (apply_mapping mapping) tops' @@ -582,12 +651,17 @@ apply_mapping ufm (CmmProc info lbl params (ListGraph blocks)) -- Switching between the two monads whilst carrying along the same -- Unique supply breaks abstraction. Is that bad? -genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel]) +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 cmm_top) + (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