X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=68982d0035945cb399cbb113faeb1e199b8da4cf;hb=9a82b1ffa35fa4c3927c66a1037a37d436cf6aac;hp=615cc0c7bade96d485a90b0b021978ecc52b69dd;hpb=c55eee3add067dd0372ed8eede64b84791f7a9b9;p=ghc-hetmet.git diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 615cc0c..68982d0 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,25 +52,21 @@ 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 ) @@ -87,8 +76,9 @@ import DynFlags import StaticFlags ( opt_Static, opt_PIC ) #endif import Util +#if !defined(darwin_TARGET_OS) import Config ( cProjectVersion ) -import Module +#endif import Digraph import qualified Pretty @@ -102,11 +92,7 @@ import ErrUtils --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 @@ -226,7 +212,21 @@ nativeCodeGen dflags h us cmms -- | 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 @@ -278,9 +278,9 @@ cmmNativeGen dflags us cmm count = do -- rewrite assignments to global regs - let (fixed_cmm, usFix) = - {-# SCC "fixAssignsTop" #-} - initUs us $ fixAssignsTop cmm + let fixed_cmm = + {-# SCC "fixStgRegisters" #-} + fixStgRegisters cmm -- cmm to cmm optimisations let (opt_cmm, imports) = @@ -294,22 +294,22 @@ cmmNativeGen dflags us cmm count -- generate native code from cmm let ((native, lastMinuteImports), usGen) = {-# SCC "genMachCode" #-} - initUs usFix $ genMachCode dflags opt_cmm + initUs us $ genMachCode dflags opt_cmm dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" (vcat $ map (docToSDoc . pprNatCmmTop) native) - -- 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" (vcat $ map ppr withLiveness) - -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- @@ -323,7 +323,6 @@ cmmNativeGen dflags us cmm count emptyUFM $ allocatableRegs - -- do the graph coloring register allocation let ((alloced, regAllocStats), usAlloc) = {-# SCC "RegAlloc" #-} @@ -404,7 +403,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" @@ -424,7 +423,7 @@ 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)) = +x86fp_kludge (CmmProc info lbl params (ListGraph code)) = CmmProc info lbl params (ListGraph $ i386_insert_ffrees code) #endif @@ -545,8 +544,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 @@ -559,7 +562,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 @@ -621,6 +625,8 @@ 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) @@ -647,6 +653,9 @@ 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 @@ -697,44 +706,6 @@ genMachCode dflags cmm_top else pprPanic "genMachCode: nonzero final delta" (int final_delta) } --- ----------------------------------------------------------------------------- --- Fixup assignments to global registers so that they assign to --- locations within the RegTable, if appropriate. - --- Note that we currently don't fixup reads here: they're done by --- the generic optimiser below, to avoid having two separate passes --- over the Cmm. - -fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop -fixAssignsTop top@(CmmData _ _) = returnUs top -fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) = - mapUs fixAssignsBlock blocks `thenUs` \ blocks' -> - returnUs (CmmProc info lbl params (ListGraph blocks')) - -fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock -fixAssignsBlock (BasicBlock id stmts) = - fixAssigns stmts `thenUs` \ stmts' -> - returnUs (BasicBlock id stmts') - -fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt] -fixAssigns stmts = - mapUs fixAssign stmts `thenUs` \ stmtss -> - returnUs (concat stmtss) - -fixAssign :: CmmStmt -> UniqSM [CmmStmt] -fixAssign (CmmAssign (CmmGlobal reg) src) - | Left realreg <- reg_or_addr - = returnUs [CmmAssign (CmmGlobal reg) src] - | Right baseRegAddr <- reg_or_addr - = returnUs [CmmStore baseRegAddr src] - -- Replace register leaves with appropriate StixTrees for - -- the given target. GlobalRegs which map to a reg on this - -- arch are left unchanged. Assigning to BaseReg is always - -- illegal, so we check for that. - where - reg_or_addr = get_GlobalReg_reg_or_addr reg - -fixAssign other_stmt = returnUs [other_stmt] -- ----------------------------------------------------------------------------- -- Generic Cmm optimiser @@ -745,10 +716,7 @@ Here we do: (a) Constant folding (b) Simple inlining: a temporary which is assigned to and then used, once, can be shorted. - (c) Replacement of references to GlobalRegs which do not have - machine registers by the appropriate memory load (eg. - Hp ==> *(BaseReg + 34) ). - (d) Position independent code and dynamic linking + (c) Position independent code and dynamic linking (i) introduce the appropriate indirections and position independent refs (ii) compile a list of imported symbols @@ -780,7 +748,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 #) @@ -794,6 +762,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 @@ -829,8 +798,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 @@ -840,6 +809,7 @@ cmmStmtConFold stmt -> return other +cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr cmmExprConFold referenceKind expr = case expr of CmmLoad addr rep @@ -872,53 +842,19 @@ cmmExprConFold referenceKind expr CmmReg (CmmGlobal EagerBlackholeInfo) | not opt_PIC -> cmmExprConFold referenceKind $ - CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_EAGER_BLACKHOLE_INFO"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) | not opt_PIC -> cmmExprConFold referenceKind $ - CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_enter_1"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) | not opt_PIC -> cmmExprConFold referenceKind $ - CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_fun"))) + CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) #endif - CmmReg (CmmGlobal mid) - -- Replace register leaves with appropriate StixTrees for - -- the given target. MagicIds which map to a reg on this - -- arch are left unchanged. For the rest, BaseReg is taken - -- to mean the address of the reg table in MainCapability, - -- and for all others we generate an indirection to its - -- location in the register table. - -> case get_GlobalReg_reg_or_addr mid of - Left realreg -> return expr - Right baseRegAddr - -> case mid of - BaseReg -> cmmExprConFold DataReference baseRegAddr - other -> cmmExprConFold DataReference - (CmmLoad baseRegAddr (globalRegType mid)) - -- eliminate zero offsets - CmmRegOff reg 0 - -> cmmExprConFold referenceKind (CmmReg reg) - - CmmRegOff (CmmGlobal mid) offset - -- RegOf leaves are just a shorthand form. If the reg maps - -- to a real reg, we keep the shorthand, otherwise, we just - -- expand it and defer to the above code. - -> case get_GlobalReg_reg_or_addr mid of - Left realreg -> return expr - Right baseRegAddr - -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordWidth) [ - CmmReg (CmmGlobal mid), - CmmLit (CmmInt (fromIntegral offset) - wordWidth)]) other -> return other --- ----------------------------------------------------------------------------- --- Utils - -bind f x = x $! f - \end{code}