module X86.RegInfo (
- RegUsage(..),
- noUsage,
- regUsage,
- patchRegs,
- jumpDests,
- isJumpish,
- patchJump,
- isRegRegMove,
-
- JumpDest(..),
- canShortcut,
- shortcutJump,
-
- mkSpillInstr,
- mkLoadInstr,
- mkRegRegMoveInstr,
- mkBranchInstr,
-
- spillSlotSize,
- maxSpillSlots,
- spillSlotToOffset
+ mkVirtualReg,
+ regDotColor
)
where
#include "nativeGen/NCG.h"
#include "HsVersions.h"
-import X86.Instr
-import X86.Regs
-import RegsBase
+import Size
+import Reg
-import BlockId
import Outputable
-import Constants ( rESERVED_C_STACK_BYTES )
-import FastBool
-
-
--- -----------------------------------------------------------------------------
--- RegUsage type
-
--- @regUsage@ returns the sets of src and destination registers used
--- by a particular instruction. Machine registers that are
--- pre-allocated to stgRegs are filtered out, because they are
--- uninteresting from a register allocation standpoint. (We wouldn't
--- want them to end up on the free list!) As far as we are concerned,
--- the fixed registers simply don't exist (for allocation purposes,
--- anyway).
-
--- regUsage doesn't need to do any trickery for jumps and such. Just
--- state precisely the regs read and written by that insn. The
--- consequences of control flow transfers, as far as register
--- allocation goes, are taken care of by the register allocator.
-
-data RegUsage = RU [Reg] [Reg]
-
-noUsage :: RegUsage
-noUsage = RU [] []
-
-
-regUsage :: Instr -> RegUsage
-regUsage instr = case instr of
- MOV _ src dst -> usageRW src dst
- MOVZxL _ src dst -> usageRW src dst
- MOVSxL _ src dst -> usageRW src dst
- LEA _ src dst -> usageRW src dst
- ADD _ src dst -> usageRM src dst
- ADC _ src dst -> usageRM src dst
- SUB _ src dst -> usageRM src dst
- IMUL _ src dst -> usageRM src dst
- IMUL2 _ src -> mkRU (eax:use_R src) [eax,edx]
- MUL _ src dst -> usageRM src dst
- DIV _ op -> mkRU (eax:edx:use_R op) [eax,edx]
- IDIV _ op -> mkRU (eax:edx:use_R op) [eax,edx]
- AND _ src dst -> usageRM src dst
- OR _ src dst -> usageRM src dst
-
- XOR _ (OpReg src) (OpReg dst)
- | src == dst -> mkRU [] [dst]
-
- XOR _ src dst -> usageRM src dst
- NOT _ op -> usageM op
- NEGI _ op -> usageM op
- SHL _ imm dst -> usageRM imm dst
- SAR _ imm dst -> usageRM imm dst
- SHR _ imm dst -> usageRM imm dst
- BT _ _ src -> mkRUR (use_R src)
-
- PUSH _ op -> mkRUR (use_R op)
- POP _ op -> mkRU [] (def_W op)
- TEST _ src dst -> mkRUR (use_R src ++ use_R dst)
- CMP _ src dst -> mkRUR (use_R src ++ use_R dst)
- SETCC _ op -> mkRU [] (def_W op)
- JXX _ _ -> mkRU [] []
- JXX_GBL _ _ -> mkRU [] []
- JMP op -> mkRUR (use_R op)
- JMP_TBL op _ -> mkRUR (use_R op)
- CALL (Left _) params -> mkRU params callClobberedRegs
- CALL (Right reg) params -> mkRU (reg:params) callClobberedRegs
- CLTD _ -> mkRU [eax] [edx]
- NOP -> mkRU [] []
-
-#if i386_TARGET_ARCH
- GMOV src dst -> mkRU [src] [dst]
- GLD _ src dst -> mkRU (use_EA src) [dst]
- GST _ src dst -> mkRUR (src : use_EA dst)
-
- GLDZ dst -> mkRU [] [dst]
- GLD1 dst -> mkRU [] [dst]
-
- GFTOI src dst -> mkRU [src] [dst]
- GDTOI src dst -> mkRU [src] [dst]
-
- GITOF src dst -> mkRU [src] [dst]
- GITOD src dst -> mkRU [src] [dst]
-
- GADD _ s1 s2 dst -> mkRU [s1,s2] [dst]
- GSUB _ s1 s2 dst -> mkRU [s1,s2] [dst]
- GMUL _ s1 s2 dst -> mkRU [s1,s2] [dst]
- GDIV _ s1 s2 dst -> mkRU [s1,s2] [dst]
-
- GCMP _ src1 src2 -> mkRUR [src1,src2]
- GABS _ src dst -> mkRU [src] [dst]
- GNEG _ src dst -> mkRU [src] [dst]
- GSQRT _ src dst -> mkRU [src] [dst]
- GSIN _ _ _ src dst -> mkRU [src] [dst]
- GCOS _ _ _ src dst -> mkRU [src] [dst]
- GTAN _ _ _ src dst -> mkRU [src] [dst]
-#endif
-
-#if x86_64_TARGET_ARCH
- CVTSS2SD src dst -> mkRU [src] [dst]
- CVTSD2SS src dst -> mkRU [src] [dst]
- CVTTSS2SIQ src dst -> mkRU (use_R src) [dst]
- CVTTSD2SIQ src dst -> mkRU (use_R src) [dst]
- CVTSI2SS src dst -> mkRU (use_R src) [dst]
- CVTSI2SD src dst -> mkRU (use_R src) [dst]
- FDIV _ src dst -> usageRM src dst
-#endif
-
- FETCHGOT reg -> mkRU [] [reg]
- FETCHPC reg -> mkRU [] [reg]
-
- COMMENT _ -> noUsage
- DELTA _ -> noUsage
- SPILL reg _ -> mkRU [reg] []
- RELOAD _ reg -> mkRU [] [reg]
-
- _other -> panic "regUsage: unrecognised instr"
-
- where
- -- 2 operand form; first operand Read; second Written
- usageRW :: Operand -> Operand -> RegUsage
- usageRW op (OpReg reg) = mkRU (use_R op) [reg]
- usageRW op (OpAddr ea) = mkRUR (use_R op ++ use_EA ea)
- usageRW _ _ = panic "X86.RegInfo.usageRW: no match"
-
- -- 2 operand form; first operand Read; second Modified
- usageRM :: Operand -> Operand -> RegUsage
- usageRM op (OpReg reg) = mkRU (use_R op ++ [reg]) [reg]
- usageRM op (OpAddr ea) = mkRUR (use_R op ++ use_EA ea)
- usageRM _ _ = panic "X86.RegInfo.usageRM: no match"
-
- -- 1 operand form; operand Modified
- usageM :: Operand -> RegUsage
- usageM (OpReg reg) = mkRU [reg] [reg]
- usageM (OpAddr ea) = mkRUR (use_EA ea)
- usageM _ = panic "X86.RegInfo.usageM: no match"
-
- -- Registers defd when an operand is written.
- def_W (OpReg reg) = [reg]
- def_W (OpAddr _ ) = []
- def_W _ = panic "X86.RegInfo.def_W: no match"
-
- -- Registers used when an operand is read.
- use_R (OpReg reg) = [reg]
- use_R (OpImm _) = []
- use_R (OpAddr ea) = use_EA ea
-
- -- Registers used to compute an effective address.
- use_EA (ImmAddr _ _) = []
- use_EA (AddrBaseIndex base index _) =
- use_base base $! use_index index
- where use_base (EABaseReg r) x = r : x
- use_base _ x = x
- use_index EAIndexNone = []
- use_index (EAIndex i _) = [i]
-
- mkRUR src = src' `seq` RU src' []
- where src' = filter interesting src
-
- mkRU src dst = src' `seq` dst' `seq` RU src' dst'
- where src' = filter interesting src
- 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)
-
-
-
-
--- -----------------------------------------------------------------------------
--- 'patchRegs' function
-
--- 'patchRegs' takes an instruction and applies the given mapping to
--- all the register references.
-
-patchRegs :: Instr -> (Reg -> Reg) -> Instr
-patchRegs instr env = case instr of
- MOV sz src dst -> patch2 (MOV sz) src dst
- MOVZxL sz src dst -> patch2 (MOVZxL sz) src dst
- MOVSxL sz src dst -> patch2 (MOVSxL sz) src dst
- LEA sz src dst -> patch2 (LEA sz) src dst
- ADD sz src dst -> patch2 (ADD sz) src dst
- ADC sz src dst -> patch2 (ADC sz) src dst
- SUB sz src dst -> patch2 (SUB sz) src dst
- IMUL sz src dst -> patch2 (IMUL sz) src dst
- IMUL2 sz src -> patch1 (IMUL2 sz) src
- MUL sz src dst -> patch2 (MUL sz) src dst
- IDIV sz op -> patch1 (IDIV sz) op
- DIV sz op -> patch1 (DIV sz) op
- AND sz src dst -> patch2 (AND sz) src dst
- OR sz src dst -> patch2 (OR sz) src dst
- XOR sz src dst -> patch2 (XOR sz) src dst
- NOT sz op -> patch1 (NOT sz) op
- NEGI sz op -> patch1 (NEGI sz) op
- SHL sz imm dst -> patch1 (SHL sz imm) dst
- SAR sz imm dst -> patch1 (SAR sz imm) dst
- SHR sz imm dst -> patch1 (SHR sz imm) dst
- BT sz imm src -> patch1 (BT sz imm) src
- TEST sz src dst -> patch2 (TEST sz) src dst
- CMP sz src dst -> patch2 (CMP sz) src dst
- PUSH sz op -> patch1 (PUSH sz) op
- POP sz op -> patch1 (POP sz) op
- SETCC cond op -> patch1 (SETCC cond) op
- JMP op -> patch1 JMP op
- JMP_TBL op ids -> patch1 JMP_TBL op $ ids
-
-#if i386_TARGET_ARCH
- GMOV src dst -> GMOV (env src) (env dst)
- GLD sz src dst -> GLD sz (lookupAddr src) (env dst)
- GST sz src dst -> GST sz (env src) (lookupAddr dst)
-
- GLDZ dst -> GLDZ (env dst)
- GLD1 dst -> GLD1 (env dst)
-
- GFTOI src dst -> GFTOI (env src) (env dst)
- GDTOI src dst -> GDTOI (env src) (env dst)
-
- GITOF src dst -> GITOF (env src) (env dst)
- GITOD src dst -> GITOD (env src) (env dst)
-
- GADD sz s1 s2 dst -> GADD sz (env s1) (env s2) (env dst)
- GSUB sz s1 s2 dst -> GSUB sz (env s1) (env s2) (env dst)
- GMUL sz s1 s2 dst -> GMUL sz (env s1) (env s2) (env dst)
- GDIV sz s1 s2 dst -> GDIV sz (env s1) (env s2) (env dst)
-
- GCMP sz src1 src2 -> GCMP sz (env src1) (env src2)
- GABS sz src dst -> GABS sz (env src) (env dst)
- GNEG sz src dst -> GNEG sz (env src) (env dst)
- GSQRT sz src dst -> GSQRT sz (env src) (env dst)
- GSIN sz l1 l2 src dst -> GSIN sz l1 l2 (env src) (env dst)
- GCOS sz l1 l2 src dst -> GCOS sz l1 l2 (env src) (env dst)
- GTAN sz l1 l2 src dst -> GTAN sz l1 l2 (env src) (env dst)
-#endif
-
-#if x86_64_TARGET_ARCH
- CVTSS2SD src dst -> CVTSS2SD (env src) (env dst)
- CVTSD2SS src dst -> CVTSD2SS (env src) (env dst)
- CVTTSS2SIQ src dst -> CVTTSS2SIQ (patchOp src) (env dst)
- CVTTSD2SIQ src dst -> CVTTSD2SIQ (patchOp src) (env dst)
- CVTSI2SS src dst -> CVTSI2SS (patchOp src) (env dst)
- CVTSI2SD src dst -> CVTSI2SD (patchOp src) (env dst)
- FDIV sz src dst -> FDIV sz (patchOp src) (patchOp dst)
-#endif
-
- CALL (Left _) _ -> instr
- CALL (Right reg) p -> CALL (Right (env reg)) p
-
- FETCHGOT reg -> FETCHGOT (env reg)
- FETCHPC reg -> FETCHPC (env reg)
-
- NOP -> instr
- COMMENT _ -> instr
- DELTA _ -> instr
- SPILL reg slot -> SPILL (env reg) slot
- RELOAD slot reg -> RELOAD slot (env reg)
-
- JXX _ _ -> instr
- JXX_GBL _ _ -> instr
- CLTD _ -> instr
-
- _other -> panic "patchRegs: unrecognised instr"
-
- where
- patch1 insn op = insn $! patchOp op
- patch2 insn src dst = (insn $! patchOp src) $! patchOp dst
-
- patchOp (OpReg reg) = OpReg $! env reg
- patchOp (OpImm imm) = OpImm imm
- patchOp (OpAddr ea) = OpAddr $! lookupAddr ea
-
- lookupAddr (ImmAddr imm off) = ImmAddr imm off
- lookupAddr (AddrBaseIndex base index disp)
- = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp
- where
- lookupBase EABaseNone = EABaseNone
- lookupBase EABaseRip = EABaseRip
- lookupBase (EABaseReg r) = EABaseReg (env r)
-
- lookupIndex EAIndexNone = EAIndexNone
- lookupIndex (EAIndex r i) = EAIndex (env r) i
-
-
--- -----------------------------------------------------------------------------
--- Determine the possible destinations from the current instruction.
-
--- (we always assume that the next instruction is also a valid destination;
--- if this isn't the case then the jump should be at the end of the basic
--- block).
-
-jumpDests :: Instr -> [BlockId] -> [BlockId]
-jumpDests insn acc
- = case insn of
- JXX _ id -> id : acc
- JMP_TBL _ ids -> ids ++ acc
- _ -> acc
-
-
-isJumpish :: Instr -> Bool
-isJumpish instr
- = case instr of
- JMP{} -> True
- JXX{} -> True
- JXX_GBL{} -> True
- JMP_TBL{} -> True
- CALL{} -> True
- _ -> False
-
--- | Change the destination of this jump instruction
--- Used in joinToTargets in the linear allocator, when emitting fixup code
--- for join points.
-patchJump :: Instr -> BlockId -> BlockId -> Instr
-patchJump insn old new
- = case insn of
- JXX cc id | id == old -> JXX cc new
- JMP_TBL _ _ -> error "Cannot patch JMP_TBL"
- _other -> insn
-
-
--- -----------------------------------------------------------------------------
--- Detecting reg->reg moves
-
--- The register allocator attempts to eliminate reg->reg moves whenever it can,
--- by assigning the src and dest temporaries to the same real register.
-
-isRegRegMove :: Instr -> Maybe (Reg,Reg)
-isRegRegMove (MOV _ (OpReg r1) (OpReg r2)) = Just (r1,r2)
-isRegRegMove _ = Nothing
-
-
-
-data JumpDest = DestBlockId BlockId | DestImm Imm
-
-
-canShortcut :: Instr -> Maybe JumpDest
-canShortcut (JXX ALWAYS id) = Just (DestBlockId id)
-canShortcut (JMP (OpImm imm)) = Just (DestImm imm)
-canShortcut _ = Nothing
-
-
-shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
-shortcutJump fn insn@(JXX cc id) =
- case fn id of
- Nothing -> insn
- Just (DestBlockId id') -> shortcutJump fn (JXX cc id')
- Just (DestImm imm) -> shortcutJump fn (JXX_GBL cc imm)
-
-shortcutJump _ other = other
-
-
-
--- -----------------------------------------------------------------------------
--- Generating spill instructions
-
-mkSpillInstr
- :: Reg -- register to spill
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
-
-#if i386_TARGET_ARCH
-mkSpillInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
- let off_w = (off-delta) `div` 4
- in case regClass reg of
- RcInteger -> MOV II32 (OpReg reg) (OpAddr (spRel off_w))
- _ -> GST FF80 reg (spRel off_w) {- RcFloat/RcDouble -}
-
-#elif x86_64_TARGET_ARCH
-mkSpillInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
- let off_w = (off-delta) `div` 8
- in case regClass reg of
- RcInteger -> MOV II64 (OpReg reg) (OpAddr (spRel off_w))
- RcDouble -> MOV FF64 (OpReg reg) (OpAddr (spRel off_w))
- -- ToDo: will it work to always spill as a double?
- -- does that cause a stall if the data was a float?
-#else
-mkSpillInstr _ _ _
- = panic "X86.RegInfo.mkSpillInstr: not defined for this architecture."
-#endif
-
-
-mkLoadInstr
- :: Reg -- register to load
- -> Int -- current stack delta
- -> Int -- spill slot to use
- -> Instr
-#if i386_TARGET_ARCH
-mkLoadInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
- let off_w = (off-delta) `div` 4
- in case regClass reg of {
- RcInteger -> MOV II32 (OpAddr (spRel off_w)) (OpReg reg);
- _ -> GLD FF80 (spRel off_w) reg} {- RcFloat/RcDouble -}
-#elif x86_64_TARGET_ARCH
-mkLoadInstr reg delta slot
- = let off = spillSlotToOffset slot
- in
- let off_w = (off-delta) `div` 8
- in case regClass reg of
- RcInteger -> MOV II64 (OpAddr (spRel off_w)) (OpReg reg)
- _ -> MOV FF64 (OpAddr (spRel off_w)) (OpReg reg)
-#else
-mkLoadInstr _ _ _
- = panic "X86.RegInfo.mkLoadInstr: not defined for this architecture."
-#endif
-
-
-
-mkRegRegMoveInstr
- :: Reg
- -> Reg
- -> Instr
-mkRegRegMoveInstr src dst
- = case regClass src of
- RcInteger -> MOV wordSize (OpReg src) (OpReg dst)
-#if i386_TARGET_ARCH
- RcDouble -> GMOV src dst
- RcFloat -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"
-#else
- RcDouble -> MOV FF64 (OpReg src) (OpReg dst)
- RcFloat -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"
-#endif
-
-
-mkBranchInstr
- :: BlockId
- -> [Instr]
-
-mkBranchInstr id = [JXX ALWAYS id]
+import Platform
+import Unique
+import UniqFM
+import X86.Regs
-spillSlotSize :: Int
-spillSlotSize = IF_ARCH_i386(12, 8)
-maxSpillSlots :: Int
-maxSpillSlots = ((rESERVED_C_STACK_BYTES - 64) `div` spillSlotSize) - 1
+mkVirtualReg :: Unique -> Size -> VirtualReg
+mkVirtualReg u size
+ = case size of
+ FF32 -> VirtualRegSSE u
+ FF64 -> VirtualRegSSE u
+ FF80 -> VirtualRegD u
+ _other -> VirtualRegI u
+
+regDotColor :: RealReg -> SDoc
+regDotColor reg
+ = let Just str = lookupUFM regColors reg
+ in text str
+
+regColors :: UniqFM [Char]
+regColors = listToUFM (normalRegColors ++ fpRegColors)
+
+-- TODO: We shouldn't be using defaultTargetPlatform here.
+-- We should be passing DynFlags in instead, and looking at
+-- its targetPlatform.
+
+normalRegColors :: [(Reg,String)]
+normalRegColors = case platformArch defaultTargetPlatform of
+ ArchX86 -> [ (eax, "#00ff00")
+ , (ebx, "#0000ff")
+ , (ecx, "#00ffff")
+ , (edx, "#0080ff") ]
+ ArchX86_64 -> [ (rax, "#00ff00"), (eax, "#00ff00")
+ , (rbx, "#0000ff"), (ebx, "#0000ff")
+ , (rcx, "#00ffff"), (ecx, "#00ffff")
+ , (rdx, "#0080ff"), (edx, "#00ffff")
+ , (r8, "#00ff80")
+ , (r9, "#008080")
+ , (r10, "#0040ff")
+ , (r11, "#00ff40")
+ , (r12, "#008040")
+ , (r13, "#004080")
+ , (r14, "#004040")
+ , (r15, "#002080") ]
+ ArchPPC -> panic "X86 normalRegColors ArchPPC"
+ ArchPPC_64 -> panic "X86 normalRegColors ArchPPC_64"
+ ArchSPARC -> panic "X86 normalRegColors ArchSPARC"
+ ArchUnknown -> panic "X86 normalRegColors ArchUnknown"
+
+fpRegColors :: [(Reg,String)]
+fpRegColors =
+ [ (fake0, "#ff00ff")
+ , (fake1, "#ff00aa")
+ , (fake2, "#aa00ff")
+ , (fake3, "#aa00aa")
+ , (fake4, "#ff0055")
+ , (fake5, "#5500ff") ]
+
+ ++ zip (map regSingle [24..39]) (repeat "red")
--- convert a spill slot number to a *byte* offset, with no sign:
--- decide on a per arch basis whether you are spilling above or below
--- the C stack pointer.
-spillSlotToOffset :: Int -> Int
-spillSlotToOffset slot
- | slot >= 0 && slot < maxSpillSlots
- = 64 + spillSlotSize * slot
- | otherwise
- = pprPanic "spillSlotToOffset:"
- ( text "invalid spill location: " <> int slot
- $$ text "maxSpillSlots: " <> int maxSpillSlots)
projects / ghc-hetmet.git / blobdiff