diff options
Diffstat (limited to 'compiler/nativeGen')
36 files changed, 1494 insertions, 1032 deletions
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 119e1181ef..eafeec92df 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 ed59d2bd0a..409d0c42cf 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 e57d3ca052..d3ec27f45c 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 55affc6e1e..58ddc21d40 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 3629683cb8..8378dd17d3 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 b2806c74d1..719d76c316 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 80c68dd096..c39313a6f2 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 1a341bbdda..4819d0f3c7 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 2e584617e9..94b18aeb0a 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 e6e5622a02..ce34b513a1 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 4f129c468a..9d0dcf9236 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 d4dd75a4b7..ff3f76a545 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 5e3dd3265b..10ab0cbcfb 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 df04606313..5f3f0ac495 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 45fd640804..26262327c9 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 7d2cbcd7a7..8ff06eb886 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 47529d2c96..00e01d7ebc 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 ac16d8a640..d828347433 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 eedaca8cc0..2b69da0093 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 8faab5af92..0c289c16e9 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 bd72cb3dd4..58487941e3 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 6e325cb7a1..54bbf9b51a 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 3d10cef12b..be789729c8 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 0000000000..2becccb30d --- /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 f620e721d5..8e6271e0a3 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 5d2f481a15..56f71e44ed 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 25a723ea9e..5cb28d5c40 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 00ee07f0b7..d517a08085 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 1da728aaad..ff42f2b91c 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 e610d5d6d4..1c41e888ae 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 471ee21384..848f72bf18 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 4cfeaccff7..6cf871fb2d 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 26da90778c..dbec540426 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 4881062d75..398c480aaf 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 39ff4063b0..48d983c173 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 5db3ab1fa6..21823a8923 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 |