X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=b9ae9567d3bb4a70218a7a2c065dd249d9cab633;hb=a12e845684c10955bc594cdb20d1f13fae14873d;hp=86363ed0c1c067a1f04a0bd34dd6ef7fcfbb443d;hpb=16dc208aaad7aadaea970e47b8055d7d7f8781e5;p=ghc-hetmet.git diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 86363ed..b9ae956 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -19,41 +19,43 @@ module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" #include "nativeGen/NCG.h" -import MachInstrs -import MachRegs +import Instrs +import Regs import MachCodeGen import PprMach import RegAllocInfo 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 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 Cmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm ( pprStmt, pprCmms, pprCmm ) -import MachOp +import PprCmm import CLabel import State import UniqFM import Unique ( Unique, getUnique ) import UniqSupply -import FastTypes import List ( groupBy, sortBy ) -import ErrUtils ( dumpIfSet_dyn ) import DynFlags +#if powerpc_TARGET_ARCH import StaticFlags ( opt_Static, opt_PIC ) +#endif import Util import Config ( cProjectVersion ) import Module import Digraph import qualified Pretty +import BufWrite import Outputable import FastString import UniqSet @@ -128,8 +130,12 @@ nativeCodeGen dflags h us cmms = do let split_cmms = concat $ map add_split cmms - (imports, prof) - <- cmmNativeGens dflags h us 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 + bFlush bufh let (native, colorStats, linearStats) = unzip3 prof @@ -179,15 +185,15 @@ nativeCodeGen dflags h us cmms -- | Do native code generation on all these cmms. -- -cmmNativeGens dflags h us [] impAcc profAcc +cmmNativeGens dflags h us [] impAcc profAcc count = return (reverse impAcc, reverse profAcc) -cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc +cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count = do (us', native, imports, colorStats, linearStats) - <- cmmNativeGen dflags us cmm + <- cmmNativeGen dflags us cmm count - Pretty.printDoc Pretty.LeftMode h + Pretty.bufLeftRender h $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native let lsPprNative = @@ -196,13 +202,18 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc then native else [] - -- force evaulation of imports and lsPprNative to avoid space leak + let count' = count + 1; + + + -- force evaulation all this stuff to avoid space leaks seqString (showSDoc $ vcat $ map ppr imports) `seq` return () - lsPprNative `seq` return () + lsPprNative `seq` return () + count' `seq` return () cmmNativeGens dflags h us' cmms (imports : impAcc) ((lsPprNative, colorStats, linearStats) : profAcc) + count' where seqString [] = () seqString (x:xs) = x `seq` seqString xs `seq` () @@ -214,15 +225,17 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc cmmNativeGen :: DynFlags -> UniqSupply - -> RawCmmTop + -> RawCmmTop -- ^ the cmm to generate code for + -> Int -- ^ sequence number of this top thing -> IO ( UniqSupply - , [NatCmmTop] - , [CLabel] - , Maybe [Color.RegAllocStats] - , Maybe [Linear.RegAllocStats]) + , [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 -cmmNativeGen dflags us cmm +cmmNativeGen dflags us cmm count = do + -- rewrite assignments to global regs let (fixed_cmm, usFix) = {-# SCC "fixAssignsTop" #-} @@ -259,7 +272,8 @@ cmmNativeGen dflags us cmm -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- - if dopt Opt_RegsGraph dflags + if ( dopt Opt_RegsGraph dflags + || dopt Opt_RegsIterative dflags) then do -- the regs usable for allocation let alloc_regs @@ -268,20 +282,12 @@ cmmNativeGen dflags us cmm emptyUFM $ map RealReg allocatableRegs - -- if any of these dump flags are turned on we want to hang on to - -- intermediate structures in the allocator - otherwise tell the - -- allocator to ditch them early so we don't end up creating space leaks. - let generateRegAllocStats = or - [ dopt Opt_D_dump_asm_regalloc_stages dflags - , dopt Opt_D_dump_asm_stats dflags - , dopt Opt_D_dump_asm_conflicts dflags ] - -- graph coloring register allocation let ((alloced, regAllocStats), usAlloc) - = {-# SCC "regAlloc(color)" #-} + = {-# SCC "RegAlloc" #-} initUs usLive $ Color.regAlloc - generateRegAllocStats + dflags alloc_regs (mkUniqSet [0..maxSpillSlots]) withLiveness @@ -294,7 +300,8 @@ cmmNativeGen dflags us cmm dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" (vcat $ map (\(stage, stats) - -> text "-- Stage " <> int stage + -> text "# --------------------------" + $$ text "# cmm " <> int count <> text " Stage " <> int stage $$ ppr stats) $ zip [0..] regAllocStats) @@ -312,7 +319,7 @@ cmmNativeGen dflags us cmm else do -- do linear register allocation let ((alloced, regAllocStats), usAlloc) - = {-# SCC "regAlloc(linear)" #-} + = {-# SCC "RegAlloc" #-} initUs usLive $ liftM unzip $ mapUs Linear.regAlloc withLiveness @@ -362,10 +369,7 @@ cmmNativeGen dflags us cmm x86fp_kludge :: NatCmmTop -> NatCmmTop x86fp_kludge top@(CmmData _ _) = top x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = - CmmProc info lbl params (ListGraph $ map bb_i386_insert_ffrees code) - where - bb_i386_insert_ffrees (BasicBlock id instrs) = - BasicBlock id (i386_insert_ffrees instrs) + CmmProc info lbl params (ListGraph $ i386_insert_ffrees code) #endif @@ -445,6 +449,9 @@ sequenceTop (CmmProc info lbl params (ListGraph blocks)) = -- output the block, then if it has an out edge, we move the -- 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). + sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock] sequenceBlocks [] = [] sequenceBlocks (entry:blocks) = @@ -452,7 +459,7 @@ sequenceBlocks (entry:blocks) = -- the first block is the entry point ==> it must remain at the start. sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])] -sccBlocks blocks = stronglyConnCompR (map mkNode blocks) +sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks) getOutEdges :: [Instr] -> [Unique] getOutEdges instrs = case jumpDests (last instrs) [] of @@ -715,9 +722,9 @@ cmmStmtConFold stmt e' <- cmmExprConFold CallReference e return $ CmmCallee e' conv other -> return other - args' <- mapM (\(arg, hint) -> do + args' <- mapM (\(CmmHinted arg hint) -> do arg' <- cmmExprConFold DataReference arg - return (arg', hint)) args + return (CmmHinted arg' hint)) args return $ CmmCall target' regs args' srt returns CmmCondBranch test dest @@ -758,23 +765,27 @@ cmmExprConFold referenceKind expr -> do dflags <- getDynFlagsCmmOpt dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl - return $ cmmMachOpFold (MO_Add wordRep) [ + return $ cmmMachOpFold (MO_Add wordWidth) [ dynRef, - (CmmLit $ CmmInt (fromIntegral off) wordRep) + (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: + CmmReg (CmmGlobal EagerBlackholeInfo) + | not opt_PIC + -> cmmExprConFold referenceKind $ + CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_EAGER_BLACKHOLE_INFO"))) CmmReg (CmmGlobal GCEnter1) | not opt_PIC -> cmmExprConFold referenceKind $ - CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1"))) + CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) | not opt_PIC -> cmmExprConFold referenceKind $ - CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun"))) + CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_fun"))) #endif CmmReg (CmmGlobal mid) @@ -790,7 +801,7 @@ cmmExprConFold referenceKind expr -> case mid of BaseReg -> cmmExprConFold DataReference baseRegAddr other -> cmmExprConFold DataReference - (CmmLoad baseRegAddr (globalRegRep mid)) + (CmmLoad baseRegAddr (globalRegType mid)) -- eliminate zero offsets CmmRegOff reg 0 -> cmmExprConFold referenceKind (CmmReg reg) @@ -802,10 +813,10 @@ cmmExprConFold referenceKind expr -> case get_GlobalReg_reg_or_addr mid of Left realreg -> return expr Right baseRegAddr - -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [ + -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordWidth) [ CmmReg (CmmGlobal mid), CmmLit (CmmInt (fromIntegral offset) - wordRep)]) + wordWidth)]) other -> return other