X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=57faa6ff0efc14d72b3a83a1a936d3c61bf48e36;hp=0761946be2069024d170874eff49d2e4c0e5b078;hb=2d4d636af091b8da27466b5cf90011395a9c2f66;hpb=9a47b3820b1cb381ce1dc94fe25fac600c4d10a5 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 0761946..57faa6f 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -13,13 +13,7 @@ module AsmCodeGen ( nativeCodeGen ) where #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 +#if i386_TARGET_ARCH || x86_64_TARGET_ARCH import X86.CodeGen import X86.Regs import X86.Instr @@ -56,6 +50,7 @@ import qualified RegAlloc.Graph.TrivColorable as Color import TargetReg import Platform +import Config import Instruction import PIC import Reg @@ -63,20 +58,17 @@ import NCGMonad import BlockId import CgUtils ( fixStgRegisters ) -import Cmm -import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm +import OldCmm +import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) +import OldPprCmm import CLabel import UniqFM import Unique ( Unique, getUnique ) import UniqSupply import DynFlags -#if powerpc_TARGET_ARCH -import StaticFlags ( opt_Static, opt_PIC ) -#endif +import StaticFlags import Util -import Config ( cProjectVersion ) import Digraph import qualified Pretty @@ -85,6 +77,7 @@ import Outputable import FastString import UniqSet import ErrUtils +import Module -- DEBUGGING ONLY --import OrdList @@ -205,7 +198,7 @@ nativeCodeGen dflags h us cmms | dopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph []) + split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph []) -- | Do native code generation on all these cmms. @@ -378,37 +371,48 @@ cmmNativeGen dflags us cmm count , Nothing , mPprStats) + ---- x86fp_kludge. This pass inserts ffree instructions to clear + ---- the FPU stack on x86. The x86 ABI requires that the FPU stack + ---- is clear, and library functions can return odd results if it + ---- isn't. + ---- + ---- 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 + + ---- generate jump tables + let tabled = + {-# SCC "generateJumpTables" #-} + generateJumpTables kludged + ---- shortcut branches let shorted = {-# SCC "shortcutBranches" #-} - shortcutBranches dflags alloced + shortcutBranches dflags tabled ---- sequence blocks let sequenced = {-# SCC "sequenceBlocks" #-} map sequenceTop shorted - ---- x86fp_kludge - let kludged = -#if i386_TARGET_ARCH - {-# SCC "x86fp_kludge" #-} - map x86fp_kludge sequenced -#else - sequenced -#endif - - ---- expansion of SPARC synthetic instrs + ---- expansion of SPARC synthetic instrs #if sparc_TARGET_ARCH let expanded = {-# SCC "sparc_expand" #-} - map expandTop kludged + map expandTop sequenced dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" (vcat $ map (docToSDoc . pprNatCmmTop) expanded) #else let expanded = - kludged + sequenced #endif return ( usAlloc @@ -421,8 +425,8 @@ cmmNativeGen dflags us cmm count #if i386_TARGET_ARCH x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge (CmmProc info lbl params (ListGraph code)) = - CmmProc info lbl params (ListGraph $ i386_insert_ffrees code) +x86fp_kludge (CmmProc info lbl (ListGraph code)) = + CmmProc info lbl (ListGraph $ i386_insert_ffrees code) #endif @@ -447,14 +451,12 @@ makeImportsDoc dflags 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 @@ -480,7 +482,7 @@ makeImportsDoc dflags imports | otherwise = Pretty.empty - doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle) + doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle) astyle = mkCodeStyle AsmStyle @@ -498,8 +500,8 @@ sequenceTop -> NatCmmTop Instr sequenceTop top@(CmmData _ _) = top -sequenceTop (CmmProc info lbl params (ListGraph blocks)) = - CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks) +sequenceTop (CmmProc info lbl (ListGraph blocks)) = + CmmProc info lbl (ListGraph $ makeFarBranches $ 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 @@ -509,7 +511,7 @@ sequenceTop (CmmProc info lbl params (ListGraph blocks)) = -- destination of the out edge to the front of the list, and continue. -- FYI, the classic layout for basic blocks uses postorder DFS; this --- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007). +-- algorithm is implemented in Hoopl. sequenceBlocks :: Instruction instr @@ -588,14 +590,14 @@ makeFarBranches blocks handleBlock addr (BasicBlock id instrs) = BasicBlock id (zipWith makeFar [addr..] instrs) - makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt + 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 addr other = other + makeFar _ other = other nearLimit = 7000 -- 8192 instructions are allowed; let's keep some -- distance, as we have a few pseudo-insns that are @@ -609,6 +611,18 @@ 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 + where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs + f p = [p] + g (BasicBlock _ xs) = catMaybes (map generateJumpTableForInstr xs) + +-- ----------------------------------------------------------------------------- -- Shortcut branches shortcutBranches @@ -626,10 +640,10 @@ shortcutBranches dflags tops 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 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) +build_mapping (CmmProc info lbl (ListGraph [])) + = (CmmProc info lbl (ListGraph []), emptyUFM) +build_mapping (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. where @@ -639,11 +653,11 @@ build_mapping (CmmProc info lbl params (ListGraph (head:blocks))) (_, 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 -- loop checks + (setMember dest s) || dest == id -- loop checks = (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) + = (setInsert id s, (id,dest) : shortcut_blocks, others) split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) @@ -658,8 +672,8 @@ apply_mapping ufm (CmmData sec statics) = CmmData sec (map (shortcutStatic (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 params (ListGraph blocks)) - = CmmProc info lbl params (ListGraph $ map short_bb blocks) +apply_mapping 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 @@ -704,7 +718,6 @@ genMachCode dflags cmm_top else pprPanic "genMachCode: nonzero final delta" (int final_delta) } - -- ----------------------------------------------------------------------------- -- Generic Cmm optimiser @@ -719,10 +732,9 @@ Here we do: and position independent refs (ii) compile a list of imported symbols -Ideas for other things we could do (ToDo): +Ideas for other things we could do: - shortcut jumps-to-jumps - - eliminate dead code blocks - simple CSE: if an expr is assigned to a temp, then replace later occs of that expr with the temp, until the expr is no longer valid (can push through temp assignments, and certain assigns to mem...) @@ -730,9 +742,9 @@ Ideas for other things we could do (ToDo): 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') +cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do + blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks)) + return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) @@ -808,8 +820,10 @@ cmmStmtConFold stmt cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr -cmmExprConFold referenceKind expr - = case expr of +cmmExprConFold referenceKind expr = do + dflags <- getDynFlagsCmmOpt + let arch = platformArch (targetPlatform dflags) + case expr of CmmLoad addr rep -> do addr' <- cmmExprConFold DataReference addr return $ CmmLoad addr' rep @@ -822,34 +836,30 @@ cmmExprConFold referenceKind expr 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 - -- On powerpc (non-PIC), it's easier to jump directly to a label than - -- to use the register table, so we replace these registers - -- with the corresponding labels: + -- On powerpc (non-PIC), it's easier to jump directly to a label than + -- to use the register table, so we replace these registers + -- with the corresponding labels: CmmReg (CmmGlobal EagerBlackholeInfo) - | not opt_PIC + | arch == ArchPPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) - | not opt_PIC + | arch == ArchPPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) - | not opt_PIC + | arch == ArchPPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) -#endif other -> return other