X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=7981a40fc160fcbb577882ee9aba258d95d3b515;hb=97169c5dd31537b28f5f8ad08cd6cdf82c1ecefd;hp=8fdd31a40d8e572668d377a9b125632ffd94ffe8;hpb=a7f409e855291efece19970927156fae4e527b6e;p=ghc-hetmet.git diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 8fdd31a..7981a40 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -35,7 +35,7 @@ import qualified GraphColor as Color import Cmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm ( pprStmt, pprCmms, pprCmm ) +import PprCmm import MachOp import CLabel import State @@ -43,11 +43,11 @@ 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 @@ -129,7 +129,7 @@ nativeCodeGen dflags h us cmms let split_cmms = concat $ map add_split cmms (imports, prof) - <- cmmNativeGens dflags h us split_cmms [] [] + <- cmmNativeGens dflags h us split_cmms [] [] 0 let (native, colorStats, linearStats) = unzip3 prof @@ -174,18 +174,18 @@ nativeCodeGen dflags h us cmms | dopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc [] mkSplitMarkerLabel [] [] + split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph []) -- | 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 $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native @@ -196,13 +196,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 +219,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 +266,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 +276,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 +294,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 +313,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 @@ -361,8 +362,8 @@ cmmNativeGen dflags us cmm #if i386_TARGET_ARCH x86fp_kludge :: NatCmmTop -> NatCmmTop x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge top@(CmmProc info lbl params code) = - CmmProc info lbl params (map bb_i386_insert_ffrees code) +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) @@ -435,8 +436,8 @@ makeImportsDoc imports sequenceTop :: NatCmmTop -> NatCmmTop sequenceTop top@(CmmData _ _) = top -sequenceTop (CmmProc info lbl params blocks) = - CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks) +sequenceTop (CmmProc info lbl params (ListGraph blocks)) = + CmmProc info lbl params (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 @@ -445,6 +446,9 @@ sequenceTop (CmmProc info lbl params 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) = @@ -532,10 +536,10 @@ shortcutBranches dflags tops mapping = foldr plusUFM emptyUFM mappings build_mapping top@(CmmData _ _) = (top, emptyUFM) -build_mapping (CmmProc info lbl params []) - = (CmmProc info lbl params [], emptyUFM) -build_mapping (CmmProc info lbl params (head:blocks)) - = (CmmProc info lbl params (head:others), mapping) +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) -- drop the shorted blocks, but don't ever drop the first one, -- because it is pointed to by a global label. where @@ -554,8 +558,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 blocks) - = CmmProc info lbl params (map short_bb blocks) +apply_mapping ufm (CmmProc info lbl params (ListGraph blocks)) + = CmmProc info lbl params (ListGraph $ map short_bb blocks) where short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns short_insn i = shortcutJump (lookupUFM ufm) i @@ -605,9 +609,9 @@ genMachCode dflags cmm_top fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop fixAssignsTop top@(CmmData _ _) = returnUs top -fixAssignsTop (CmmProc info lbl params blocks) = +fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) = mapUs fixAssignsBlock blocks `thenUs` \ blocks' -> - returnUs (CmmProc info lbl params blocks') + returnUs (CmmProc info lbl params (ListGraph blocks')) fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock fixAssignsBlock (BasicBlock id stmts) = @@ -662,9 +666,9 @@ Ideas for other things we could do (ToDo): cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do +cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) - return $ CmmProc info lbl params blocks' + return $ CmmProc info lbl params (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))