X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FX86%2FRegInfo.hs;fp=compiler%2FnativeGen%2FX86%2FRegInfo.hs;h=58d063bd88e71361b3aa4585a5b6bcd140c43c16;hb=b04a210e26ca57242fd052f2aa91011a80b76299;hp=39bc6dec10dbd71cb8911e9af3de24f196076e99;hpb=77ed23d51b968505b3ad8541c075657ae94f0ea3;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs
index 39bc6de..58d063b 100644
--- a/compiler/nativeGen/X86/RegInfo.hs
+++ b/compiler/nativeGen/X86/RegInfo.hs
@@ -1,26 +1,17 @@
 
 module X86.RegInfo (
-	RegUsage(..),
-	noUsage,
-	regUsage,
-	patchRegs,
-	jumpDests,
-	isJumpish,
-	patchJump,
-	isRegRegMove,
-
-        JumpDest(..), 
+	mkVReg,
+
+        JumpDest, 
 	canShortcut, 
 	shortcutJump, 
 
-	mkSpillInstr,
-	mkLoadInstr,
-	mkRegRegMoveInstr,
-	mkBranchInstr,
-
 	spillSlotSize,
 	maxSpillSlots,
-	spillSlotToOffset		
+	spillSlotToOffset,
+	
+	shortcutStatic,
+	regDotColor
 )
 
 where
@@ -29,341 +20,26 @@ where
 #include "HsVersions.h"
 
 import X86.Instr
+import X86.Cond
 import X86.Regs
-import RegsBase
+import Size
+import Reg
 
+import Cmm
+import CLabel
 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
+import Unique
 
+mkVReg :: Unique -> Size -> Reg
+mkVReg u size
+   | not (isFloatSize size) = VirtualRegI u
+   | otherwise
+   = case size of
+        FF32	-> VirtualRegD u
+        FF64	-> VirtualRegD u
+	_	-> panic "mkVReg"
 
 
 data JumpDest = DestBlockId BlockId | DestImm Imm
@@ -386,92 +62,6 @@ 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))
-	   RcFloat   -> panic "mkSpillInstr/RcFloat"
-		-- 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]
-
-
 spillSlotSize :: Int
 spillSlotSize = IF_ARCH_i386(12, 8)
 
@@ -489,3 +79,82 @@ spillSlotToOffset slot
    = pprPanic "spillSlotToOffset:" 
               (   text "invalid spill location: " <> int slot
 	      $$  text "maxSpillSlots:          " <> int maxSpillSlots)
+
+
+-- Here because it knows about JumpDest
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+  | Just uq <- maybeAsmTemp lab 
+  = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq)))
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
+  | Just uq <- maybeAsmTemp lbl1
+  = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off)
+        -- slightly dodgy, we're ignoring the second label, but this
+        -- works with the way we use CmmLabelDiffOff for jump tables now.
+
+shortcutStatic _ other_static
+        = other_static
+
+shortBlockId 
+	:: (BlockId -> Maybe JumpDest)
+	-> BlockId
+	-> CLabel
+
+shortBlockId fn blockid@(BlockId uq) =
+   case fn blockid of
+      Nothing -> mkAsmTempLabel uq
+      Just (DestBlockId blockid')  -> shortBlockId fn blockid'
+      Just (DestImm (ImmCLbl lbl)) -> lbl
+      _other -> panic "shortBlockId"
+
+
+
+-- reg colors for x86
+#if i386_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = let	Just	str	= lookupUFM regColors reg
+   in	text str
+
+regColors
+ = listToUFM
+ $  	[ (eax,	"#00ff00")
+	, (ebx,	"#0000ff")
+	, (ecx,	"#00ffff")
+	, (edx,	"#0080ff")
+
+	, (fake0, "#ff00ff")
+	, (fake1, "#ff00aa")
+	, (fake2, "#aa00ff")
+	, (fake3, "#aa00aa")
+	, (fake4, "#ff0055")
+	, (fake5, "#5500ff") ]
+
+
+-- reg colors for x86_64
+#elif x86_64_TARGET_ARCH
+regDotColor :: Reg -> SDoc
+regDotColor reg
+ = let	Just	str	= lookupUFM regColors reg
+   in	text str
+
+regColors
+ = listToUFM
+ $	[ (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") ]
+
+	++ zip (map RealReg [16..31]) (repeat "red")
+#else
+regDotColor :: Reg -> SDoc
+regDotColor	= panic "not defined"
+#endif