X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=30af913b29200536acf5484e6277f8614d8cb118;hb=0ebb776871df240ce58664e880ed3afe21977b02;hp=4152c45220811c5d377d237845d932ed81b66fc8;hpb=3d52165d6ff86168fd68addd56be0eb1893aaa1f;p=ghc-hetmet.git diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 4152c45..30af913 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,9 +36,9 @@ 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 @@ -63,14 +62,17 @@ 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 Cmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) import PprCmm @@ -80,7 +82,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 ) @@ -196,7 +197,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) @@ -232,19 +237,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) @@ -312,13 +317,14 @@ 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 @@ -386,7 +392,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 @@ -394,8 +400,22 @@ 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) @@ -611,10 +631,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 @@ -845,15 +872,15 @@ 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)