X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=d73cb89984eab3233155a35102e06b83616593ae;hp=8613a8ed1ff06215316d655f81e90dbc2873ef9b;hb=49a8e5c021009430d373d6224b29004c7d18c408;hpb=b04a210e26ca57242fd052f2aa91011a80b76299 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 8613a8e..d73cb89 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -25,7 +25,6 @@ import Alpha.CodeGen import Alpha.Regs import Alpha.RegInfo import Alpha.Instr -import Alpha.Ppr #elif i386_TARGET_ARCH || x86_64_TARGET_ARCH import X86.CodeGen @@ -37,12 +36,13 @@ import X86.Ppr #elif sparc_TARGET_ARCH import SPARC.CodeGen import SPARC.Regs -import SPARC.RegInfo import SPARC.Instr import SPARC.Ppr +import SPARC.ShortcutJump #elif powerpc_TARGET_ARCH import PPC.CodeGen +import PPC.Cond import PPC.Regs import PPC.RegInfo import PPC.Instr @@ -62,14 +62,18 @@ import qualified RegAlloc.Graph.Stats as Color import qualified RegAlloc.Graph.Coalesce as Color import qualified RegAlloc.Graph.TrivColorable as Color -import qualified TargetReg as Target +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 @@ -79,7 +83,6 @@ import State import UniqFM import Unique ( Unique, getUnique ) import UniqSupply -import List ( groupBy, sortBy ) import DynFlags #if powerpc_TARGET_ARCH import StaticFlags ( opt_Static, opt_PIC ) @@ -195,7 +198,11 @@ nativeCodeGen dflags h us cmms dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" - $ Color.dotGraph Target.targetRegDotColor (Color.trivColorable Target.targetRegClass) + $ Color.dotGraph + targetRegDotColor + (Color.trivColorable + targetVirtualRegSqueeze + targetRealRegSqueeze) $ graphGlobal) @@ -231,19 +238,19 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count Pretty.bufLeftRender h $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native - let lsPprNative = + -- carefully evaluate this strictly. Binding it with 'let' + -- and then using 'seq' doesn't work, because the let + -- apparently gets inlined first. + lsPprNative <- return $! if dopt Opt_D_dump_asm dflags || dopt Opt_D_dump_asm_stats dflags then native else [] - let count' = count + 1; - + count' <- return $! count + 1; -- force evaulation all this stuff to avoid space leaks seqString (showSDoc $ vcat $ map ppr imports) `seq` return () - lsPprNative `seq` return () - count' `seq` return () cmmNativeGens dflags h us' cmms (imports : impAcc) @@ -272,9 +279,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) = @@ -288,13 +295,12 @@ 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" #-} @@ -303,7 +309,6 @@ cmmNativeGen dflags us cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" (vcat $ map ppr withLiveness) - -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- @@ -311,13 +316,13 @@ cmmNativeGen dflags us cmm count || dopt Opt_RegsIterative dflags) then do -- the regs usable for allocation - let alloc_regs + let (alloc_regs :: UniqFM (UniqSet RealReg)) = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (regClass r) (unitUniqSet r)) + $ unitUFM (targetClassOfRealReg r) (unitUniqSet r)) emptyUFM - $ map RealReg allocatableRegs + $ allocatableRegs - -- graph coloring register allocation + -- do the graph coloring register allocation let ((alloced, regAllocStats), usAlloc) = {-# SCC "RegAlloc" #-} initUs usLive @@ -385,7 +390,7 @@ cmmNativeGen dflags us cmm count map sequenceTop shorted ---- x86fp_kludge - let final_mach_code = + let kludged = #if i386_TARGET_ARCH {-# SCC "x86fp_kludge" #-} map x86fp_kludge sequenced @@ -393,15 +398,29 @@ cmmNativeGen dflags us cmm count sequenced #endif + ---- expansion of SPARC synthetic instrs +#if sparc_TARGET_ARCH + let expanded = + {-# SCC "sparc_expand" #-} + map SPARC.expandTop kludged + + dumpIfSet_dyn dflags + Opt_D_dump_asm_expanded "Synthetic instructions expanded" + (vcat $ map (docToSDoc . pprNatCmmTop) expanded) +#else + let expanded = + kludged +#endif + return ( usAlloc - , final_mach_code + , expanded , lastMinuteImports ++ imports , ppr_raStatsColor , ppr_raStatsLinear) #if i386_TARGET_ARCH -x86fp_kludge :: NatCmmTop -> NatCmmTop +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) @@ -476,9 +495,8 @@ makeImportsDoc dflags imports -- fallthroughs. sequenceTop - :: Instruction instr - => NatCmmTop instr - -> NatCmmTop instr + :: NatCmmTop Instr + -> NatCmmTop Instr sequenceTop top@(CmmData _ _) = top sequenceTop (CmmProc info lbl params (ListGraph blocks)) = @@ -552,9 +570,8 @@ reorder id accum (b@(block,id',out) : rest) -- big, we have to work around this limitation. makeFarBranches - :: Instruction instr - => [NatBasicBlock instr] - -> [NatBasicBlock instr] + :: [NatBasicBlock Instr] + -> [NatBasicBlock Instr] #if powerpc_TARGET_ARCH makeFarBranches blocks @@ -612,10 +629,17 @@ build_mapping (CmmProc info lbl params (ListGraph (head:blocks))) where -- find all the blocks that just consist of a jump that can be -- shorted. - (shortcut_blocks, others) = partitionWith split blocks - split (BasicBlock id [insn]) | Just dest <- canShortcut insn - = Left (id,dest) - split other = Right other + -- Don't completely eliminate loops here -- that can leave a dangling jump! + (_, 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 + = (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) + split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) + -- build a mapping from BlockId to JumpDest for shorting branches mapping = foldl add emptyUFM shortcut_blocks @@ -671,44 +695,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 @@ -719,10 +705,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 @@ -846,53 +829,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}