X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=7a38540baaa135d0f78efe40fd1ab5647793da9a;hp=d73cb89984eab3233155a35102e06b83616593ae;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hpb=49a8e5c021009430d373d6224b29004c7d18c408 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index d73cb89..7a38540 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -7,13 +7,6 @@ -- ----------------------------------------------------------------------------- \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" @@ -29,12 +22,12 @@ 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.CodeGen.Expand import SPARC.Regs import SPARC.Instr import SPARC.Ppr @@ -59,37 +52,29 @@ 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 OldCmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm +import OldPprCmm 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 StaticFlags import Util -import Config ( cProjectVersion ) -import Module +import Config import Digraph import qualified Pretty @@ -98,18 +83,16 @@ import Outputable import FastString import UniqSet import ErrUtils +import Module -- DEBUGGING ONLY --import OrdList import Data.List -import Data.Int -import Data.Word -import Data.Bits import Data.Maybe -import GHC.Exts import Control.Monad import System.IO +import Distribution.System {- The native-code generator has machine-independent and @@ -222,12 +205,26 @@ 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. -- -cmmNativeGens dflags h us [] impAcc profAcc count +cmmNativeGens :: DynFlags + -> BufHandle + -> UniqSupply + -> [RawCmmTop] + -> [[CLabel]] + -> [ ([NatCmmTop Instr], + Maybe [Color.RegAllocStats Instr], + Maybe [Linear.RegAllocStats]) ] + -> Int + -> IO ( [[CLabel]], + [([NatCmmTop Instr], + Maybe [Color.RegAllocStats Instr], + Maybe [Linear.RegAllocStats])] ) + +cmmNativeGens _ _ _ [] impAcc profAcc _ = return (reverse impAcc, reverse profAcc) cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count @@ -304,7 +301,9 @@ cmmNativeGen dflags us cmm count -- tag instructions with register liveness information let (withLiveness, usLive) = {-# SCC "regLiveness" #-} - initUs usGen $ mapUs regLiveness native + initUs usGen + $ mapUs regLiveness + $ map natCmmTopToLive native dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" @@ -402,7 +401,7 @@ cmmNativeGen dflags us cmm count #if sparc_TARGET_ARCH let expanded = {-# SCC "sparc_expand" #-} - map SPARC.expandTop kludged + map expandTop kludged dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" @@ -422,8 +421,8 @@ cmmNativeGen dflags us cmm count #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) +x86fp_kludge (CmmProc info lbl (ListGraph code)) = + CmmProc info lbl (ListGraph $ i386_insert_ffrees code) #endif @@ -499,8 +498,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 @@ -510,7 +509,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 @@ -543,8 +542,12 @@ getOutEdges instrs [one] -> [getUnique one] _many -> [] +mkNode :: (Instruction t) + => GenBasicBlock t + -> (GenBasicBlock t, Unique, [Unique]) mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs) +seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1] seqBlocks [] = [] seqBlocks ((block,_,[]) : rest) = block : seqBlocks rest @@ -557,7 +560,8 @@ seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest) -- fallthroughs within a loop. seqBlocks _ = panic "AsmCodegen:seqBlocks" -reorder id accum [] = (False, reverse accum) +reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)]) +reorder _ 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 @@ -584,14 +588,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 @@ -619,11 +623,13 @@ shortcutBranches dflags tops (tops', mappings) = mapAndUnzip build_mapping 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 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 @@ -633,11 +639,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) @@ -645,12 +651,15 @@ build_mapping (CmmProc info lbl params (ListGraph (head:blocks))) 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) -- 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 @@ -695,7 +704,6 @@ genMachCode dflags cmm_top else pprPanic "genMachCode: nonzero final delta" (int final_delta) } - -- ----------------------------------------------------------------------------- -- Generic Cmm optimiser @@ -721,9 +729,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 +cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) - return $ CmmProc info lbl params (ListGraph blocks') + return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) @@ -737,7 +745,7 @@ instance Monad CmmOptM where CmmOptM g' -> g' (imports', dflags) addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #) +addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #) getDynFlagsCmmOpt :: CmmOptM DynFlags getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) @@ -751,6 +759,7 @@ cmmBlockConFold (BasicBlock id stmts) = do stmts' <- mapM cmmStmtConFold stmts return $ BasicBlock id stmts' +cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt cmmStmtConFold stmt = case stmt of CmmAssign reg src @@ -786,8 +795,8 @@ cmmStmtConFold stmt CmmComment (mkFastString ("deleted: " ++ showSDoc (pprStmt stmt))) - CmmLit (CmmInt n _) -> CmmBranch dest - other -> CmmCondBranch test' dest + CmmLit (CmmInt _ _) -> CmmBranch dest + _other -> CmmCondBranch test' dest CmmSwitch expr ids -> do expr' <- cmmExprConFold DataReference expr @@ -797,6 +806,7 @@ cmmStmtConFold stmt -> return other +cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprConFold referenceKind expr = case expr of CmmLoad addr rep @@ -822,23 +832,21 @@ cmmExprConFold referenceKind expr (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 + | cTargetArch == PPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) - | not opt_PIC + | cTargetArch == PPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) - | not opt_PIC + | cTargetArch == PPC && not opt_PIC -> cmmExprConFold referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) -#endif other -> return other