From f9288086f935c97812b2d80defcff38baf7b6a6c Mon Sep 17 00:00:00 2001 From: "Ben.Lippmeier@anu.edu.au" Date: Mon, 18 May 2009 01:44:44 +0000 Subject: [PATCH] Split Reg into vreg/hreg and add register pairs * The old Reg type is now split into VirtualReg and RealReg. * For the graph coloring allocator, the type of the register graph is now (Graph VirtualReg RegClass RealReg), which shows that it colors in nodes representing virtual regs with colors representing real regs. (as was intended) * RealReg contains two contructors, RealRegSingle and RealRegPair, where RealRegPair is used to represent a SPARC double reg constructed from two single precision FP regs. * On SPARC we can now allocate double regs into an arbitrary register pair, instead of reserving some reg ranges to only hold float/double values. --- compiler/ghc.cabal.in | 1 + compiler/main/DynFlags.hs | 3 + compiler/nativeGen/AsmCodeGen.lhs | 37 +- compiler/nativeGen/NCGMonad.hs | 8 +- compiler/nativeGen/PPC/CodeGen.hs | 2 +- compiler/nativeGen/PPC/Instr.hs | 10 +- compiler/nativeGen/PPC/Ppr.hs | 11 +- compiler/nativeGen/PPC/RegInfo.hs | 6 +- compiler/nativeGen/PPC/Regs.hs | 105 ++--- compiler/nativeGen/Reg.hs | 211 +++++++--- compiler/nativeGen/RegAlloc/Graph/Main.hs | 146 ++++--- compiler/nativeGen/RegAlloc/Graph/Spill.hs | 6 +- compiler/nativeGen/RegAlloc/Graph/SpillClean.hs | 5 +- compiler/nativeGen/RegAlloc/Graph/SpillCost.hs | 71 ++-- compiler/nativeGen/RegAlloc/Graph/Stats.hs | 40 +- compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs | 253 +++++++----- compiler/nativeGen/RegAlloc/Linear/Base.hs | 8 +- .../nativeGen/RegAlloc/Linear/JoinToTargets.hs | 13 +- compiler/nativeGen/RegAlloc/Linear/Main.hs | 425 +++++++++++--------- .../nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs | 210 +++++----- compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs | 2 +- compiler/nativeGen/RegAlloc/Liveness.hs | 5 +- compiler/nativeGen/SPARC/AddrMode.hs | 2 +- compiler/nativeGen/SPARC/CodeGen/Base.hs | 8 +- compiler/nativeGen/SPARC/CodeGen/CCall.hs | 14 +- compiler/nativeGen/SPARC/CodeGen/Expand.hs | 161 ++++++++ compiler/nativeGen/SPARC/CodeGen/Gen64.hs | 4 +- compiler/nativeGen/SPARC/CodeGen/Sanity.hs | 3 +- compiler/nativeGen/SPARC/Instr.hs | 40 +- compiler/nativeGen/SPARC/Ppr.hs | 207 +++------- compiler/nativeGen/SPARC/RegPlate.hs | 62 +-- compiler/nativeGen/SPARC/Regs.hs | 202 ++++++---- compiler/nativeGen/TargetReg.hs | 47 ++- compiler/nativeGen/X86/CodeGen.hs | 12 +- compiler/nativeGen/X86/Instr.hs | 9 +- compiler/nativeGen/X86/Ppr.hs | 23 +- compiler/nativeGen/X86/RegInfo.hs | 6 +- compiler/nativeGen/X86/Regs.hs | 152 +++---- compiler/utils/GraphColor.hs | 21 +- compiler/utils/GraphOps.hs | 10 +- compiler/utils/UniqSet.lhs | 2 +- includes/MachRegs.h | 7 + 42 files changed, 1528 insertions(+), 1042 deletions(-) create mode 100644 compiler/nativeGen/SPARC/CodeGen/Expand.hs diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 9a181f8..ec87c4a 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -505,6 +505,7 @@ Library SPARC.CodeGen.Gen32 SPARC.CodeGen.Gen64 SPARC.CodeGen.Sanity + SPARC.CodeGen.Expand RegAlloc.Liveness RegAlloc.Graph.Main RegAlloc.Graph.Stats diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index ad17fa6..3b027d8 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -120,6 +120,7 @@ data DynFlag | Opt_D_dump_asm_regalloc_stages | Opt_D_dump_asm_conflicts | Opt_D_dump_asm_stats + | Opt_D_dump_asm_expanded | Opt_D_dump_cpranal | Opt_D_dump_deriv | Opt_D_dump_ds @@ -1360,6 +1361,8 @@ dynamic_flags = [ Supported , Flag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) Supported + , Flag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) + Supported , Flag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) Supported , Flag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 119e118..eafeec9 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -62,12 +62,14 @@ 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 Cmm @@ -195,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) @@ -311,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 @@ -385,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 @@ -393,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) diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index ed59d2b..409d0c4 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -132,14 +132,16 @@ getNewLabelNat getNewRegNat :: Size -> NatM Reg getNewRegNat rep = do u <- getUniqueNat - return (targetMkVReg u rep) + return (RegVirtual $ targetMkVirtualReg u rep) getNewRegPairNat :: Size -> NatM (Reg,Reg) getNewRegPairNat rep = do u <- getUniqueNat - let lo = targetMkVReg u rep; hi = getHiVRegFromLo lo - return (lo,hi) + let vLo = targetMkVirtualReg u rep + let lo = RegVirtual $ targetMkVirtualReg u rep + let hi = RegVirtual $ getHiVirtualRegFromLo vLo + return (lo, hi) getPicBaseMaybeNat :: NatM (Maybe Reg) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index e57d3ca..d3ec27f 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -180,7 +180,7 @@ getRegisterReg (CmmLocal (LocalReg u pk)) getRegisterReg (CmmGlobal mid) = case get_GlobalReg_reg_or_addr mid of - Left (RealReg rrno) -> RealReg rrno + Left reg@(RegReal _) -> reg _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the -- ones which map to a real machine register on this diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index 55affc6..58ddc21 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -230,12 +230,12 @@ ppc_regUsageOfInstr instr regRI _ = [] interesting :: Reg -> Bool -interesting (VirtualRegI _) = True -interesting (VirtualRegHi _) = True -interesting (VirtualRegF _) = True -interesting (VirtualRegD _) = True -interesting (RealReg i) = isFastTrue (freeReg i) +interesting (RegVirtual _) = True +interesting (RegReal (RealRegSingle i)) + = isFastTrue (freeReg i) +interesting (RegReal (RealRegPair{})) + = panic "PPC.Instr.interesting: no reg pairs on this arch" diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 3629683..8378dd1 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -164,11 +164,12 @@ pprReg :: Reg -> Doc pprReg r = case r of - RealReg i -> ppr_reg_no i - VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u) - VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u) - VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u) - VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u) + RegReal (RealRegSingle i) -> ppr_reg_no i + RegReal (RealRegPair{}) -> panic "PPC.pprReg: no reg pairs on this arch" + RegVirtual (VirtualRegI u) -> text "%vI_" <> asmSDoc (pprUnique u) + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> asmSDoc (pprUnique u) + RegVirtual (VirtualRegF u) -> text "%vF_" <> asmSDoc (pprUnique u) + RegVirtual (VirtualRegD u) -> text "%vD_" <> asmSDoc (pprUnique u) where #if darwin_TARGET_OS ppr_reg_no :: Int -> Doc diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index b2806c7..719d76c 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -37,11 +37,11 @@ import Unique mkVReg :: Unique -> Size -> Reg mkVReg u size - | not (isFloatSize size) = VirtualRegI u + | not (isFloatSize size) = RegVirtual $ VirtualRegI u | otherwise = case size of - FF32 -> VirtualRegD u - FF64 -> VirtualRegD u + FF32 -> RegVirtual $ VirtualRegD u + FF64 -> RegVirtual $ VirtualRegD u _ -> panic "mkVReg" diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index 80c68dd..c39313a 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -138,30 +138,30 @@ spRel n = AddrRegImm sp (ImmInt (n * wORD_SIZE)) -- Dunno about Alpha. argRegs :: RegNo -> [Reg] argRegs 0 = [] -argRegs 1 = map RealReg [3] -argRegs 2 = map RealReg [3,4] -argRegs 3 = map RealReg [3..5] -argRegs 4 = map RealReg [3..6] -argRegs 5 = map RealReg [3..7] -argRegs 6 = map RealReg [3..8] -argRegs 7 = map RealReg [3..9] -argRegs 8 = map RealReg [3..10] +argRegs 1 = map regSingle [3] +argRegs 2 = map regSingle [3,4] +argRegs 3 = map regSingle [3..5] +argRegs 4 = map regSingle [3..6] +argRegs 5 = map regSingle [3..7] +argRegs 6 = map regSingle [3..8] +argRegs 7 = map regSingle [3..9] +argRegs 8 = map regSingle [3..10] argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!" allArgRegs :: [Reg] -allArgRegs = map RealReg [3..10] +allArgRegs = map regSingle [3..10] -- these are the regs which we cannot assume stay alive over a C call. callClobberedRegs :: [Reg] #if defined(darwin_TARGET_OS) callClobberedRegs - = map RealReg (0:[2..12] ++ map fReg [0..13]) + = map regSingle (0:[2..12] ++ map fReg [0..13]) #elif defined(linux_TARGET_OS) callClobberedRegs - = map RealReg (0:[2..13] ++ map fReg [0..13]) + = map regSingle (0:[2..13] ++ map fReg [0..13]) #else callClobberedRegs @@ -175,14 +175,17 @@ allMachRegNos = [0..63] {-# INLINE regClass #-} regClass :: Reg -> RegClass -regClass (VirtualRegI _) = RcInteger -regClass (VirtualRegHi _) = RcInteger -regClass (VirtualRegF u) = pprPanic ("regClass(ppc):VirtualRegF ") (ppr u) -regClass (VirtualRegD _) = RcDouble -regClass (RealReg i) +regClass (RegVirtual (VirtualRegI _)) = RcInteger +regClass (RegVirtual (VirtualRegHi _)) = RcInteger +regClass (RegVirtual (VirtualRegF u)) = pprPanic ("regClass(ppc):VirtualRegF ") (ppr u) +regClass (RegVirtual (VirtualRegD _)) = RcDouble + +regClass (RegReal (RealRegSingle i)) | i < 32 = RcInteger | otherwise = RcDouble +regClass (RegReal (RealRegPair{})) + = panic "regClass(ppr): no reg pairs on this architecture" showReg :: RegNo -> String showReg n @@ -196,10 +199,10 @@ showReg n allFPArgRegs :: [Reg] #if defined(darwin_TARGET_OS) -allFPArgRegs = map (RealReg . fReg) [1..13] +allFPArgRegs = map (regSingle . fReg) [1..13] #elif defined(linux_TARGET_OS) -allFPArgRegs = map (RealReg . fReg) [1..8] +allFPArgRegs = map (regSingle . fReg) [1..8] #else allFPArgRegs = panic "PPC.Regs.allFPArgRegs: not defined for this architecture" @@ -240,14 +243,14 @@ fReg :: Int -> RegNo fReg x = (32 + x) sp, r3, r4, r27, r28, f1, f20, f21 :: Reg -sp = RealReg 1 -r3 = RealReg 3 -r4 = RealReg 4 -r27 = RealReg 27 -r28 = RealReg 28 -f1 = RealReg $ fReg 1 -f20 = RealReg $ fReg 20 -f21 = RealReg $ fReg 21 +sp = regSingle 1 +r3 = regSingle 3 +r4 = regSingle 4 +r27 = regSingle 27 +r28 = regSingle 28 +f1 = regSingle $ fReg 1 +f20 = regSingle $ fReg 20 +f21 = regSingle $ fReg 21 @@ -436,79 +439,79 @@ freeReg _ = fastBool True #ifdef REG_Base -globalRegMaybe BaseReg = Just (RealReg REG_Base) +globalRegMaybe BaseReg = Just (regSingle REG_Base) #endif #ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (RealReg REG_R1) +globalRegMaybe (VanillaReg 1 _) = Just (regSingle REG_R1) #endif #ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (RealReg REG_R2) +globalRegMaybe (VanillaReg 2 _) = Just (regSingle REG_R2) #endif #ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (RealReg REG_R3) +globalRegMaybe (VanillaReg 3 _) = Just (regSingle REG_R3) #endif #ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (RealReg REG_R4) +globalRegMaybe (VanillaReg 4 _) = Just (regSingle REG_R4) #endif #ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (RealReg REG_R5) +globalRegMaybe (VanillaReg 5 _) = Just (regSingle REG_R5) #endif #ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (RealReg REG_R6) +globalRegMaybe (VanillaReg 6 _) = Just (regSingle REG_R6) #endif #ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (RealReg REG_R7) +globalRegMaybe (VanillaReg 7 _) = Just (regSingle REG_R7) #endif #ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (RealReg REG_R8) +globalRegMaybe (VanillaReg 8 _) = Just (regSingle REG_R8) #endif #ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (RealReg REG_R9) +globalRegMaybe (VanillaReg 9 _) = Just (regSingle REG_R9) #endif #ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (RealReg REG_R10) +globalRegMaybe (VanillaReg 10 _) = Just (regSingle REG_R10) #endif #ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (RealReg REG_F1) +globalRegMaybe (FloatReg 1) = Just (regSingle REG_F1) #endif #ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (RealReg REG_F2) +globalRegMaybe (FloatReg 2) = Just (regSingle REG_F2) #endif #ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (RealReg REG_F3) +globalRegMaybe (FloatReg 3) = Just (regSingle REG_F3) #endif #ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (RealReg REG_F4) +globalRegMaybe (FloatReg 4) = Just (regSingle REG_F4) #endif #ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = Just (RealReg REG_D1) +globalRegMaybe (DoubleReg 1) = Just (regSingle REG_D1) #endif #ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = Just (RealReg REG_D2) +globalRegMaybe (DoubleReg 2) = Just (regSingle REG_D2) #endif #ifdef REG_Sp -globalRegMaybe Sp = Just (RealReg REG_Sp) +globalRegMaybe Sp = Just (regSingle REG_Sp) #endif #ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (RealReg REG_Lng1) +globalRegMaybe (LongReg 1) = Just (regSingle REG_Lng1) #endif #ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (RealReg REG_Lng2) +globalRegMaybe (LongReg 2) = Just (regSingle REG_Lng2) #endif #ifdef REG_SpLim -globalRegMaybe SpLim = Just (RealReg REG_SpLim) +globalRegMaybe SpLim = Just (regSingle REG_SpLim) #endif #ifdef REG_Hp -globalRegMaybe Hp = Just (RealReg REG_Hp) +globalRegMaybe Hp = Just (regSingle REG_Hp) #endif #ifdef REG_HpLim -globalRegMaybe HpLim = Just (RealReg REG_HpLim) +globalRegMaybe HpLim = Just (regSingle REG_HpLim) #endif #ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO) +globalRegMaybe CurrentTSO = Just (regSingle REG_CurrentTSO) #endif #ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery) +globalRegMaybe CurrentNursery = Just (regSingle REG_CurrentNursery) #endif globalRegMaybe _ = Nothing diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs index 1a341bb..4819d0f 100644 --- a/compiler/nativeGen/Reg.hs +++ b/compiler/nativeGen/Reg.hs @@ -7,11 +7,22 @@ module Reg ( RegNo, Reg(..), - isRealReg, - unRealReg, - isVirtualReg, + regPair, + regSingle, + isRealReg, takeRealReg, + isVirtualReg, takeVirtualReg, + + VirtualReg(..), renameVirtualReg, - getHiVRegFromLo + classOfVirtualReg, + getHiVirtualRegFromLo, + getHiVRegFromLo, + + RealReg(..), + regNosOfRealReg, + realRegsAlias, + + liftPatchFnToRegReg ) where @@ -19,15 +30,13 @@ where import Outputable import Unique import Panic +import RegClass +import Data.List --- | An identifier for a real machine register. +-- | An identifier for a primitive real machine register. type RegNo = Int --- RealRegs are machine regs which are available for allocation, in --- the usual way. We know what class they are, because that's part of --- the processor's architecture. - -- VirtualRegs are virtual registers. The register allocator will -- eventually have to map them into RealRegs, or into spill slots. -- @@ -35,79 +44,173 @@ type RegNo -- value in the abstract assembly code (i.e. dynamic registers are -- usually single assignment). -- --- With the new register allocator, the --- single assignment restriction isn't necessary to get correct code, +-- The single assignment restriction isn't necessary to get correct code, -- although a better register allocation will result if single -- assignment is used -- because the allocator maps a VirtualReg into -- a single RealReg, even if the VirtualReg has multiple live ranges. - +-- -- Virtual regs can be of either class, so that info is attached. -data Reg - = RealReg {-# UNPACK #-} !RegNo - | VirtualRegI {-# UNPACK #-} !Unique +-- +data VirtualReg + = VirtualRegI {-# UNPACK #-} !Unique | VirtualRegHi {-# UNPACK #-} !Unique -- High part of 2-word register | VirtualRegF {-# UNPACK #-} !Unique | VirtualRegD {-# UNPACK #-} !Unique - deriving (Eq, Ord) - - --- We like to have Uniques for Reg so that we can make UniqFM and UniqSets --- in the register allocator. -instance Uniquable Reg where - getUnique (RealReg i) = mkUnique 'C' i - getUnique (VirtualRegI u) = u - getUnique (VirtualRegHi u) = u - getUnique (VirtualRegF u) = u - getUnique (VirtualRegD u) = u + deriving (Eq, Show, Ord) +instance Uniquable VirtualReg where + getUnique reg + = case reg of + VirtualRegI u -> u + VirtualRegHi u -> u + VirtualRegF u -> u + VirtualRegD u -> u --- | Print a reg in a generic manner --- If you want the architecture specific names, then use the pprReg --- function from the appropriate Ppr module. -instance Outputable Reg where +instance Outputable VirtualReg where ppr reg = case reg of - RealReg i -> text "%r" <> int i VirtualRegI u -> text "%vI_" <> pprUnique u VirtualRegHi u -> text "%vHi_" <> pprUnique u VirtualRegF u -> text "%vF_" <> pprUnique u VirtualRegD u -> text "%vD_" <> pprUnique u - -isRealReg :: Reg -> Bool -isRealReg = not . isVirtualReg - --- | Take the RegNo from a real reg -unRealReg :: Reg -> RegNo -unRealReg (RealReg i) = i -unRealReg _ = panic "unRealReg on VirtualReg" - -isVirtualReg :: Reg -> Bool -isVirtualReg (RealReg _) = False -isVirtualReg (VirtualRegI _) = True -isVirtualReg (VirtualRegHi _) = True -isVirtualReg (VirtualRegF _) = True -isVirtualReg (VirtualRegD _) = True - - -renameVirtualReg :: Unique -> Reg -> Reg +renameVirtualReg :: Unique -> VirtualReg -> VirtualReg renameVirtualReg u r = case r of - RealReg _ -> error "renameVirtualReg: can't change unique on a real reg" VirtualRegI _ -> VirtualRegI u VirtualRegHi _ -> VirtualRegHi u VirtualRegF _ -> VirtualRegF u VirtualRegD _ -> VirtualRegD u + +classOfVirtualReg :: VirtualReg -> RegClass +classOfVirtualReg vr + = case vr of + VirtualRegI{} -> RcInteger + VirtualRegHi{} -> RcInteger + VirtualRegF{} -> RcFloat + VirtualRegD{} -> RcDouble + + -- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform -- when supplied with the vreg for the lower-half of the quantity. -- (NB. Not reversible). +getHiVirtualRegFromLo :: VirtualReg -> VirtualReg +getHiVirtualRegFromLo reg + = case reg of + -- makes a pseudo-unique with tag 'H' + VirtualRegI u -> VirtualRegHi (newTagUnique u 'H') + _ -> panic "Reg.getHiVirtualRegFromLo" + getHiVRegFromLo :: Reg -> Reg -getHiVRegFromLo (VirtualRegI u) - = VirtualRegHi (newTagUnique u 'H') -- makes a pseudo-unique with tag 'H' +getHiVRegFromLo reg + = case reg of + RegVirtual vr -> RegVirtual (getHiVirtualRegFromLo vr) + RegReal _ -> panic "Reg.getHiVRegFromLo" + + +------------------------------------------------------------------------------------ +-- | RealRegs are machine regs which are available for allocation, in +-- the usual way. We know what class they are, because that's part of +-- the processor's architecture. +-- +-- RealRegPairs are pairs of real registers that are allocated together +-- to hold a larger value, such as with Double regs on SPARC. +-- +data RealReg + = RealRegSingle {-# UNPACK #-} !RegNo + | RealRegPair {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo + deriving (Eq, Show, Ord) + +instance Uniquable RealReg where + getUnique reg + = case reg of + RealRegSingle i -> mkUnique 'S' i + RealRegPair r1 r2 -> mkUnique 'P' (r1 * 65536 + r2) + +instance Outputable RealReg where + ppr reg + = case reg of + RealRegSingle i -> text "%r" <> int i + RealRegPair r1 r2 -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")" + +regNosOfRealReg :: RealReg -> [RegNo] +regNosOfRealReg rr + = case rr of + RealRegSingle r1 -> [r1] + RealRegPair r1 r2 -> [r1, r2] + + +realRegsAlias :: RealReg -> RealReg -> Bool +realRegsAlias rr1 rr2 + = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2) + +-------------------------------------------------------------------------------- +-- | A register, either virtual or real +data Reg + = RegVirtual {-# UNPACK #-} !VirtualReg + | RegReal {-# UNPACK #-} !RealReg + deriving (Eq, Ord) -getHiVRegFromLo _ - = panic "RegsBase.getHiVRegFromLo" +regSingle :: RegNo -> Reg +regSingle regNo = RegReal $ RealRegSingle regNo +regPair :: RegNo -> RegNo -> Reg +regPair regNo1 regNo2 = RegReal $ RealRegPair regNo1 regNo2 + + +-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets +-- in the register allocator. +instance Uniquable Reg where + getUnique reg + = case reg of + RegVirtual vr -> getUnique vr + RegReal rr -> getUnique rr + +-- | Print a reg in a generic manner +-- If you want the architecture specific names, then use the pprReg +-- function from the appropriate Ppr module. +instance Outputable Reg where + ppr reg + = case reg of + RegVirtual vr -> ppr vr + RegReal rr -> ppr rr + + +isRealReg :: Reg -> Bool +isRealReg reg + = case reg of + RegReal _ -> True + RegVirtual _ -> False + +takeRealReg :: Reg -> Maybe RealReg +takeRealReg reg + = case reg of + RegReal rr -> Just rr + _ -> Nothing + + +isVirtualReg :: Reg -> Bool +isVirtualReg reg + = case reg of + RegReal _ -> False + RegVirtual _ -> True + +takeVirtualReg :: Reg -> Maybe VirtualReg +takeVirtualReg reg + = case reg of + RegReal _ -> Nothing + RegVirtual vr -> Just vr + + +-- | The patch function supplied by the allocator maps VirtualReg to RealReg +-- regs, but sometimes we want to apply it to plain old Reg. +-- +liftPatchFnToRegReg :: (VirtualReg -> RealReg) -> (Reg -> Reg) +liftPatchFnToRegReg patchF reg + = case reg of + RegVirtual vr -> RegReal (patchF vr) + RegReal _ -> reg + diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs index 2e58461..94b18ae 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Main.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs @@ -11,6 +11,7 @@ module RegAlloc.Graph.Main ( where import qualified GraphColor as Color +import qualified GraphBase as Color import RegAlloc.Liveness import RegAlloc.Graph.Spill import RegAlloc.Graph.SpillClean @@ -47,7 +48,7 @@ maxSpinCount = 10 regAlloc :: (Outputable instr, Instruction instr) => DynFlags - -> UniqFM (UniqSet Reg) -- ^ the registers we can use for allocation + -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. -> [LiveCmmTop instr] -- ^ code annotated with liveness information. -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] ) @@ -59,7 +60,9 @@ regAlloc dflags regsFree slotsFree code -- TODO: the regClass function is currently hard coded to the default target -- architecture. Would prefer to determine this from dflags. -- There are other uses of targetRegClass later in this module. - let triv = trivColorable targetRegClass + let triv = trivColorable + targetVirtualRegSqueeze + targetRealRegSqueeze (code_final, debug_codeGraphs, _) <- regAlloc_spin dflags 0 @@ -69,7 +72,14 @@ regAlloc dflags regsFree slotsFree code return ( code_final , reverse debug_codeGraphs ) -regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code +regAlloc_spin + dflags + spinCount + (triv :: Color.Triv VirtualReg RegClass RealReg) + (regsFree :: UniqFM (UniqSet RealReg)) + slotsFree + debug_codeGraphs + code = do -- if any of these dump flags are turned on we want to hang on to -- intermediate structures in the allocator - otherwise tell the @@ -89,7 +99,8 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code $$ text "slotsFree = " <> ppr (sizeUniqSet slotsFree)) -- build a conflict graph from the code. - graph <- {-# SCC "BuildGraph" #-} buildGraph code + (graph :: Color.Graph VirtualReg RegClass RealReg) + <- {-# SCC "BuildGraph" #-} buildGraph code -- VERY IMPORTANT: -- We really do want the graph to be fully evaluated _before_ we start coloring. @@ -125,9 +136,15 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code regsFree triv spill graph -- rewrite regs in the code that have been coalesced - let patchF reg = case lookupUFM rmCoalesce reg of - Just reg' -> patchF reg' - Nothing -> reg + let patchF reg + | RegVirtual vr <- reg + = case lookupUFM rmCoalesce vr of + Just vr' -> patchF (RegVirtual vr') + Nothing -> reg + + | otherwise + = reg + let code_coalesced = map (patchEraseLive patchF) code @@ -225,7 +242,7 @@ regAlloc_spin dflags spinCount triv regsFree slotsFree debug_codeGraphs code buildGraph :: Instruction instr => [LiveCmmTop instr] - -> UniqSM (Color.Graph Reg RegClass Reg) + -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code = do @@ -252,19 +269,20 @@ buildGraph code -- graphAddConflictSet :: UniqSet Reg - -> Color.Graph Reg RegClass Reg - -> Color.Graph Reg RegClass Reg + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg graphAddConflictSet set graph - = let reals = filterUFM isRealReg set - virtuals = filterUFM (not . isRealReg) set + = let virtuals = mkUniqSet + [ vr | RegVirtual vr <- uniqSetToList set ] - graph1 = Color.addConflicts virtuals targetRegClass graph - graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 targetRegClass r2) + graph1 = Color.addConflicts virtuals classOfVirtualReg graph + + graph2 = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2) graph1 - [ (a, b) - | a <- uniqSetToList virtuals - , b <- uniqSetToList reals] + [ (vr, rr) + | RegVirtual vr <- uniqSetToList set + , RegReal rr <- uniqSetToList set] in graph2 @@ -274,26 +292,33 @@ graphAddConflictSet set graph -- graphAddCoalesce :: (Reg, Reg) - -> Color.Graph Reg RegClass Reg - -> Color.Graph Reg RegClass Reg + -> Color.Graph VirtualReg RegClass RealReg + -> Color.Graph VirtualReg RegClass RealReg graphAddCoalesce (r1, r2) graph - | RealReg _ <- r1 - = Color.addPreference (regWithClass r2) r1 graph + | RegReal rr <- r1 + , RegVirtual vr <- r2 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph - | RealReg _ <- r2 - = Color.addPreference (regWithClass r1) r2 graph + | RegReal rr <- r2 + , RegVirtual vr <- r1 + = Color.addPreference (vr, classOfVirtualReg vr) rr graph - | otherwise - = Color.addCoalesce (regWithClass r1) (regWithClass r2) graph + | RegVirtual vr1 <- r1 + , RegVirtual vr2 <- r2 + = Color.addCoalesce + (vr1, classOfVirtualReg vr1) + (vr2, classOfVirtualReg vr2) + graph - where regWithClass r = (r, targetRegClass r) + | otherwise + = panic "RegAlloc.Graph.Main.graphAddCoalesce: can't coalesce two real regs" -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph :: (Outputable instr, Instruction instr) - => Color.Graph Reg RegClass Reg + => Color.Graph VirtualReg RegClass RealReg -> LiveCmmTop instr -> LiveCmmTop instr patchRegsFromGraph graph code @@ -301,21 +326,27 @@ patchRegsFromGraph graph code -- a function to lookup the hardreg for a virtual reg from the graph. patchF reg -- leave real regs alone. - | isRealReg reg + | RegReal{} <- reg = reg -- this virtual has a regular node in the graph. - | Just node <- Color.lookupNode graph reg + | RegVirtual vr <- reg + , Just node <- Color.lookupNode graph vr = case Color.nodeColor node of - Just color -> color - Nothing -> reg + Just color -> RegReal color + Nothing -> RegVirtual vr -- no node in the graph for this virtual, bad news. | otherwise = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg $$ ppr code - $$ Color.dotGraph (\_ -> text "white") (trivColorable targetRegClass) graph) + $$ Color.dotGraph + (\_ -> text "white") + (trivColorable + targetVirtualRegSqueeze + targetRealRegSqueeze) + graph) in patchEraseLive patchF code @@ -323,34 +354,39 @@ patchRegsFromGraph graph code ----- -- for when laziness just isn't what you wanted... -- -seqGraph :: Color.Graph Reg RegClass Reg -> () +seqGraph :: Color.Graph VirtualReg RegClass RealReg -> () seqGraph graph = seqNodes (eltsUFM (Color.graphMap graph)) -seqNodes :: [Color.Node Reg RegClass Reg] -> () +seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> () seqNodes ns = case ns of [] -> () (n : ns) -> seqNode n `seq` seqNodes ns -seqNode :: Color.Node Reg RegClass Reg -> () +seqNode :: Color.Node VirtualReg RegClass RealReg -> () seqNode node - = seqReg (Color.nodeId node) - `seq` seqRegClass (Color.nodeClass node) - `seq` seqMaybeReg (Color.nodeColor node) - `seq` (seqRegList (uniqSetToList (Color.nodeConflicts node))) - `seq` (seqRegList (uniqSetToList (Color.nodeExclusions node))) - `seq` (seqRegList (Color.nodePreference node)) - `seq` (seqRegList (uniqSetToList (Color.nodeCoalesce node))) - -seqReg :: Reg -> () -seqReg reg + = seqVirtualReg (Color.nodeId node) + `seq` seqRegClass (Color.nodeClass node) + `seq` seqMaybeRealReg (Color.nodeColor node) + `seq` (seqVirtualRegList (uniqSetToList (Color.nodeConflicts node))) + `seq` (seqRealRegList (uniqSetToList (Color.nodeExclusions node))) + `seq` (seqRealRegList (Color.nodePreference node)) + `seq` (seqVirtualRegList (uniqSetToList (Color.nodeCoalesce node))) + +seqVirtualReg :: VirtualReg -> () +seqVirtualReg reg = case reg of - RealReg _ -> () VirtualRegI _ -> () VirtualRegHi _ -> () VirtualRegF _ -> () VirtualRegD _ -> () +seqRealReg :: RealReg -> () +seqRealReg reg + = case reg of + RealRegSingle _ -> () + RealRegPair _ _ -> () + seqRegClass :: RegClass -> () seqRegClass c = case c of @@ -358,17 +394,23 @@ seqRegClass c RcFloat -> () RcDouble -> () -seqMaybeReg :: Maybe Reg -> () -seqMaybeReg mr +seqMaybeRealReg :: Maybe RealReg -> () +seqMaybeRealReg mr = case mr of Nothing -> () - Just r -> seqReg r + Just r -> seqRealReg r + +seqVirtualRegList :: [VirtualReg] -> () +seqVirtualRegList rs + = case rs of + [] -> () + (r : rs) -> seqVirtualReg r `seq` seqVirtualRegList rs -seqRegList :: [Reg] -> () -seqRegList rs +seqRealRegList :: [RealReg] -> () +seqRealRegList rs = case rs of [] -> () - (r : rs) -> seqReg r `seq` seqRegList rs + (r : rs) -> seqRealReg r `seq` seqRealRegList rs seqList :: [a] -> () seqList ls diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index e6e5622..ce34b51 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -37,7 +37,7 @@ regSpill :: Instruction instr => [LiveCmmTop instr] -- ^ the code -> UniqSet Int -- ^ available stack slots - -> UniqSet Reg -- ^ the regs to spill + -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM ([LiveCmmTop instr] -- code will spill instructions , UniqSet Int -- left over slots @@ -190,7 +190,9 @@ patchInstr patchInstr reg instr = do nUnique <- newUnique - let nReg = renameVirtualReg nUnique reg + let nReg = case reg of + RegVirtual vr -> RegVirtual (renameVirtualReg nUnique vr) + RegReal{} -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" let instr' = patchReg1 reg nReg instr return (instr', nReg) diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index 4f129c4..9d0dcf9 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -436,9 +436,12 @@ isStoreReg ss -- instance Uniquable Store where getUnique (SReg r) - | RealReg i <- r + | RegReal (RealRegSingle i) <- r = mkUnique 'R' i + | RegReal (RealRegPair r1 r2) <- r + = mkUnique 'P' (r1 * 65535 + r2) + | otherwise = error "RegSpillClean.getUnique: found virtual reg during spill clean, only real regs expected." diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index d4dd75a..ff3f76a 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -36,10 +36,10 @@ import Data.Maybe import Control.Monad type SpillCostRecord - = ( Reg -- register name - , Int -- number of writes to this reg - , Int -- number of reads from this reg - , Int) -- number of instrs this reg was live on entry to + = ( VirtualReg -- register name + , Int -- number of writes to this reg + , Int -- number of reads from this reg + , Int) -- number of instrs this reg was live on entry to type SpillCostInfo = UniqFM SpillCostRecord @@ -83,7 +83,11 @@ slurpSpillCostInfo cmm countBlock info (BasicBlock blockId instrs) | LiveInfo _ _ blockLive <- info , Just rsLiveEntry <- lookupBlockEnv blockLive blockId - = countLIs rsLiveEntry instrs + + , rsLiveEntry_virt <- mapUniqSet (\(RegVirtual vr) -> vr) + $ filterUniqSet isVirtualReg rsLiveEntry + + = countLIs rsLiveEntry_virt instrs | otherwise = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block" @@ -113,16 +117,24 @@ slurpSpillCostInfo cmm -- increment counts for what regs were read/written from let (RU read written) = regUsageOfInstr instr - mapM_ incUses $ filter (not . isRealReg) $ nub read - mapM_ incDefs $ filter (not . isRealReg) $ nub written + mapM_ incUses $ catMaybes $ map takeVirtualReg $ nub read + mapM_ incDefs $ catMaybes $ map takeVirtualReg $ nub written -- compute liveness for entry to next instruction. + let takeVirtuals set + = mapUniqSet (\(RegVirtual vr) -> vr) + $ filterUniqSet isVirtualReg set + + let liveDieRead_virt = takeVirtuals (liveDieRead live) + let liveDieWrite_virt = takeVirtuals (liveDieWrite live) + let liveBorn_virt = takeVirtuals (liveBorn live) + let rsLiveAcross - = rsLiveEntry `minusUniqSet` (liveDieRead live) + = rsLiveEntry `minusUniqSet` liveDieRead_virt let rsLiveNext - = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) + = (rsLiveAcross `unionUniqSets` liveBorn_virt) + `minusUniqSet` liveDieWrite_virt countLIs rsLiveNext lis @@ -135,8 +147,8 @@ slurpSpillCostInfo cmm chooseSpill :: SpillCostInfo - -> Graph Reg RegClass Reg - -> Reg + -> Graph VirtualReg RegClass RealReg + -> VirtualReg chooseSpill info graph = let cost = spillCost_length info graph @@ -212,19 +224,20 @@ spillCost_chaitin info graph reg -- Just spill the longest live range. spillCost_length :: SpillCostInfo - -> Graph Reg RegClass Reg - -> Reg + -> Graph VirtualReg RegClass RealReg + -> VirtualReg -> Float spillCost_length info _ reg | lifetime <= 1 = 1/0 | otherwise = 1 / fromIntegral lifetime where (_, _, _, lifetime) - = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg + = fromMaybe (reg, 0, 0, 0) + $ lookupUFM info reg -lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (Reg, Int) +lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int) lifeMapFromSpillCostInfo info = listToUFM $ map (\(r, _, _, life) -> (r, (r, life))) @@ -233,13 +246,19 @@ lifeMapFromSpillCostInfo info -- | Work out the degree (number of neighbors) of this node which have the same class. nodeDegree - :: (Reg -> RegClass) - -> Graph Reg RegClass Reg -> Reg -> Int + :: (VirtualReg -> RegClass) + -> Graph VirtualReg RegClass RealReg + -> VirtualReg + -> Int -nodeDegree regClass graph reg +nodeDegree classOfVirtualReg graph reg | Just node <- lookupUFM (graphMap graph) reg - , virtConflicts <- length $ filter (\r -> regClass r == regClass reg) - $ uniqSetToList $ nodeConflicts node + + , virtConflicts <- length + $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg) + $ uniqSetToList + $ nodeConflicts node + = virtConflicts + sizeUniqSet (nodeExclusions node) | otherwise @@ -248,16 +267,20 @@ nodeDegree regClass graph reg -- | Show a spill cost record, including the degree from the graph and final calulated spill cos pprSpillCostRecord - :: (Reg -> RegClass) + :: (VirtualReg -> RegClass) -> (Reg -> SDoc) - -> Graph Reg RegClass Reg -> SpillCostRecord -> SDoc + -> Graph VirtualReg RegClass RealReg + -> SpillCostRecord + -> SDoc pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life) = hsep - [ pprReg reg + [ pprReg (RegVirtual reg) , ppr uses , ppr defs , ppr life , ppr $ nodeDegree regClass graph reg , text $ show $ (fromIntegral (uses + defs) / fromIntegral (nodeDegree regClass graph reg) :: Float) ] + + diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 5e3dd32..10ab0cb 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -39,27 +39,27 @@ data RegAllocStats instr -- initial graph = RegAllocStatsStart - { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness - , raGraph :: Color.Graph Reg RegClass Reg -- ^ the initial, uncolored graph - , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill + { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness + , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph + , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill -- a spill stage | RegAllocStatsSpill - { raGraph :: Color.Graph Reg RegClass Reg -- ^ the partially colored graph - , raCoalesced :: UniqFM Reg -- ^ the regs that were coaleced - , raSpillStats :: SpillStats -- ^ spiller stats - , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for - , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added + { raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph + , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced + , raSpillStats :: SpillStats -- ^ spiller stats + , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for + , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added -- a successful coloring | RegAllocStatsColored - { raGraph :: Color.Graph Reg RegClass Reg -- ^ the uncolored graph - , raGraphColored :: Color.Graph Reg RegClass Reg -- ^ the coalesced and colored graph - , raCoalesced :: UniqFM Reg -- ^ the regs that were coaleced - , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs - , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out - , raFinal :: [NatCmmTop instr] -- ^ final code - , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code + { raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph + , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph + , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced + , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs + , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out + , raFinal :: [NatCmmTop instr] -- ^ final code + , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code instance Outputable instr => Outputable (RegAllocStats instr) where @@ -132,7 +132,11 @@ instance Outputable instr => Outputable (RegAllocStats instr) where $$ text "" -- | Do all the different analysis on this list of RegAllocStats -pprStats :: [RegAllocStats instr] -> Color.Graph Reg RegClass Reg -> SDoc +pprStats + :: [RegAllocStats instr] + -> Color.Graph VirtualReg RegClass RealReg + -> SDoc + pprStats stats graph = let outSpills = pprStatsSpills stats outLife = pprStatsLifetimes stats @@ -176,7 +180,7 @@ pprStatsLifetimes stats $$ (vcat $ map ppr $ eltsUFM lifeBins) $$ text "\n") -binLifetimeCount :: UniqFM (Reg, Int) -> UniqFM (Int, Int) +binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int) binLifetimeCount fm = let lifes = map (\l -> (l, (l, 1))) $ map snd @@ -208,7 +212,7 @@ pprStatsConflict stats -- good for making a scatter plot. pprStatsLifeConflict :: [RegAllocStats instr] - -> Color.Graph Reg RegClass Reg -- ^ global register conflict graph + -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph -> SDoc pprStatsLifeConflict stats graph diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs index df04606..5f3f0ac 100644 --- a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs +++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-unused-binds #-} module RegAlloc.Graph.TrivColorable ( trivColorable, @@ -15,51 +16,136 @@ import GraphBase import UniqFM import FastTypes -{- --- allocatableRegs is allMachRegNos with the fixed-use regs removed. --- i.e., these are the regs for which we are prepared to allow the --- register allocator to attempt to map VRegs to. -allocatableRegs :: [RegNo] -allocatableRegs - = let isFree i = isFastTrue (freeReg i) - in filter isFree allMachRegNos - - --- | The number of regs in each class. --- We go via top level CAFs to ensure that we're not recomputing --- the length of these lists each time the fn is called. -allocatableRegsInClass :: RegClass -> Int -allocatableRegsInClass cls - = case cls of - RcInteger -> allocatableRegsInteger - RcDouble -> allocatableRegsDouble - RcFloat -> panic "Regs.allocatableRegsInClass: no match\n" - -allocatableRegsInteger :: Int -allocatableRegsInteger - = length $ filter (\r -> regClass r == RcInteger) - $ map RealReg allocatableRegs - -allocatableRegsDouble :: Int -allocatableRegsDouble - = length $ filter (\r -> regClass r == RcDouble) - $ map RealReg allocatableRegs --} - -- trivColorable --------------------------------------------------------------- -- trivColorable function for the graph coloring allocator +-- -- This gets hammered by scanGraph during register allocation, -- so needs to be fairly efficient. -- -- NOTE: This only works for arcitectures with just RcInteger and RcDouble -- (which are disjoint) ie. x86, x86_64 and ppc -- - -- BL 2007/09 -- Doing a nice fold over the UniqSet makes trivColorable use -- 32% of total compile time and 42% of total alloc when compiling SHA1.lhs from darcs. +-- +-- The number of allocatable regs is hard coded here so we can do a fast +-- comparision in trivColorable. +-- +-- It's ok if these numbers are _less_ than the actual number of free regs, +-- but they can't be more or the register conflict graph won't color. +-- +-- If the graph doesn't color then the allocator will panic, but it won't +-- generate bad object code or anything nasty like that. +-- +-- There is an allocatableRegsInClass :: RegClass -> Int, but doing the unboxing +-- is too slow for us here. +-- +-- Look at includes/MachRegs.h to get these numbers. +-- + +#if i386_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER (_ILIT(3)) +#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6)) +#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) + + +#elif x86_64_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER (_ILIT(5)) +#define ALLOCATABLE_REGS_DOUBLE (_ILIT(2)) +#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) + + +#elif powerpc_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER (_ILIT(16)) +#define ALLOCATABLE_REGS_DOUBLE (_ILIT(26)) +#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) + + +#elif sparc_TARGET_ARCH +#define ALLOCATABLE_REGS_INTEGER (_ILIT(14)) +#define ALLOCATABLE_REGS_DOUBLE (_ILIT(11)) +#define ALLOCATABLE_REGS_FLOAT (_ILIT(22)) + + +#else +#error ToDo: choose which trivColorable function to use for this architecture. +#endif + + + +-- Disjoint registers ---------------------------------------------------------- +-- +-- The definition has been unfolded into individual cases for speed. +-- Each architecture has a different register setup, so we use a +-- different regSqueeze function for each. +-- +accSqueeze + :: FastInt + -> FastInt + -> (reg -> FastInt) + -> UniqFM reg + -> FastInt + +accSqueeze count maxCount squeeze ufm + = case ufm of + NodeUFM _ _ left right + -> case accSqueeze count maxCount squeeze right of + count' -> case count' >=# maxCount of + False -> accSqueeze count' maxCount squeeze left + True -> count' + + LeafUFM _ reg -> count +# squeeze reg + EmptyUFM -> count + + +trivColorable + :: (RegClass -> VirtualReg -> FastInt) + -> (RegClass -> RealReg -> FastInt) + -> Triv VirtualReg RegClass RealReg + +trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions + | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_INTEGER + (virtualRegSqueeze RcInteger) + conflicts + + , count3 <- accSqueeze count2 ALLOCATABLE_REGS_INTEGER + (realRegSqueeze RcInteger) + exclusions + + = count3 <# ALLOCATABLE_REGS_INTEGER + +trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions + | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_FLOAT + (virtualRegSqueeze RcFloat) + conflicts + + , count3 <- accSqueeze count2 ALLOCATABLE_REGS_FLOAT + (realRegSqueeze RcFloat) + exclusions + + = count3 <# ALLOCATABLE_REGS_FLOAT + +trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions + | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_DOUBLE + (virtualRegSqueeze RcDouble) + conflicts + + , count3 <- accSqueeze count2 ALLOCATABLE_REGS_DOUBLE + (realRegSqueeze RcDouble) + exclusions + + = count3 <# ALLOCATABLE_REGS_DOUBLE + + +-- Specification Code ---------------------------------------------------------- +-- +-- The trivColorable function for each particular architecture should +-- implement the following function, but faster. +-- + {- trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool trivColorable classN conflicts exclusions @@ -69,14 +155,14 @@ trivColorable classN conflicts exclusions acc r (cd, cf) = case regClass r of RcInteger -> (cd+1, cf) - RcDouble -> (cd, cf+1) + RcFloat -> (cd, cf+1) _ -> panic "Regs.trivColorable: reg class not handled" tmp = foldUniqSet acc (0, 0) conflicts (countInt, countFloat) = foldUniqSet acc tmp exclusions squeese = worst countInt classN RcInteger - + worst countFloat classN RcDouble + + worst countFloat classN RcFloat in squeese < allocatableRegsInClass classN @@ -92,85 +178,38 @@ worst n classN classC RcInteger -> case classC of RcInteger -> min n (allocatableRegsInClass RcInteger) - RcDouble -> 0 + RcFloat -> 0 RcDouble -> case classC of - RcDouble -> min n (allocatableRegsInClass RcDouble) + RcFloat -> min n (allocatableRegsInClass RcFloat) RcInteger -> 0 --} - --- The number of allocatable regs is hard coded here so we can do a fast comparision --- in trivColorable. It's ok if these numbers are _less_ than the actual number of --- free regs, but they can't be more or the register conflict graph won't color. --- --- There is an allocatableRegsInClass :: RegClass -> Int, but doing the unboxing --- is too slow for us here. --- --- Compare Regs.freeRegs and MachRegs.h to get these numbers. --- -#if i386_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(3)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) - -#elif x86_64_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(5)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(2)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) +-- allocatableRegs is allMachRegNos with the fixed-use regs removed. +-- i.e., these are the regs for which we are prepared to allow the +-- register allocator to attempt to map VRegs to. +allocatableRegs :: [RegNo] +allocatableRegs + = let isFree i = isFastTrue (freeReg i) + in filter isFree allMachRegNos -#elif powerpc_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(16)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(26)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) -#elif sparc_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(14)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(8)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(6)) +-- | The number of regs in each class. +-- We go via top level CAFs to ensure that we're not recomputing +-- the length of these lists each time the fn is called. +allocatableRegsInClass :: RegClass -> Int +allocatableRegsInClass cls + = case cls of + RcInteger -> allocatableRegsInteger + RcFloat -> allocatableRegsDouble -#else -#error ToDo: define ALLOCATABLE_REGS_INTEGER and ALLOCATABLE_REGS_DOUBLE -#endif +allocatableRegsInteger :: Int +allocatableRegsInteger + = length $ filter (\r -> regClass r == RcInteger) + $ map RealReg allocatableRegs -trivColorable - :: (Reg -> RegClass) - -> Triv Reg RegClass Reg - -trivColorable regClass _ conflicts exclusions - = {-# SCC "trivColorable" #-} - let - isSqueesed cI cF ufm - = case ufm of - NodeUFM _ _ left right - -> case isSqueesed cI cF right of - (# s, cI', cF' #) - -> case s of - False -> isSqueesed cI' cF' left - True -> (# True, cI', cF' #) - - LeafUFM _ reg - -> case regClass reg of - RcInteger - -> case cI +# _ILIT(1) of - cI' -> (# cI' >=# ALLOCATABLE_REGS_INTEGER, cI', cF #) - - RcDouble - -> case cF +# _ILIT(1) of - cF' -> (# cF' >=# ALLOCATABLE_REGS_DOUBLE, cI, cF' #) - - RcFloat - -> case cF +# _ILIT(1) of - cF' -> (# cF' >=# ALLOCATABLE_REGS_FLOAT, cI, cF' #) - - EmptyUFM - -> (# False, cI, cF #) - - in case isSqueesed (_ILIT(0)) (_ILIT(0)) conflicts of - (# False, cI', cF' #) - -> case isSqueesed cI' cF' exclusions of - (# s, _, _ #) -> not s - - (# True, _, _ #) - -> False +allocatableRegsFloat :: Int +allocatableRegsFloat + = length $ filter (\r -> regClass r == RcFloat + $ map RealReg allocatableRegs +-} diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs index 45fd640..2626232 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Base.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs @@ -51,14 +51,14 @@ type BlockAssignment -- data Loc -- | vreg is in a register - = InReg {-# UNPACK #-} !RegNo + = InReg {-# UNPACK #-} !RealReg -- | vreg is held in a stack slot - | InMem {-# UNPACK #-} !StackSlot + | InMem {-# UNPACK #-} !StackSlot -- | vreg is held in both a register and a stack slot - | InBoth {-# UNPACK #-} !RegNo + | InBoth {-# UNPACK #-} !RealReg {-# UNPACK #-} !StackSlot deriving (Eq, Show, Ord) @@ -67,7 +67,7 @@ instance Outputable Loc where -- | Get the reg numbers stored in this Loc. -regsOfLoc :: Loc -> [RegNo] +regsOfLoc :: Loc -> [RealReg] regsOfLoc (InReg r) = [r] regsOfLoc (InBoth r _) = [r] regsOfLoc (InMem _) = [] diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index 7d2cbcd..8ff06eb 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -110,7 +110,8 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) -- this is the first time we jumped to this block. joinToTargets_first block_live new_blocks block_id instr dest dests - block_assig src_assig to_free + block_assig src_assig + (to_free :: [RealReg]) = do -- free up the regs that are not live on entry to this block. freeregs <- getFreeRegsR @@ -292,10 +293,10 @@ handleComponent delta instr = do -- spill the source into its slot (instrSpill, slot) - <- spillR (RealReg sreg) vreg + <- spillR (RegReal sreg) vreg -- reload into destination reg - instrLoad <- loadR (RealReg dreg) slot + instrLoad <- loadR (RegReal dreg) slot remainingFixUps <- mapM (handleComponent delta instr) (stronglyConnCompFromEdgedVerticesR rest) @@ -320,15 +321,15 @@ makeMove makeMove _ vreg (InReg src) (InReg dst) = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr (RealReg src) (RealReg dst) + return $ mkRegRegMoveInstr (RegReal src) (RegReal dst) makeMove delta vreg (InMem src) (InReg dst) = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr (RealReg dst) delta src + return $ mkLoadInstr (RegReal dst) delta src makeMove delta vreg (InReg src) (InMem dst) = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr (RealReg src) delta dst + return $ mkSpillInstr (RegReal src) delta dst -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share stack slots between vregs. diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index 47529d2..00e01d7 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -101,8 +101,6 @@ import RegAlloc.Liveness import Instruction import Reg --- import PprMach - import BlockId import Cmm hiding (RegSet) @@ -256,7 +254,9 @@ initBlock id -- no prior info about this block: assume everything is -- free and the assignment is empty. Nothing - -> do setFreeRegsR initFreeRegs + -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) + + setFreeRegsR initFreeRegs setAssigR emptyRegMap -- load info about register assignments leading into this block. @@ -330,7 +330,7 @@ raInsn block_live new_instrs id (Instr instr (Just live)) not (dst `elemUFM` assig), Just (InReg _) <- (lookupUFM assig src) -> do case src of - RealReg i -> setAssigR (addToUFM assig dst (InReg i)) + (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) -- if src is a fixed reg, then we just map dest to this -- reg in the assignment. src must be an allocatable reg, -- otherwise it wouldn't be in r_dying. @@ -361,27 +361,30 @@ raInsn _ _ _ instr genRaInsn block_live new_instrs block_id instr r_dying w_dying = case regUsageOfInstr instr of { RU read written -> - case partition isRealReg written of { (real_written1,virt_written) -> do - let - real_written = [ r | RealReg r <- real_written1 ] + let real_written = [ rr | (RegReal rr) <- written ] + let virt_written = [ vr | (RegVirtual vr) <- written ] - -- we don't need to do anything with real registers that are - -- only read by this instr. (the list is typically ~2 elements, - -- so using nub isn't a problem). - virt_read = nub (filter isVirtualReg read) - -- in + -- we don't need to do anything with real registers that are + -- only read by this instr. (the list is typically ~2 elements, + -- so using nub isn't a problem). + let virt_read = nub [ vr | (RegVirtual vr) <- read ] -- (a) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying - + clobber_saves <- saveClobberedTemps real_written r_dying -{- freeregs <- getFreeRegsR + -- debugging +{- freeregs <- getFreeRegsR assig <- getAssigR pprTrace "genRaInsn" - (docToSDoc (pprInstr instr) $$ ppr r_dying <+> ppr w_dying $$ ppr virt_read <+> ppr virt_written - $$ text (show freeregs) $$ ppr assig) - $ do + (ppr instr + $$ text "r_dying = " <+> ppr r_dying + $$ text "w_dying = " <+> ppr w_dying + $$ text "virt_read = " <+> ppr virt_read + $$ text "virt_written = " <+> ppr virt_written + $$ text "freeregs = " <+> text (show freeregs) + $$ text "assig = " <+> ppr assig) + $ do -} -- (b), (c) allocate real regs for all regs read by this instruction. @@ -412,17 +415,20 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = let -- (i) Patch the instruction - patch_map = listToUFM [ (t,RealReg r) | - (t,r) <- zip virt_read r_allocd - ++ zip virt_written w_allocd ] + patch_map + = listToUFM + [ (t, RegReal r) + | (t, r) <- zip virt_read r_allocd + ++ zip virt_written w_allocd ] + + patched_instr + = patchRegsOfInstr adjusted_instr patchLookup - patched_instr = patchRegsOfInstr adjusted_instr patchLookup - patchLookup x = case lookupUFM patch_map x of - Nothing -> x - Just y -> y - -- in + patchLookup x + = case lookupUFM patch_map x of + Nothing -> x + Just y -> y --- pprTrace "patched" (docToSDoc (pprInstr patched_instr)) $ do -- (j) free up stack slots for dead spilled regs -- TODO (can't be bothered right now) @@ -443,7 +449,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying = return (code, fixup_blocks) - }} + } -- ----------------------------------------------------------------------------- -- releaseRegs @@ -455,79 +461,103 @@ releaseRegs regs = do where loop _ free _ | free `seq` False = undefined loop assig free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig free (RealReg r : rs) = loop assig (releaseReg r free) rs + loop assig free (RegReal rr : rs) = loop assig (releaseReg rr free) rs loop assig free (r:rs) = case lookupUFM assig r of Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs _other -> loop (delFromUFM assig r) free rs + -- ----------------------------------------------------------------------------- -- Clobber real registers -{- -For each temp in a register that is going to be clobbered: - - if the temp dies after this instruction, do nothing - - otherwise, put it somewhere safe (another reg if possible, - otherwise spill and record InBoth in the assignment). - -for allocateRegs on the temps *read*, - - clobbered regs are allocatable. +-- For each temp in a register that is going to be clobbered: +-- - if the temp dies after this instruction, do nothing +-- - otherwise, put it somewhere safe (another reg if possible, +-- otherwise spill and record InBoth in the assignment). +-- - for allocateRegs on the temps *read*, +-- - clobbered regs are allocatable. +-- +-- for allocateRegs on the temps *written*, +-- - clobbered regs are not allocatable. +-- +-- TODO: instead of spilling, try to copy clobbered +-- temps to another register if possible. +-- -for allocateRegs on the temps *written*, - - clobbered regs are not allocatable. --} saveClobberedTemps :: Instruction instr - => [RegNo] -- real registers clobbered by this instruction + => [RealReg] -- real registers clobbered by this instruction -> [Reg] -- registers which are no longer live after this insn -> RegM [instr] -- return: instructions to spill any temps that will -- be clobbered. -saveClobberedTemps [] _ = return [] -- common case -saveClobberedTemps clobbered dying = do - assig <- getAssigR - let - to_spill = [ (temp,reg) | (temp, InReg reg) <- ufmToList assig, - reg `elem` clobbered, - temp `notElem` map getUnique dying ] - -- in - (instrs,assig') <- clobber assig [] to_spill - setAssigR assig' - return instrs - where - clobber assig instrs [] = return (instrs,assig) - clobber assig instrs ((temp,reg):rest) - = do - --ToDo: copy it to another register if possible - (spill,slot) <- spillR (RealReg reg) temp - recordSpill (SpillClobber temp) - - let new_assign = addToUFM assig temp (InBoth reg slot) - clobber new_assign (spill : {- COMMENT (fsLit "spill clobber") : -} instrs) rest - -clobberRegs :: [RegNo] -> RegM () -clobberRegs [] = return () -- common case -clobberRegs clobbered = do - freeregs <- getFreeRegsR --- setFreeRegsR $! foldr grabReg freeregs clobbered - setFreeRegsR $! foldr allocateReg freeregs clobbered +saveClobberedTemps [] _ + = return [] - assig <- getAssigR - setAssigR $! clobber assig (ufmToList assig) - where - -- if the temp was InReg and clobbered, then we will have - -- saved it in saveClobberedTemps above. So the only case - -- we have to worry about here is InBoth. Note that this - -- also catches temps which were loaded up during allocation - -- of read registers, not just those saved in saveClobberedTemps. - clobber assig [] = assig - clobber assig ((temp, InBoth reg slot) : rest) - | reg `elem` clobbered - = clobber (addToUFM assig temp (InMem slot)) rest - clobber assig (_:rest) - = clobber assig rest +saveClobberedTemps clobbered dying + = do + assig <- getAssigR + let to_spill + = [ (temp,reg) + | (temp, InReg reg) <- ufmToList assig + , any (realRegsAlias reg) clobbered + , temp `notElem` map getUnique dying ] + + (instrs,assig') <- clobber assig [] to_spill + setAssigR assig' + return instrs + + where + clobber assig instrs [] + = return (instrs, assig) + + clobber assig instrs ((temp, reg) : rest) + = do + (spill, slot) <- spillR (RegReal reg) temp + + -- record why this reg was spilled for profiling + recordSpill (SpillClobber temp) + + let new_assign = addToUFM assig temp (InBoth reg slot) + + clobber new_assign (spill : instrs) rest + + + +-- | Mark all these regal regs as allocated, +-- and kick out their vreg assignments. +-- +clobberRegs :: [RealReg] -> RegM () +clobberRegs [] + = return () + +clobberRegs clobbered + = do + freeregs <- getFreeRegsR + setFreeRegsR $! foldr allocateReg freeregs clobbered + + assig <- getAssigR + setAssigR $! clobber assig (ufmToList assig) + + where + -- if the temp was InReg and clobbered, then we will have + -- saved it in saveClobberedTemps above. So the only case + -- we have to worry about here is InBoth. Note that this + -- also catches temps which were loaded up during allocation + -- of read registers, not just those saved in saveClobberedTemps. + + clobber assig [] + = assig + + clobber assig ((temp, InBoth reg slot) : rest) + | any (realRegsAlias reg) clobbered + = clobber (addToUFM assig temp (InMem slot)) rest + + clobber assig (_:rest) + = clobber assig rest -- ----------------------------------------------------------------------------- -- allocateRegsAndSpill @@ -542,126 +572,145 @@ clobberRegs clobbered = do allocateRegsAndSpill :: Instruction instr => Bool -- True <=> reading (load up spilled regs) - -> [Reg] -- don't push these out + -> [VirtualReg] -- don't push these out -> [instr] -- spill insns - -> [RegNo] -- real registers allocated (accum.) - -> [Reg] -- temps to allocate - -> RegM ([instr], [RegNo]) + -> [RealReg] -- real registers allocated (accum.) + -> [VirtualReg] -- temps to allocate + -> RegM ( [instr] + , [RealReg]) allocateRegsAndSpill _ _ spills alloc [] - = return (spills,reverse alloc) - -allocateRegsAndSpill reading keep spills alloc (r:rs) = do - assig <- getAssigR - case lookupUFM assig r of - -- case (1a): already in a register - Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignemnt to be - -- InReg, because the memory value is no longer valid. - -- NB2. This is why we must process written registers here, even if they - -- are also read by the same instruction. - Just (InBoth my_reg _) -> do - when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- Not already in a register, so we need to find a free one... - loc -> do - freeregs <- getFreeRegsR - - case getFreeRegs (targetRegClass r) freeregs of - - -- case (2): we have a free register - my_reg:_ -> {- pprTrace "alloc" (ppr r <+> ppr my_reg <+> ppr freeClass) $ -} - do - spills' <- loadTemp reading r loc my_reg spills - let new_loc - | Just (InMem slot) <- loc, reading = InBoth my_reg slot - | otherwise = InReg my_reg - setAssigR (addToUFM assig r $! new_loc) - setFreeRegsR $ allocateReg my_reg freeregs - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- case (3): we need to push something out to free up a register - [] -> do - let - keep' = map getUnique keep - candidates1 = [ (temp,reg,mem) - | (temp, InBoth reg mem) <- ufmToList assig, - temp `notElem` keep', targetRegClass (RealReg reg) == targetRegClass r ] - candidates2 = [ (temp,reg) - | (temp, InReg reg) <- ufmToList assig, - temp `notElem` keep', targetRegClass (RealReg reg) == targetRegClass r ] - -- in - ASSERT2(not (null candidates1 && null candidates2), - text (show freeregs) <+> ppr r <+> ppr assig) do - - case candidates1 of - - -- we have a temporary that is in both register and mem, - -- just free up its register for use. - -- - (temp,my_reg,slot):_ -> do - spills' <- loadTemp reading r loc my_reg spills - let - assig1 = addToUFM assig temp (InMem slot) - assig2 = addToUFM assig1 r (InReg my_reg) - -- in - setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- otherwise, we need to spill a temporary that currently - -- resides in a register. - - - [] -> do - - -- TODO: plenty of room for optimisation in choosing which temp - -- to spill. We just pick the first one that isn't used in - -- the current instruction for now. - - let (temp_to_push_out, my_reg) - = case candidates2 of - [] -> panic $ "RegAllocLinear.allocRegsAndSpill: no spill candidates" - ++ "assignment: " ++ show (ufmToList assig) ++ "\n" - (x:_) -> x - - (spill_insn, slot) <- spillR (RealReg my_reg) temp_to_push_out - let spill_store = (if reading then id else reverse) - [ -- COMMENT (fsLit "spill alloc") - spill_insn ] - - -- record that this temp was spilled - recordSpill (SpillAlloc temp_to_push_out) - - -- update the register assignment - let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) - setAssigR assig2 - - -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp reading r loc my_reg spills - - allocateRegsAndSpill reading keep - (spill_store ++ spills') - (my_reg:alloc) rs + = return (spills, reverse alloc) + +allocateRegsAndSpill reading keep spills alloc (r:rs) + = do assig <- getAssigR + case lookupUFM assig r of + -- case (1a): already in a register + Just (InReg my_reg) -> + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- case (1b): already in a register (and memory) + -- NB1. if we're writing this register, update its assignemnt to be + -- InReg, because the memory value is no longer valid. + -- NB2. This is why we must process written registers here, even if they + -- are also read by the same instruction. + Just (InBoth my_reg _) + -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) + allocateRegsAndSpill reading keep spills (my_reg:alloc) rs + + -- Not already in a register, so we need to find a free one... + loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig + +allocRegsAndSpill_spill reading keep spills alloc r rs loc assig + = do + freeRegs <- getFreeRegsR + let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs + + case freeRegs_thisClass of + + -- case (2): we have a free register + (my_reg : _) -> + do spills' <- loadTemp reading r loc my_reg spills + + let new_loc + -- if the tmp was in a slot, then now its in a reg as well + | Just (InMem slot) <- loc + , reading + = InBoth my_reg slot + + -- tmp has been loaded into a reg + | otherwise + = InReg my_reg + + setAssigR (addToUFM assig r $! new_loc) + setFreeRegsR $ allocateReg my_reg freeRegs + + allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs + + + -- case (3): we need to push something out to free up a register + [] -> + do let keep' = map getUnique keep + + -- the vregs we could kick out that are already in a slot + let candidates_inBoth + = [ (temp, reg, mem) + | (temp, InBoth reg mem) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg reg == classOfVirtualReg r ] + + -- the vregs we could kick out that are only in a reg + -- this would require writing the reg to a new slot before using it. + let candidates_inReg + = [ (temp, reg) + | (temp, InReg reg) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg reg == classOfVirtualReg r ] + + let result + + -- we have a temporary that is in both register and mem, + -- just free up its register for use. + | (temp, my_reg, slot) : _ <- candidates_inBoth + = do spills' <- loadTemp reading r loc my_reg spills + let assig1 = addToUFM assig temp (InMem slot) + let assig2 = addToUFM assig1 r (InReg my_reg) + + setAssigR assig2 + allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs + + -- otherwise, we need to spill a temporary that currently + -- resides in a register. + | (temp_to_push_out, (my_reg :: RealReg)) : _ + <- candidates_inReg + = do + (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out + let spill_store = (if reading then id else reverse) + [ -- COMMENT (fsLit "spill alloc") + spill_insn ] + + -- record that this temp was spilled + recordSpill (SpillAlloc temp_to_push_out) + + -- update the register assignment + let assig1 = addToUFM assig temp_to_push_out (InMem slot) + let assig2 = addToUFM assig1 r (InReg my_reg) + setAssigR assig2 + + -- if need be, load up a spilled temp into the reg we've just freed up. + spills' <- loadTemp reading r loc my_reg spills + + allocateRegsAndSpill reading keep + (spill_store ++ spills') + (my_reg:alloc) rs + + + -- there wasn't anything to spill, so we're screwed. + | otherwise + = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") + $ vcat + [ text "allocating vreg: " <> text (show r) + , text "assignment: " <> text (show $ ufmToList assig) + , text "freeRegs: " <> text (show freeRegs) + , text "initFreeRegs: " <> text (show initFreeRegs) ] + + result + -- | Load up a spilled temporary if we need to. loadTemp :: Instruction instr => Bool - -> Reg -- the temp being loaded + -> VirtualReg -- the temp being loaded -> Maybe Loc -- the current location of this temp - -> RegNo -- the hreg to load the temp into + -> RealReg -- the hreg to load the temp into -> [instr] -> RegM [instr] loadTemp True vreg (Just (InMem slot)) hreg spills = do - insn <- loadR (RealReg hreg) slot + insn <- loadR (RegReal hreg) slot recordSpill (SpillLoad $ getUnique vreg) return $ {- COMMENT (fsLit "spill load") : -} insn : spills diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs index ac16d8a..d828347 100644 --- a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs @@ -33,8 +33,9 @@ data FreeRegs !Word32 -- int reg bitmap regs 0..31 !Word32 -- float reg bitmap regs 32..63 !Word32 -- double reg bitmap regs 32..63 - deriving( Show ) +instance Show FreeRegs where + show = showFreeRegs -- | A reg map where no regs are free to be allocated. noFreeRegs :: FreeRegs @@ -42,129 +43,144 @@ noFreeRegs = FreeRegs 0 0 0 -- | The initial set of free regs. --- Don't treat the top half of reg pairs we're using as doubles as being free. initFreeRegs :: FreeRegs initFreeRegs - = regs - where --- freeDouble = getFreeRegs RcDouble regs - regs = foldr releaseReg noFreeRegs allocable - allocable = allocatableRegs \\ doublePairs - doublePairs = [43, 45, 47, 49, 51, 53] + = foldr releaseReg noFreeRegs allocatableRegs -- | Get all the free registers of this class. -getFreeRegs :: RegClass -> FreeRegs -> [RegNo] -- lazilly +getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazilly getFreeRegs cls (FreeRegs g f d) - | RcInteger <- cls = go g 1 0 - | RcFloat <- cls = go f 1 32 - | RcDouble <- cls = go d 1 32 + | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0 + | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32 + | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32 | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls) where - go _ 0 _ = [] - go x m i | x .&. m /= 0 = i : (go x (m `shiftL` 1) $! i+1) - | otherwise = go x (m `shiftL` 1) $! i+1 -{- -showFreeRegs :: FreeRegs -> String -showFreeRegs regs - = "FreeRegs\n" - ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" - ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" - ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" --} - -{- --- | Check whether a reg is free -regIsFree :: RegNo -> FreeRegs -> Bool -regIsFree r (FreeRegs g f d) + go _ _ 0 _ + = [] - -- a general purpose reg - | r <= 31 - , mask <- 1 `shiftL` fromIntegral r - = g .&. mask /= 0 + go step bitmap mask ix + | bitmap .&. mask /= 0 + = ix : (go step bitmap (mask `shiftL` step) $! ix + step) - -- use the first 22 float regs as double precision - | r >= 32 - , r <= 53 - , mask <- 1 `shiftL` (fromIntegral r - 32) - = d .&. mask /= 0 + | otherwise + = go step bitmap (mask `shiftL` step) $! ix + step - -- use the last 10 float regs as single precision - | otherwise - , mask <- 1 `shiftL` (fromIntegral r - 32) - = f .&. mask /= 0 --} -- | Grab a register. -grabReg :: RegNo -> FreeRegs -> FreeRegs -grabReg r (FreeRegs g f d) +allocateReg :: RealReg -> FreeRegs -> FreeRegs +allocateReg + reg@(RealRegSingle r) + (FreeRegs g f d) + -- can't allocate free regs + | not $ isFastTrue (freeReg r) + = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg) + -- a general purpose reg | r <= 31 - , mask <- complement (1 `shiftL` fromIntegral r) - = FreeRegs (g .&. mask) f d - - -- use the first 22 float regs as double precision - | r >= 32 - , r <= 53 - , mask <- complement (1 `shiftL` (fromIntegral r - 32)) - = FreeRegs g f (d .&. mask) - - -- use the last 10 float regs as single precision - | otherwise - , mask <- complement (1 `shiftL` (fromIntegral r - 32)) - = FreeRegs g (f .&. mask) d + = let mask = complement (bitMask r) + in FreeRegs + (g .&. mask) + f + d + + -- a float reg + | r >= 32, r <= 63 + = let mask = complement (bitMask (r - 32)) + + -- the mask of the double this FP reg aliases + maskLow = if r `mod` 2 == 0 + then complement (bitMask (r - 32)) + else complement (bitMask (r - 32 - 1)) + in FreeRegs + g + (f .&. mask) + (d .&. maskLow) + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) + +allocateReg + reg@(RealRegPair r1 r2) + (FreeRegs g f d) + + | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 + , r2 >= 32, r2 <= 63 + = let mask1 = complement (bitMask (r1 - 32)) + mask2 = complement (bitMask (r2 - 32)) + in + FreeRegs + g + ((f .&. mask1) .&. mask2) + (d .&. mask1) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg) + -- | Release a register from allocation. -- The register liveness information says that most regs die after a C call, -- but we still don't want to allocate to some of them. -- -releaseReg :: RegNo -> FreeRegs -> FreeRegs -releaseReg r regs@(FreeRegs g f d) +releaseReg :: RealReg -> FreeRegs -> FreeRegs +releaseReg + reg@(RealRegSingle r) + regs@(FreeRegs g f d) + -- don't release pinned reg | not $ isFastTrue (freeReg r) = regs - - -- don't release the high part of double regs - -- this prevents them from being allocated as single precison regs. - | r == 39 = regs - | r == 41 = regs - | r == 43 = regs - | r == 45 = regs - | r == 47 = regs - | r == 49 = regs - | r == 51 = regs - | r == 53 = regs - + -- a general purpose reg | r <= 31 - , mask <- 1 `shiftL` fromIntegral r - = FreeRegs (g .|. mask) f d - - -- use the first 22 float regs as double precision - | r >= 32 - , r <= 53 - , mask <- 1 `shiftL` (fromIntegral r - 32) - = FreeRegs g f (d .|. mask) - - -- use the last 10 float regs as single precision - | otherwise - , mask <- 1 `shiftL` (fromIntegral r - 32) - = FreeRegs g (f .|. mask) d - - --- | Allocate a register in the map. -allocateReg :: RegNo -> FreeRegs -> FreeRegs -allocateReg r regs -- (FreeRegs g f d) - - -- if the reg isn't actually free then we're in trouble -{- | not $ regIsFree r regs - = pprPanic - "RegAllocLinear.allocateReg" - (text "reg " <> ppr r <> text " is not free") --} + = let mask = bitMask r + in FreeRegs (g .|. mask) f d + + -- a float reg + | r >= 32, r <= 63 + = let mask = bitMask (r - 32) + + -- the mask of the double this FP reg aliases + maskLow = if r `mod` 2 == 0 + then bitMask (r - 32) + else bitMask (r - 32 - 1) + in FreeRegs + g + (f .|. mask) + (d .|. maskLow) + | otherwise - = grabReg r regs + = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) + +releaseReg + reg@(RealRegPair r1 r2) + (FreeRegs g f d) + + | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0 + , r2 >= 32, r2 <= 63 + = let mask1 = bitMask (r1 - 32) + mask2 = bitMask (r2 - 32) + in + FreeRegs + g + ((f .|. mask1) .|. mask2) + (d .|. mask1) + + | otherwise + = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg) + + + +bitMask :: Int -> Word32 +bitMask n = 1 `shiftL` n + + +showFreeRegs :: FreeRegs -> String +showFreeRegs regs + = "FreeRegs\n" + ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n" + ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n" + ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n" diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs index eedaca8..2b69da0 100644 --- a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs +++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs @@ -28,7 +28,7 @@ getFreeRegs cls f = go f 0 where go 0 _ = [] go n m - | n .&. 1 /= 0 && regClass (RealReg m) == cls + | n .&. 1 /= 0 && regClass (regSingle m) == cls = m : (go (n `shiftR` 1) $! (m+1)) | otherwise diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 8faab5a..0c289c1 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -465,7 +465,8 @@ patchEraseLive patchF cmm patchCmm (CmmProc info label params (ListGraph comps)) | LiveInfo static id blockMap <- info - = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set + = let + patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set blockMap' = mapBlockEnv patchRegSet blockMap info' = LiveInfo static id blockMap' @@ -781,5 +782,3 @@ liveness1 liveregs blockmap instr live_branch_only) - - diff --git a/compiler/nativeGen/SPARC/AddrMode.hs b/compiler/nativeGen/SPARC/AddrMode.hs index bd72cb3..5848794 100644 --- a/compiler/nativeGen/SPARC/AddrMode.hs +++ b/compiler/nativeGen/SPARC/AddrMode.hs @@ -35,7 +35,7 @@ addrOffset addr off | otherwise -> Nothing where n2 = n + toInteger off - AddrRegReg r (RealReg 0) + AddrRegReg r (RegReal (RealRegSingle 0)) | fits13Bits off -> Just (AddrRegImm r (ImmInt off)) | otherwise -> Nothing diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index 6e325cb..54bbf9b 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -92,12 +92,14 @@ setSizeOfRegister reg size getRegisterReg :: CmmReg -> Reg getRegisterReg (CmmLocal (LocalReg u pk)) - = mkVReg u (cmmTypeSize pk) + = RegVirtual $ mkVirtualReg u (cmmTypeSize pk) getRegisterReg (CmmGlobal mid) = case get_GlobalReg_reg_or_addr mid of - Left (RealReg rrno) -> RealReg rrno - _ -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + Left rr -> RegReal rr + + _ -> pprPanic "SPARC.CodeGen.Base.getRegisterReg: global is in memory" + (ppr $ CmmGlobal mid) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 3d10cef..be78972 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -159,14 +159,12 @@ arg_to_int_vregs arg v1 <- getNewRegNat II32 v2 <- getNewRegNat II32 - let Just f0_high = fPair f0 - let code2 = code `snocOL` FMOV FF64 src f0 `snocOL` ST FF32 f0 (spRel 16) `snocOL` LD II32 (spRel 16) v1 `snocOL` - ST FF32 f0_high (spRel 16) `snocOL` + ST FF32 f1 (spRel 16) `snocOL` LD II32 (spRel 16) v2 return (code2, [v1,v2]) @@ -228,21 +226,21 @@ assign_code [CmmHinted dest _hint] result | isFloatType rep , W32 <- width - = unitOL $ FMOV FF32 (RealReg $ fReg 0) r_dest + = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest | isFloatType rep , W64 <- width - = unitOL $ FMOV FF64 (RealReg $ fReg 0) r_dest + = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest | not $ isFloatType rep , W32 <- width - = unitOL $ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest + = unitOL $ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest | not $ isFloatType rep , W64 <- width , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest_hi - , mkRegRegMoveInstr (RealReg $ oReg 1) r_dest] + = toOL [ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr (regSingle $ oReg 1) r_dest] | otherwise = panic "SPARC.CodeGen.GenCCall: no match" diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs new file mode 100644 index 0000000..2becccb --- /dev/null +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -0,0 +1,161 @@ + +-- | Expand out synthetic instructions into single machine instrs. +module SPARC.CodeGen.Expand ( + expandTop +) + +where + +import SPARC.Instr +import SPARC.Imm +import SPARC.AddrMode +import SPARC.Regs +import SPARC.Ppr () +import Instruction +import Reg +import Size +import Cmm + + +import Outputable +import OrdList + +-- | Expand out synthetic instructions in this top level thing +expandTop :: NatCmmTop Instr -> NatCmmTop Instr +expandTop top@(CmmData{}) + = top + +expandTop (CmmProc info lbl params (ListGraph blocks)) + = CmmProc info lbl params (ListGraph $ map expandBlock blocks) + + +-- | Expand out synthetic instructions in this block +expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr + +expandBlock (BasicBlock label instrs) + = let instrs_ol = expandBlockInstrs instrs + instrs' = fromOL instrs_ol + in BasicBlock label instrs' + + +-- | Expand out some instructions +expandBlockInstrs :: [Instr] -> OrdList Instr +expandBlockInstrs [] = nilOL + +expandBlockInstrs (ii:is) + = let ii_doubleRegs = remapRegPair ii + is_misaligned = expandMisalignedDoubles ii_doubleRegs + + in is_misaligned `appOL` expandBlockInstrs is + + + +-- | In the SPARC instruction set the FP register pairs that are used +-- to hold 64 bit floats are refered to by just the first reg +-- of the pair. Remap our internal reg pairs to the appropriate reg. +-- +-- For example: +-- ldd [%l1], (%f0 | %f1) +-- +-- gets mapped to +-- ldd [$l1], %f0 +-- +remapRegPair :: Instr -> Instr +remapRegPair instr + = let patchF reg + = case reg of + RegReal (RealRegSingle _) + -> reg + + RegReal (RealRegPair r1 r2) + + -- sanity checking + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + , r2 == r1 + 1 + -> RegReal (RealRegSingle r1) + + | otherwise + -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg) + + RegVirtual _ + -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg) + + in patchRegsOfInstr instr patchF + + + + +-- Expand out 64 bit load/stores into individual instructions to handle +-- possible double alignment problems. +-- +-- TODO: It'd be better to use a scratch reg instead of the add/sub thing. +-- We might be able to do this faster if we use the UA2007 instr set +-- instead of restricting ourselves to SPARC V9. +-- +expandMisalignedDoubles :: Instr -> OrdList Instr +expandMisalignedDoubles instr + + -- Translate to: + -- add g1,g2,g1 + -- ld [g1],%fn + -- ld [g1+4],%f(n+1) + -- sub g1,g2,g1 -- to restore g1 + | LD FF64 (AddrRegReg r1 r2) fReg <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , LD FF32 (AddrRegReg r1 g0) fReg + , LD FF32 (AddrRegImm r1 (ImmInt 4)) (fRegHi fReg) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | LD FF64 addr fReg <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ LD FF32 addr fReg + , LD FF32 addr' (fRegHi fReg) ] + + -- Translate to: + -- add g1,g2,g1 + -- st %fn,[g1] + -- st %f(n+1),[g1+4] + -- sub g1,g2,g1 -- to restore g1 + | ST FF64 fReg (AddrRegReg r1 r2) <- instr + = toOL [ ADD False False r1 (RIReg r2) r1 + , ST FF32 fReg (AddrRegReg r1 g0) + , ST FF32 (fRegHi fReg) (AddrRegImm r1 (ImmInt 4)) + , SUB False False r1 (RIReg r2) r1 ] + + -- Translate to + -- ld [addr],%fn + -- ld [addr+4],%f(n+1) + | ST FF64 fReg addr <- instr + = let Just addr' = addrOffset addr 4 + in toOL [ ST FF32 fReg addr + , ST FF32 (fRegHi fReg) addr' ] + + -- some other instr + | otherwise + = unitOL instr + + + +-- | The the high partner for this float reg. +fRegHi :: Reg -> Reg +fRegHi (RegReal (RealRegSingle r1)) + | r1 >= 32 + , r1 <= 63 + , r1 `mod` 2 == 0 + = (RegReal $ RealRegSingle (r1 + 1)) + +-- Can't take high partner for non-low reg. +fRegHi reg + = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg) + + + + + + + diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index f620e72..8e6271e 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -68,7 +68,7 @@ assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let - r_dst_lo = mkVReg u_dst (cmmTypeSize pk) + r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeSize pk) r_dst_hi = getHiVRegFromLo r_dst_lo r_src_hi = getHiVRegFromLo r_src_lo mov_lo = mkMOV r_src_lo r_dst_lo @@ -164,7 +164,7 @@ iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) = do r_dst_lo <- getNewRegNat II32 let r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_lo = mkVReg uq II32 + r_src_lo = RegVirtual $ mkVirtualReg uq II32 r_src_hi = getHiVRegFromLo r_src_lo mov_lo = mkMOV r_src_lo r_dst_lo mov_hi = mkMOV r_src_hi r_dst_hi diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index 5d2f481..56f71e4 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -20,7 +20,8 @@ import Outputable -- | Enforce intra-block invariants. -- checkBlock - :: CmmBasicBlock -> NatBasicBlock Instr -> NatBasicBlock Instr + :: CmmBasicBlock + -> NatBasicBlock Instr -> NatBasicBlock Instr checkBlock cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 25a723e..5cb28d5 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -31,6 +31,7 @@ import SPARC.Cond import SPARC.Regs import SPARC.RegPlate import SPARC.Base +import TargetReg import Instruction import RegClass import Reg @@ -40,6 +41,7 @@ import BlockId import Cmm import FastString import FastBool +import Outputable import GHC.Exts @@ -53,11 +55,11 @@ data RI -- - a literal zero -- - register %g0, which is always zero. -- -riZero :: RI -> Bool -riZero (RIImm (ImmInt 0)) = True -riZero (RIImm (ImmInteger 0)) = True -riZero (RIReg (RealReg 0)) = True -riZero _ = False +riZero :: RI -> Bool +riZero (RIImm (ImmInt 0)) = True +riZero (RIImm (ImmInteger 0)) = True +riZero (RIReg (RegReal (RealRegSingle 0))) = True +riZero _ = False -- | Calculate the effective address which would be used by the @@ -271,11 +273,9 @@ sparc_regUsageOfInstr instr interesting :: Reg -> Bool interesting reg = case reg of - VirtualRegI _ -> True - VirtualRegHi _ -> True - VirtualRegF _ -> True - VirtualRegD _ -> True - RealReg i -> isFastTrue (freeReg i) + RegVirtual _ -> True + RegReal (RealRegSingle r1) -> isFastTrue (freeReg r1) + RegReal (RealRegPair r1 _) -> isFastTrue (freeReg r1) @@ -371,7 +371,7 @@ sparc_mkSpillInstr sparc_mkSpillInstr reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case regClass reg of + sz = case targetClassOfReg reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -381,7 +381,7 @@ sparc_mkSpillInstr reg _ slot -- | Make a spill reload instruction. sparc_mkLoadInstr - :: Reg -- ^ register to load + :: Reg -- ^ register to load into -> Int -- ^ current stack delta -> Int -- ^ spill slot to use -> Instr @@ -389,7 +389,7 @@ sparc_mkLoadInstr sparc_mkLoadInstr reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case regClass reg of + sz = case targetClassOfReg reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -433,10 +433,16 @@ sparc_mkRegRegMoveInstr -> Instr sparc_mkRegRegMoveInstr src dst - = case regClass src of - RcInteger -> ADD False False src (RIReg g0) dst - RcDouble -> FMOV FF64 src dst - RcFloat -> FMOV FF32 src dst + | srcClass <- targetClassOfReg src + , dstClass <- targetClassOfReg dst + , srcClass == dstClass + = case srcClass of + RcInteger -> ADD False False src (RIReg g0) dst + RcDouble -> FMOV FF64 src dst + RcFloat -> FMOV FF32 src dst + + | otherwise + = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same" -- | Check whether an instruction represents a reg-reg move. diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index 00ee07f..d517a08 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -148,13 +148,25 @@ pprUserReg = pprReg -- | Pretty print a register. pprReg :: Reg -> Doc -pprReg r - = case r of - RealReg i -> pprReg_ofRegNo i - VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u) - VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u) - VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u) - VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u) +pprReg reg + = case reg of + RegVirtual vr + -> case vr of + VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u) + VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u) + VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u) + VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u) + + RegReal rr + -> case rr of + RealRegSingle r1 + -> pprReg_ofRegNo r1 + + RealRegPair r1 r2 + -> text "(" <> pprReg_ofRegNo r1 + <> text "|" <> pprReg_ofRegNo r2 + <> text ")" + -- | Pretty print a register name, based on this register number. @@ -256,7 +268,7 @@ pprCond c pprAddr :: AddrMode -> Doc pprAddr am = case am of - AddrRegReg r1 (RealReg 0) + AddrRegReg r1 (RegReal (RealRegSingle 0)) -> pprReg r1 AddrRegReg r1 r2 @@ -364,111 +376,40 @@ pprInstr (NEWBLOCK _) pprInstr (LDATA _ _) = panic "PprMach.pprInstr: LDATA" -{- -pprInstr (SPILL reg slot) - = hcat [ - ptext (sLit "\tSPILL"), - char '\t', - pprReg reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] - -pprInstr (RELOAD slot reg) - = hcat [ - ptext (sLit "\tRELOAD"), - char '\t', - ptext (sLit "SLOT") <> parens (int slot), - comma, - pprReg reg] --} - --- a clumsy hack for now, to handle possible double alignment problems --- even clumsier, to allow for RegReg regs that show when doing indexed --- reads (bytearrays). - --- Translate to the following: --- add g1,g2,g1 --- ld [g1],%fn --- ld [g1+4],%f(n+1) --- sub g1,g2,g1 -- to restore g1 - -pprInstr (LD FF64 (AddrRegReg g1 g2) reg) - = let Just regH = fPair reg - in vcat [ - hcat [ptext (sLit "\tadd\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1], - hcat [pp_ld_lbracket, pprReg g1, pp_rbracket_comma, pprReg reg], - hcat [pp_ld_lbracket, pprReg g1, ptext (sLit "+4]"), comma, pprReg regH], - hcat [ptext (sLit "\tsub\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1] - ] - --- Translate to --- ld [addr],%fn --- ld [addr+4],%f(n+1) -pprInstr (LD FF64 addr reg) - = let Just addr2 = addrOffset addr 4 - Just regH = fPair reg - in vcat [ - hcat [pp_ld_lbracket, pprAddr addr, pp_rbracket_comma, pprReg reg], - hcat [pp_ld_lbracket, pprAddr addr2, pp_rbracket_comma,pprReg regH] - ] +-- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand +pprInstr (LD FF64 _ reg) + | RegReal (RealRegSingle{}) <- reg + = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" - pprInstr (LD size addr reg) - = hcat [ - ptext (sLit "\tld"), - pprSize size, - char '\t', - lbrack, - pprAddr addr, - pp_rbracket_comma, - pprReg reg - ] - --- The same clumsy hack as above --- Translate to the following: --- add g1,g2,g1 --- st %fn,[g1] --- st %f(n+1),[g1+4] --- sub g1,g2,g1 -- to restore g1 - -pprInstr (ST FF64 reg (AddrRegReg g1 g2)) - = let Just regH = fPair reg - in vcat [ - hcat [ptext (sLit "\tadd\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1], - hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket, - pprReg g1, rbrack], - hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket, - pprReg g1, ptext (sLit "+4]")], - hcat [ptext (sLit "\tsub\t"), pprReg g1, comma, pprReg g2, comma, pprReg g1] - ] - --- Translate to --- st %fn,[addr] --- st %f(n+1),[addr+4] -pprInstr (ST FF64 reg addr) - = let Just addr2 = addrOffset addr 4 - Just regH = fPair reg - in vcat [ - hcat [ptext (sLit "\tst\t"), pprReg reg, pp_comma_lbracket, - pprAddr addr, rbrack], - hcat [ptext (sLit "\tst\t"), pprReg regH, pp_comma_lbracket, - pprAddr addr2, rbrack] + = hcat [ + ptext (sLit "\tld"), + pprSize size, + char '\t', + lbrack, + pprAddr addr, + pp_rbracket_comma, + pprReg reg ] - + +-- 64 bit FP storees are expanded into individual instructions in CodeGen.Expand +pprInstr (ST FF64 reg _) + | RegReal (RealRegSingle{}) <- reg + = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" -- no distinction is made between signed and unsigned bytes on stores for the -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF), -- so we call a special-purpose pprSize for ST.. pprInstr (ST size reg addr) - = hcat [ - ptext (sLit "\tst"), - pprStSize size, - char '\t', - pprReg reg, - pp_comma_lbracket, - pprAddr addr, - rbrack - ] + = hcat [ + ptext (sLit "\tst"), + pprStSize size, + char '\t', + pprReg reg, + pp_comma_lbracket, + pprAddr addr, + rbrack + ] pprInstr (ADD x cc reg1 ri reg2) @@ -534,20 +475,11 @@ pprInstr (SETHI imm reg) pprReg reg ] -pprInstr NOP = ptext (sLit "\tnop") +pprInstr NOP + = ptext (sLit "\tnop") -pprInstr (FABS FF32 reg1 reg2) = pprSizeRegReg (sLit "fabs") FF32 reg1 reg2 -pprInstr (FABS FF64 reg1 reg2) - = let Just reg1H = fPair reg1 - Just reg2H = fPair reg2 - in - (<>) (pprSizeRegReg (sLit "fabs") FF32 reg1 reg2) - (if (reg1 == reg2) then empty - else (<>) (char '\n') - (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H)) - -pprInstr (FABS _ _ _) - =panic "SPARC.Ppr.pprInstr(FABS): no match" +pprInstr (FABS size reg1 reg2) + = pprSizeRegReg (sLit "fabs") size reg1 reg2 pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fadd") size reg1 reg2 reg3 @@ -558,40 +490,14 @@ pprInstr (FCMP e size reg1 reg2) pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fdiv") size reg1 reg2 reg3 -pprInstr (FMOV FF32 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF32 reg1 reg2 -pprInstr (FMOV FF64 reg1 reg2) = pprSizeRegReg (sLit "fmov") FF64 reg1 reg2 - -pprInstr (FMOV _ _ _) - = panic "SPARC.Ppr.pprInstr(FMOV): no match" - -{- -pprInstr (FMOV FF64 reg1 reg2) - = let Just reg1H = fPair reg1 - Just reg2H = fPair reg2 - in - (<>) (pprSizeRegReg (sLit "fmov") FF32 reg1 reg2) - (if (reg1 == reg2) then empty - else (<>) (char '\n') - (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H)) --} +pprInstr (FMOV size reg1 reg2) + = pprSizeRegReg (sLit "fmov") size reg1 reg2 pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "fmul") size reg1 reg2 reg3 -pprInstr (FNEG FF32 reg1 reg2) - = pprSizeRegReg (sLit "fneg") FF32 reg1 reg2 - -pprInstr (FNEG FF64 reg1 reg2) - = let Just reg1H = fPair reg1 - Just reg2H = fPair reg2 - in - (<>) (pprSizeRegReg (sLit "fneg") FF32 reg1 reg2) - (if (reg1 == reg2) then empty - else (<>) (char '\n') - (pprSizeRegReg (sLit "fmov") FF32 reg1H reg2H)) - -pprInstr (FNEG _ _ _) - = panic "SPARC.Ppr.pprInstr(FNEG): no match" +pprInstr (FNEG size reg1 reg2) + = pprSizeRegReg (sLit "fneg") size reg1 reg2 pprInstr (FSQRT size reg1 reg2) = pprSizeRegReg (sLit "fsqrt") size reg1 reg2 @@ -640,6 +546,7 @@ pprInstr (JMP_TBL op _) = pprInstr (JMP op) pprInstr (CALL (Left imm) n _) = hcat [ ptext (sLit "\tcall\t"), pprImm imm, comma, int n ] + pprInstr (CALL (Right reg) n _) = hcat [ ptext (sLit "\tcall\t"), pprReg reg, comma, int n ] @@ -712,10 +619,10 @@ pprRIReg name b ri reg1 ] -} - +{- pp_ld_lbracket :: Doc pp_ld_lbracket = ptext (sLit "\tld\t[") - +-} pp_rbracket_comma :: Doc pp_rbracket_comma = text "]," diff --git a/compiler/nativeGen/SPARC/RegPlate.hs b/compiler/nativeGen/SPARC/RegPlate.hs index 1da728a..ff42f2b 100644 --- a/compiler/nativeGen/SPARC/RegPlate.hs +++ b/compiler/nativeGen/SPARC/RegPlate.hs @@ -130,12 +130,14 @@ freeReg i7 = fastBool False freeReg f0 = fastBool False freeReg f1 = fastBool False +{- freeReg regNo -- don't release high half of double regs | regNo >= f0 , regNo < NCG_FirstFloatReg , regNo `mod` 2 /= 0 = fastBool False +-} -------------------------------------- @@ -181,9 +183,15 @@ freeReg REG_F4 = fastBool False #ifdef REG_D1 freeReg REG_D1 = fastBool False #endif +#ifdef REG_D1_2 +freeReg REG_D1_2 = fastBool False +#endif #ifdef REG_D2 freeReg REG_D2 = fastBool False #endif +#ifdef REG_D2_2 +freeReg REG_D2_2 = fastBool False +#endif #ifdef REG_Sp freeReg REG_Sp = fastBool False #endif @@ -207,86 +215,86 @@ freeReg _ = fastBool True -- in a real machine register, otherwise returns @'Just' reg@, where -- reg is the machine register it is stored in. -globalRegMaybe :: GlobalReg -> Maybe Reg + +globalRegMaybe :: GlobalReg -> Maybe RealReg #ifdef REG_Base -globalRegMaybe BaseReg = Just (RealReg REG_Base) +globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) #endif #ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (RealReg REG_R1) +globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) #endif #ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (RealReg REG_R2) +globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) #endif #ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (RealReg REG_R3) +globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) #endif #ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (RealReg REG_R4) +globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) #endif #ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (RealReg REG_R5) +globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) #endif #ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (RealReg REG_R6) +globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) #endif #ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (RealReg REG_R7) +globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) #endif #ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (RealReg REG_R8) +globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) #endif #ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (RealReg REG_R9) +globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) #endif #ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (RealReg REG_R10) +globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) #endif #ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (RealReg REG_F1) +globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) #endif #ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (RealReg REG_F2) +globalRegMaybe (FloatReg 2) = Just (RealRegSingle REG_F2) #endif #ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (RealReg REG_F3) +globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) #endif #ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (RealReg REG_F4) +globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) #endif #ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = Just (RealReg REG_D1) +globalRegMaybe (DoubleReg 1) = Just (RealRegPair REG_D1 (REG_D1 + 1)) #endif #ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = Just (RealReg REG_D2) +globalRegMaybe (DoubleReg 2) = Just (RealRegPair REG_D2 (REG_D2 + 1)) #endif #ifdef REG_Sp -globalRegMaybe Sp = Just (RealReg REG_Sp) +globalRegMaybe Sp = Just (RealRegSingle REG_Sp) #endif #ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (RealReg REG_Lng1) +globalRegMaybe (LongReg 1) = Just (RealRegSingle REG_Lng1) #endif #ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (RealReg REG_Lng2) +globalRegMaybe (LongReg 2) = Just (RealRegSingle REG_Lng2) #endif #ifdef REG_SpLim -globalRegMaybe SpLim = Just (RealReg REG_SpLim) +globalRegMaybe SpLim = Just (RealRegSingle REG_SpLim) #endif #ifdef REG_Hp -globalRegMaybe Hp = Just (RealReg REG_Hp) +globalRegMaybe Hp = Just (RealRegSingle REG_Hp) #endif #ifdef REG_HpLim -globalRegMaybe HpLim = Just (RealReg REG_HpLim) +globalRegMaybe HpLim = Just (RealRegSingle REG_HpLim) #endif #ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO) +globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) #endif #ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery) +globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) #endif globalRegMaybe _ = Nothing - #else freeReg :: RegNo -> FastBool freeReg = error "SPARC.RegPlate.freeReg: not defined" diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index e610d5d..1c41e88 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -7,14 +7,14 @@ module SPARC.Regs ( -- registers showReg, - regClass, - allMachRegNos, + virtualRegSqueeze, + realRegSqueeze, + classOfRealReg, + allRealRegs, -- machine specific info gReg, iReg, lReg, oReg, fReg, - fp, sp, g0, g1, g2, o0, o1, f0, f6, f8, f22, f26, f27, - nCG_FirstFloatReg, - fPair, + fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27, -- allocatable allocatableRegs, @@ -26,7 +26,7 @@ module SPARC.Regs ( callClobberedRegs, -- - mkVReg, + mkVirtualReg, regDotColor ) @@ -44,9 +44,9 @@ import CgUtils ( get_GlobalReg_addr ) import Unique import Outputable +import FastTypes import FastBool - {- The SPARC has 64 registers of interest; 32 integer registers and 32 floating point registers. The mapping of STG registers to SPARC @@ -70,30 +70,84 @@ showReg n | otherwise = panic "SPARC.Regs.showReg: unknown sparc register" --- | Get the class of a register. -{-# INLINE regClass #-} -regClass :: Reg -> RegClass -regClass reg +-- Get the register class of a certain real reg +classOfRealReg :: RealReg -> RegClass +classOfRealReg reg = case reg of - VirtualRegI _ -> RcInteger - VirtualRegHi _ -> RcInteger - VirtualRegF _ -> RcFloat - VirtualRegD _ -> RcDouble - RealReg i - | i < 32 -> RcInteger - | i < nCG_FirstFloatReg -> RcDouble - | otherwise -> RcFloat - - --- | The RegNos corresponding to all the registers in the machine. --- For SPARC we use f0-f22 as doubles, so pretend that the high halves --- of these, ie f23, f25 .. don't exist. + RealRegSingle i + | i < 32 -> RcInteger + | otherwise -> RcFloat + + RealRegPair{} -> RcDouble + + +-- | regSqueeze_class reg +-- Calculuate the maximum number of register colors that could be +-- denied to a node of this class due to having this reg +-- as a neighbour. -- -allMachRegNos :: [RegNo] -allMachRegNos - = ([0..31] - ++ [32,34 .. nCG_FirstFloatReg-1] - ++ [nCG_FirstFloatReg .. 63]) +{-# INLINE virtualRegSqueeze #-} +virtualRegSqueeze :: RegClass -> VirtualReg -> FastInt + +virtualRegSqueeze cls vr + = case cls of + RcInteger + -> case vr of + VirtualRegI{} -> _ILIT(1) + VirtualRegHi{} -> _ILIT(1) + VirtualRegF{} -> _ILIT(0) + VirtualRegD{} -> _ILIT(0) + + RcFloat + -> case vr of + VirtualRegI{} -> _ILIT(0) + VirtualRegHi{} -> _ILIT(0) + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(2) + + RcDouble + -> case vr of + VirtualRegI{} -> _ILIT(0) + VirtualRegHi{} -> _ILIT(0) + VirtualRegF{} -> _ILIT(1) + VirtualRegD{} -> _ILIT(1) + +{-# INLINE realRegSqueeze #-} +realRegSqueeze :: RegClass -> RealReg -> FastInt + +realRegSqueeze cls rr + = case cls of + RcInteger + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(1) + | otherwise -> _ILIT(0) + + RealRegPair{} -> _ILIT(0) + + RcFloat + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(2) + + RcDouble + -> case rr of + RealRegSingle regNo + | regNo < 32 -> _ILIT(0) + | otherwise -> _ILIT(1) + + RealRegPair{} -> _ILIT(1) + + +-- | All the allocatable registers in the machine, +-- including register pairs. +allRealRegs :: [RealReg] +allRealRegs + = [ (RealRegSingle i) | i <- [0..63] ] + ++ [ (RealRegPair i (i+1)) | i <- [32, 34 .. 62 ] ] -- | Get the regno for this sort of reg @@ -107,34 +161,29 @@ fReg x = (32 + x) -- float regs -- | Some specific regs used by the code generator. -g0, g1, g2, fp, sp, o0, o1, f0, f6, f8, f22, f26, f27 :: Reg +g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg -f6 = RealReg (fReg 6) -f8 = RealReg (fReg 8) -f22 = RealReg (fReg 22) -f26 = RealReg (fReg 26) -f27 = RealReg (fReg 27) +f6 = RegReal (RealRegSingle (fReg 6)) +f8 = RegReal (RealRegSingle (fReg 8)) +f22 = RegReal (RealRegSingle (fReg 22)) +f26 = RegReal (RealRegSingle (fReg 26)) +f27 = RegReal (RealRegSingle (fReg 27)) -g0 = RealReg (gReg 0) -- g0 is always zero, and writes to it vanish. -g1 = RealReg (gReg 1) -g2 = RealReg (gReg 2) +-- g0 is always zero, and writes to it vanish. +g0 = RegReal (RealRegSingle (gReg 0)) +g1 = RegReal (RealRegSingle (gReg 1)) +g2 = RegReal (RealRegSingle (gReg 2)) -- FP, SP, int and float return (from C) regs. -fp = RealReg (iReg 6) -sp = RealReg (oReg 6) -o0 = RealReg (oReg 0) -o1 = RealReg (oReg 1) -f0 = RealReg (fReg 0) - - --- | We use he first few float regs as double precision. --- This is the RegNo of the first float regs we use as single precision. --- -nCG_FirstFloatReg :: RegNo -nCG_FirstFloatReg = 54 - +fp = RegReal (RealRegSingle (iReg 6)) +sp = RegReal (RealRegSingle (oReg 6)) +o0 = RegReal (RealRegSingle (oReg 0)) +o1 = RegReal (RealRegSingle (oReg 1)) +f0 = RegReal (RealRegSingle (fReg 0)) +f1 = RegReal (RealRegSingle (fReg 1)) -- | Produce the second-half-of-a-double register given the first half. +{- fPair :: Reg -> Maybe Reg fPair (RealReg n) | n >= 32 && n `mod` 2 == 0 = Just (RealReg (n+1)) @@ -145,16 +194,24 @@ fPair (VirtualRegD u) fPair reg = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg) Nothing +-} - --- allocatableRegs is allMachRegNos with the fixed-use regs removed. --- i.e., these are the regs for which we are prepared to allow the --- register allocator to attempt to map VRegs to. -allocatableRegs :: [RegNo] +-- | All the regs that the register allocator can allocate to, +-- with the the fixed use regs removed. +-- +allocatableRegs :: [RealReg] allocatableRegs - = let isFree i = isFastTrue (freeReg i) - in filter isFree allMachRegNos + = let isFree rr + = case rr of + RealRegSingle r + -> isFastTrue (freeReg r) + + RealRegPair r1 r2 + -> isFastTrue (freeReg r1) + && isFastTrue (freeReg r2) + + in filter isFree allRealRegs @@ -165,10 +222,10 @@ allocatableRegs -- address in the register table holding it. -- (See also get_GlobalReg_addr in CgUtils.) -get_GlobalReg_reg_or_addr :: GlobalReg -> Either Reg CmmExpr +get_GlobalReg_reg_or_addr :: GlobalReg -> Either RealReg CmmExpr get_GlobalReg_reg_or_addr mid = case globalRegMaybe mid of - Just rr -> Left rr + Just rr -> Left rr Nothing -> Right (get_GlobalReg_addr mid) @@ -179,12 +236,12 @@ argRegs :: RegNo -> [Reg] argRegs r = case r of 0 -> [] - 1 -> map (RealReg . oReg) [0] - 2 -> map (RealReg . oReg) [0,1] - 3 -> map (RealReg . oReg) [0,1,2] - 4 -> map (RealReg . oReg) [0,1,2,3] - 5 -> map (RealReg . oReg) [0,1,2,3,4] - 6 -> map (RealReg . oReg) [0,1,2,3,4,5] + 1 -> map (RegReal . RealRegSingle . oReg) [0] + 2 -> map (RegReal . RealRegSingle . oReg) [0,1] + 3 -> map (RegReal . RealRegSingle . oReg) [0,1,2] + 4 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3] + 5 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4] + 6 -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5] _ -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!" @@ -192,7 +249,7 @@ argRegs r -- allArgRegs :: [Reg] allArgRegs - = map RealReg [oReg i | i <- [0..5]] + = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]] -- These are the regs that we cannot assume stay alive over a C call. @@ -200,7 +257,7 @@ allArgRegs -- callClobberedRegs :: [Reg] callClobberedRegs - = map RealReg + = map (RegReal . RealRegSingle) ( oReg 7 : [oReg i | i <- [0..5]] ++ [gReg i | i <- [1..7]] ++ @@ -209,8 +266,8 @@ callClobberedRegs -- | Make a virtual reg with this size. -mkVReg :: Unique -> Size -> Reg -mkVReg u size +mkVirtualReg :: Unique -> Size -> VirtualReg +mkVirtualReg u size | not (isFloatSize size) = VirtualRegI u @@ -221,9 +278,9 @@ mkVReg u size _ -> panic "mkVReg" -regDotColor :: Reg -> SDoc +regDotColor :: RealReg -> SDoc regDotColor reg - = case regClass reg of + = case classOfRealReg reg of RcInteger -> text "blue" RcFloat -> text "red" RcDouble -> text "green" @@ -231,7 +288,6 @@ regDotColor reg - -- Hard coded freeReg / globalRegMaybe ----------------------------------------- -- This isn't being used at the moment because we're generating -- these functions from the information in includes/MachRegs.hs via RegPlate.hs diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index 471ee21..848f72b 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -10,10 +10,13 @@ -- TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable module TargetReg ( - targetRegClass, - targetMkVReg, + targetVirtualRegSqueeze, + targetRealRegSqueeze, + targetClassOfRealReg, + targetMkVirtualReg, targetWordSize, - targetRegDotColor + targetRegDotColor, + targetClassOfReg ) where @@ -27,6 +30,7 @@ import Size import CmmExpr (wordWidth) import Outputable import Unique +import FastTypes #if i386_TARGET_ARCH || x86_64_TARGET_ARCH @@ -46,8 +50,11 @@ import qualified SPARC.Regs as SPARC -- x86 ------------------------------------------------------------------------- #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -targetRegClass :: Reg -> RegClass -targetRegClass = X86.regClass +targetRegClasses :: Reg -> [RegClass] +targetRegClasses = X86.regClasses + +targetRegSupportsClass :: Reg -> RegClass -> Bool +targetRegSupportsClass = X86.regSupportsClass targetWordSize :: Size targetWordSize = intSize wordWidth @@ -61,8 +68,11 @@ targetRegDotColor = X86.regDotColor -- ppc ------------------------------------------------------------------------- #elif powerpc_TARGET_ARCH -targetRegClass :: Reg -> RegClass -targetRegClass = PPC.regClass +targetRegClasses :: Reg -> [RegClass] +targetRegClasses = PPC.regClasses + +targetRegSupportsClass :: Reg -> RegClass -> Bool +targetRegSupportsClass = PPC.regSupportsClass targetWordSize :: Size targetWordSize = intSize wordWidth @@ -76,18 +86,25 @@ targetRegDotColor = PPC.regDotColor -- sparc ----------------------------------------------------------------------- #elif sparc_TARGET_ARCH -targetRegClass :: Reg -> RegClass -targetRegClass = SPARC.regClass + +targetVirtualRegSqueeze :: RegClass -> VirtualReg -> FastInt +targetVirtualRegSqueeze = SPARC.virtualRegSqueeze + +targetRealRegSqueeze :: RegClass -> RealReg -> FastInt +targetRealRegSqueeze = SPARC.realRegSqueeze + +targetClassOfRealReg :: RealReg -> RegClass +targetClassOfRealReg = SPARC.classOfRealReg -- | Size of a machine word. -- This is big enough to hold a pointer. targetWordSize :: Size targetWordSize = intSize wordWidth -targetMkVReg :: Unique -> Size -> Reg -targetMkVReg = SPARC.mkVReg +targetMkVirtualReg :: Unique -> Size -> VirtualReg +targetMkVirtualReg = SPARC.mkVirtualReg -targetRegDotColor :: Reg -> SDoc +targetRegDotColor :: RealReg -> SDoc targetRegDotColor = SPARC.regDotColor -------------------------------------------------------------------------------- @@ -96,4 +113,10 @@ targetRegDotColor = SPARC.regDotColor #endif +targetClassOfReg :: Reg -> RegClass +targetClassOfReg reg + = case reg of + RegVirtual vr -> classOfVirtualReg vr + RegReal rr -> targetClassOfRealReg rr + diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 4cfeacc..6cf871f 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -208,7 +208,7 @@ getRegisterReg (CmmLocal (LocalReg u pk)) getRegisterReg (CmmGlobal mid) = case get_GlobalReg_reg_or_addr mid of - Left (RealReg rrno) -> RealReg rrno + Left reg@(RegReal _) -> reg _other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the -- ones which map to a real machine register on this @@ -1022,7 +1022,9 @@ getNonClobberedReg expr = do return (tmp, code tmp) Fixed rep reg code -- only free regs can be clobbered - | RealReg rr <- reg, isFastTrue (freeReg rr) -> do + | RegReal (RealRegSingle rr) <- reg + , isFastTrue (freeReg rr) + -> do tmp <- getNewRegNat rep return (tmp, code `snocOL` reg2reg rep reg tmp) | otherwise -> @@ -1150,7 +1152,7 @@ getNonClobberedOperand e = do amodeCouldBeClobbered :: AddrMode -> Bool amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode) -regClobbered (RealReg rr) = isFastTrue (freeReg rr) +regClobbered (RegReal (RealRegSingle rr)) = isFastTrue (freeReg rr) regClobbered _ = False -- getOperand: the operand is not required to remain valid across the @@ -1779,7 +1781,9 @@ genCCall target dest_regs args = do assign_code [CmmHinted dest _hint] = case typeWidth rep of W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) +v v v v v v v W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) +^ ^ ^ ^ ^ ^ ^ _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) where rep = localRegType dest @@ -1867,7 +1871,7 @@ outOfLineFloatOp mop res args dflags <- getDynFlagsNat targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmCallee targetExpr CCallConv - + if isFloat64 (localRegType res) then stmtToInstrs (CmmCall target [CmmHinted res NoHint] args CmmUnsafe CmmMayReturn) diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 26da907..dbec540 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -443,12 +443,9 @@ x86_regUsageOfInstr instr dst' = filter interesting dst interesting :: Reg -> Bool -interesting (VirtualRegI _) = True -interesting (VirtualRegHi _) = True -interesting (VirtualRegF _) = True -interesting (VirtualRegD _) = True -interesting (RealReg i) = isFastTrue (freeReg i) - +interesting (RegVirtual _) = True +interesting (RegReal (RealRegSingle i)) = isFastTrue (freeReg i) +interesting (RegReal (RealRegPair{})) = panic "X86.interesting: no reg pairs on this arch" diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 4881062..398c480 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -161,16 +161,6 @@ instance Outputable Instr where ppr instr = Outputable.docToSDoc $ pprInstr instr - - - - - - - - - - #if i386_TARGET_ARCH || x86_64_TARGET_ARCH pprUserReg :: Reg -> Doc pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,) @@ -185,11 +175,12 @@ pprReg :: Size -> Reg -> Doc pprReg s r = case r of - RealReg i -> ppr_reg_no s i - VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u) - VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u) - VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u) - VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u) + RegReal (RealRegSingle i) -> ppr_reg_no s i + RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" + RegVirtual (VirtualRegI u) -> text "%vI_" <> asmSDoc (pprUnique u) + RegVirtual (VirtualRegHi u) -> text "%vHi_" <> asmSDoc (pprUnique u) + RegVirtual (VirtualRegF u) -> text "%vF_" <> asmSDoc (pprUnique u) + RegVirtual (VirtualRegD u) -> text "%vD_" <> asmSDoc (pprUnique u) where #if i386_TARGET_ARCH ppr_reg_no :: Size -> Int -> Doc @@ -956,7 +947,7 @@ gsp :: Doc gsp = char ' ' gregno :: Reg -> RegNo -gregno (RealReg i) = i +gregno (RegReal (RealRegSingle i)) = i gregno _ = --pprPanic "gregno" (ppr other) 999 -- bogus; only needed for debug printing diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs index 39ff406..48d983c 100644 --- a/compiler/nativeGen/X86/RegInfo.hs +++ b/compiler/nativeGen/X86/RegInfo.hs @@ -34,11 +34,11 @@ import UniqFM mkVReg :: Unique -> Size -> Reg mkVReg u size - | not (isFloatSize size) = VirtualRegI u + | not (isFloatSize size) = RegVirtual (VirtualRegI u) | otherwise = case size of - FF32 -> VirtualRegD u - FF64 -> VirtualRegD u + FF32 -> RegVirtual (VirtualRegD u) + FF64 -> RegVirtual (VirtualRegD u) _ -> panic "mkVReg" diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 5db3ab1..21823a8 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -275,20 +275,20 @@ never generate them. fake0, fake1, fake2, fake3, fake4, fake5, eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg -eax = RealReg 0 -ebx = RealReg 1 -ecx = RealReg 2 -edx = RealReg 3 -esi = RealReg 4 -edi = RealReg 5 -ebp = RealReg 6 -esp = RealReg 7 -fake0 = RealReg 8 -fake1 = RealReg 9 -fake2 = RealReg 10 -fake3 = RealReg 11 -fake4 = RealReg 12 -fake5 = RealReg 13 +eax = regSingle 0 +ebx = regSingle 1 +ecx = regSingle 2 +edx = regSingle 3 +esi = regSingle 4 +edi = regSingle 5 +ebp = regSingle 6 +esp = regSingle 7 +fake0 = regSingle 8 +fake1 = regSingle 9 +fake2 = regSingle 10 +fake3 = regSingle 11 +fake4 = regSingle 12 +fake5 = regSingle 13 @@ -305,41 +305,41 @@ rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi, xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7, xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg -rax = RealReg 0 -rbx = RealReg 1 -rcx = RealReg 2 -rdx = RealReg 3 -rsi = RealReg 4 -rdi = RealReg 5 -rbp = RealReg 6 -rsp = RealReg 7 -r8 = RealReg 8 -r9 = RealReg 9 -r10 = RealReg 10 -r11 = RealReg 11 -r12 = RealReg 12 -r13 = RealReg 13 -r14 = RealReg 14 -r15 = RealReg 15 -xmm0 = RealReg 16 -xmm1 = RealReg 17 -xmm2 = RealReg 18 -xmm3 = RealReg 19 -xmm4 = RealReg 20 -xmm5 = RealReg 21 -xmm6 = RealReg 22 -xmm7 = RealReg 23 -xmm8 = RealReg 24 -xmm9 = RealReg 25 -xmm10 = RealReg 26 -xmm11 = RealReg 27 -xmm12 = RealReg 28 -xmm13 = RealReg 29 -xmm14 = RealReg 30 -xmm15 = RealReg 31 +rax = regSingle 0 +rbx = regSingle 1 +rcx = regSingle 2 +rdx = regSingle 3 +rsi = regSingle 4 +rdi = regSingle 5 +rbp = regSingle 6 +rsp = regSingle 7 +r8 = regSingle 8 +r9 = regSingle 9 +r10 = regSingle 10 +r11 = regSingle 11 +r12 = regSingle 12 +r13 = regSingle 13 +r14 = regSingle 14 +r15 = regSingle 15 +xmm0 = regSingle 16 +xmm1 = regSingle 17 +xmm2 = regSingle 18 +xmm3 = regSingle 19 +xmm4 = regSingle 20 +xmm5 = regSingle 21 +xmm6 = regSingle 22 +xmm7 = regSingle 23 +xmm8 = regSingle 24 +xmm9 = regSingle 25 +xmm10 = regSingle 26 +xmm11 = regSingle 27 +xmm12 = regSingle 28 +xmm13 = regSingle 29 +xmm14 = regSingle 30 +xmm15 = regSingle 31 allFPArgRegs :: [Reg] -allFPArgRegs = map RealReg [16 .. 23] +allFPArgRegs = map regSingle [16 .. 23] ripRel :: Displacement -> AddrMode ripRel imm = AddrBaseIndex EABaseRip EAIndexNone imm @@ -358,7 +358,7 @@ esp = rsp -} xmm :: RegNo -> Reg -xmm n = RealReg (16+n) +xmm n = regSingle (16+n) @@ -501,79 +501,79 @@ freeReg _ = fastBool True -- reg is the machine register it is stored in. #ifdef REG_Base -globalRegMaybe BaseReg = Just (RealReg REG_Base) +globalRegMaybe BaseReg = Just (regSingle REG_Base) #endif #ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (RealReg REG_R1) +globalRegMaybe (VanillaReg 1 _) = Just (regSingle REG_R1) #endif #ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (RealReg REG_R2) +globalRegMaybe (VanillaReg 2 _) = Just (regSingle REG_R2) #endif #ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (RealReg REG_R3) +globalRegMaybe (VanillaReg 3 _) = Just (regSingle REG_R3) #endif #ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (RealReg REG_R4) +globalRegMaybe (VanillaReg 4 _) = Just (regSingle REG_R4) #endif #ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (RealReg REG_R5) +globalRegMaybe (VanillaReg 5 _) = Just (regSingle REG_R5) #endif #ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (RealReg REG_R6) +globalRegMaybe (VanillaReg 6 _) = Just (regSingle REG_R6) #endif #ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (RealReg REG_R7) +globalRegMaybe (VanillaReg 7 _) = Just (regSingle REG_R7) #endif #ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (RealReg REG_R8) +globalRegMaybe (VanillaReg 8 _) = Just (regSingle REG_R8) #endif #ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (RealReg REG_R9) +globalRegMaybe (VanillaReg 9 _) = Just (regSingle REG_R9) #endif #ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (RealReg REG_R10) +globalRegMaybe (VanillaReg 10 _) = Just (regSingle REG_R10) #endif #ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (RealReg REG_F1) +globalRegMaybe (FloatReg 1) = Just (regSingle REG_F1) #endif #ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (RealReg REG_F2) +globalRegMaybe (FloatReg 2) = Just (regSingle REG_F2) #endif #ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (RealReg REG_F3) +globalRegMaybe (FloatReg 3) = Just (regSingle REG_F3) #endif #ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (RealReg REG_F4) +globalRegMaybe (FloatReg 4) = Just (regSingle REG_F4) #endif #ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = Just (RealReg REG_D1) +globalRegMaybe (DoubleReg 1) = Just (regSingle REG_D1) #endif #ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = Just (RealReg REG_D2) +globalRegMaybe (DoubleReg 2) = Just (regSingle REG_D2) #endif #ifdef REG_Sp -globalRegMaybe Sp = Just (RealReg REG_Sp) +globalRegMaybe Sp = Just (regSingle REG_Sp) #endif #ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (RealReg REG_Lng1) +globalRegMaybe (LongReg 1) = Just (regSingle REG_Lng1) #endif #ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (RealReg REG_Lng2) +globalRegMaybe (LongReg 2) = Just (regSingle REG_Lng2) #endif #ifdef REG_SpLim -globalRegMaybe SpLim = Just (RealReg REG_SpLim) +globalRegMaybe SpLim = Just (regSingle REG_SpLim) #endif #ifdef REG_Hp -globalRegMaybe Hp = Just (RealReg REG_Hp) +globalRegMaybe Hp = Just (regSingle REG_Hp) #endif #ifdef REG_HpLim -globalRegMaybe HpLim = Just (RealReg REG_HpLim) +globalRegMaybe HpLim = Just (regSingle REG_HpLim) #endif #ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO) +globalRegMaybe CurrentTSO = Just (regSingle REG_CurrentTSO) #endif #ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery) +globalRegMaybe CurrentNursery = Just (regSingle REG_CurrentNursery) #endif globalRegMaybe _ = Nothing @@ -583,7 +583,7 @@ globalRegMaybe _ = Nothing allArgRegs = panic "X86.Regs.allArgRegs: should not be used!" #elif x86_64_TARGET_ARCH -allArgRegs = map RealReg [rdi,rsi,rdx,rcx,r8,r9] +allArgRegs = map regSingle [rdi,rsi,rdx,rcx,r8,r9] #else allArgRegs = panic "X86.Regs.allArgRegs: not defined for this architecture" @@ -595,13 +595,13 @@ allArgRegs = panic "X86.Regs.allArgRegs: not defined for this architecture" #if i386_TARGET_ARCH -- caller-saves registers callClobberedRegs - = map RealReg [eax,ecx,edx,fake0,fake1,fake2,fake3,fake4,fake5] + = map regSingle [eax,ecx,edx,fake0,fake1,fake2,fake3,fake4,fake5] #elif x86_64_TARGET_ARCH -- all xmm regs are caller-saves -- caller-saves registers callClobberedRegs - = map RealReg ([rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] ++ [16..31]) + = map regSingle ([rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11] ++ [16..31]) #else callClobberedRegs diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs index 8e7989d..8dc4121 100644 --- a/compiler/utils/GraphColor.hs +++ b/compiler/utils/GraphColor.hs @@ -98,12 +98,13 @@ colorGraph iterative spinCount colors triv spill graph0 -- with the provided triv function. -- in if not $ null ksNoTriv - then pprPanic "colorGraph: trivially colorable nodes didn't color!" empty -{- ( empty + then pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty + ( empty $$ text "ksTriv = " <> ppr ksTriv $$ text "ksNoTriv = " <> ppr ksNoTriv + $$ text "colors = " <> ppr colors $$ empty - $$ dotGraph (\x -> text "white") triv graph1) -} + $$ dotGraph (\_ -> text "white") triv graph_triv) else ( graph_prob , mkUniqSet ksNoColor -- the nodes that didn't color (spills) @@ -131,7 +132,7 @@ colorGraph iterative spinCount colors triv spill graph0 colorScan :: ( Uniquable k, Uniquable cls, Uniquable color , Ord k, Eq cls - , Outputable k, Outputable color) + , Outputable k, Outputable cls) => Bool -- ^ whether to do iterative coalescing -> Triv k cls color -- ^ fn to decide whether a node is trivially colorable -> (Graph k cls color -> k) -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable. @@ -224,7 +225,8 @@ colorScan_spill iterative triv spill graph -- | Try to assign a color to all these nodes. assignColors - :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color ) + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). -> Graph k cls color -- ^ the graph -> [k] -- ^ nodes to assign a color to. @@ -261,7 +263,8 @@ assignColors colors graph ks -- returns Nothing if no color can be assigned to this node. -- selectColor - :: ( Uniquable k, Uniquable cls, Uniquable color, Eq color) + :: ( Uniquable k, Uniquable cls, Uniquable color + , Eq color, Outputable cls) => UniqFM (UniqSet color) -- ^ map of (node class -> set of colors available for this class). -> Graph k cls color -- ^ the graph -> k -- ^ key of the node to select a color for. @@ -272,8 +275,10 @@ selectColor colors graph u Just node = lookupNode graph u -- lookup the available colors for the class of this node. - Just colors_avail - = lookupUFM colors (nodeClass node) + colors_avail + = case lookupUFM colors (nodeClass node) of + Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node)) + Just cs -> cs -- find colors we can't use because they're already being used -- by a node that conflicts with this one. diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs index 17c14d0..87e77bf 100644 --- a/compiler/utils/GraphOps.hs +++ b/compiler/utils/GraphOps.hs @@ -8,7 +8,7 @@ module GraphOps ( union, addConflict, delConflict, addConflicts, addCoalesce, delCoalesce, - addExclusion, + addExclusion, addExclusions, addPreference, coalesceNodes, coalesceGraph, freezeNode, freezeOneInGraph, freezeAllInGraph, @@ -213,6 +213,14 @@ addExclusion u getClass color (newNode u (getClass u)) { nodeExclusions = unitUniqSet color } u +addExclusions + :: (Uniquable k, Uniquable color) + => k -> (k -> cls) -> [color] + -> Graph k cls color -> Graph k cls color + +addExclusions u getClass colors graph + = foldr (addExclusion u getClass) graph colors + -- | Add a coalescence edge to the graph, creating nodes if requried. -- It is considered adventageous to assign the same color to nodes in a coalesence. diff --git a/compiler/utils/UniqSet.lhs b/compiler/utils/UniqSet.lhs index 1892211..6d39e00 100644 --- a/compiler/utils/UniqSet.lhs +++ b/compiler/utils/UniqSet.lhs @@ -121,7 +121,7 @@ isEmptyUniqSet :: UniqSet a -> Bool isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-} -- | Invariant: the mapping function doesn't change the unique -mapUniqSet :: (a -> a) -> UniqSet a -> UniqSet a +mapUniqSet :: (a -> b) -> UniqSet a -> UniqSet b mapUniqSet f (MkUniqSet set) = MkUniqSet (mapUFM f set) \end{code} diff --git a/includes/MachRegs.h b/includes/MachRegs.h index 593989d..d607532 100644 --- a/includes/MachRegs.h +++ b/includes/MachRegs.h @@ -655,8 +655,15 @@ #define REG_F2 f23 #define REG_F3 f24 #define REG_F4 f25 + +/* for each of the double arg regs, + Dn_2 is the high half. */ + #define REG_D1 f2 +#define REG_D1_2 f3 + #define REG_D2 f4 +#define REG_D2_2 f5 #define REG_Sp i0 #define REG_SpLim i2 -- 1.7.10.4