1 files changed, 463 insertions, 29 deletions

diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index 0dea1dd66d..b4b6fb5f4b 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -12,34 +12,46 @@
 module X86.Instr
 where
 
-import BlockId
+import X86.Cond
 import X86.Regs
-import RegsBase
+import Instruction
+import Size
+import RegClass
+import Reg
+
+import BlockId
 import Cmm
 import FastString
+import FastBool
 
 import CLabel
 import Panic
 
-data Cond
-	= ALWAYS	-- What's really used? ToDo
-	| EQQ
-	| GE
-	| GEU
-	| GTT
-	| GU
-	| LE
-	| LEU
-	| LTT
-	| LU
-	| NE
-	| NEG
-	| POS
-	| CARRY
-	| OFLO
-	| PARITY
-	| NOTPARITY
-	deriving (Eq)
+-- Size of a PPC memory address, in bytes.
+--
+archWordSize :: Size
+#if i386_TARGET_ARCH
+archWordSize	= II32
+#elif x86_64_TARGET_ARCH
+archWordSize	= II64
+#else
+archWordSize	= panic "X86.Instr.archWordSize: not defined"
+#endif
+
+-- | Instruction instance for x86 instruction set.
+instance Instruction Instr where
+	regUsageOfInstr		= x86_regUsageOfInstr
+	patchRegsOfInstr	= x86_patchRegsOfInstr
+	isJumpishInstr		= x86_isJumpishInstr
+	jumpDestsOfInstr	= x86_jumpDestsOfInstr
+	patchJumpInstr		= x86_patchJumpInstr
+	mkSpillInstr		= x86_mkSpillInstr
+	mkLoadInstr		= x86_mkLoadInstr
+	takeDeltaInstr		= x86_takeDeltaInstr
+	isMetaInstr		= x86_isMetaInstr
+	mkRegRegMoveInstr	= x86_mkRegRegMoveInstr
+	takeRegRegMoveInstr	= x86_takeRegRegMoveInstr
+	mkJumpInstr		= x86_mkJumpInstr
 
 
 -- -----------------------------------------------------------------------------
@@ -154,13 +166,6 @@ data Instr
         -- benefit of subsequent passes
 	| DELTA   Int
 
-	-- | spill this reg to a stack slot
-	| SPILL   Reg Int
-
-	-- | reload this reg from a stack slot
-	| RELOAD  Int Reg
-
-
 	-- Moves.
 	| MOV	      Size Operand Operand
 	| MOVZxL      Size Operand Operand -- size is the size of operand 1
@@ -301,7 +306,436 @@ data Operand
 
 
 
-i386_insert_ffrees :: [GenBasicBlock Instr] -> [GenBasicBlock Instr]
+x86_regUsageOfInstr :: Instr -> RegUsage
+x86_regUsageOfInstr 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
+
+    _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)
+
+
+
+
+x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
+x86_patchRegsOfInstr 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
+
+    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
+
+
+--------------------------------------------------------------------------------
+x86_isJumpishInstr 
+	:: Instr -> Bool
+
+x86_isJumpishInstr instr
+ = case instr of
+	JMP{}		-> True
+	JXX{}		-> True
+	JXX_GBL{}	-> True
+	JMP_TBL{}	-> True
+	CALL{}		-> True
+	_		-> False
+
+
+x86_jumpDestsOfInstr
+	:: Instr 
+	-> [BlockId]
+
+x86_jumpDestsOfInstr insn 
+  = case insn of
+	JXX _ id	-> [id]
+	JMP_TBL _ ids	-> ids
+	_		-> []
+
+
+x86_patchJumpInstr 
+	:: Instr -> (BlockId -> BlockId) -> Instr
+
+x86_patchJumpInstr insn patchF
+  = case insn of
+	JXX cc id 	-> JXX cc (patchF id)
+	JMP_TBL _ _     -> error "Cannot patch JMP_TBL"
+	_		-> insn
+
+
+
+
+-- -----------------------------------------------------------------------------
+-- | Make a spill instruction.
+x86_mkSpillInstr
+	:: Reg		-- register to spill
+	-> Int		-- current stack delta
+	-> Int		-- spill slot to use
+	-> Instr
+
+#if   i386_TARGET_ARCH
+x86_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
+x86_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))
+           _         -> panic "X86.mkSpillInstr: no match"
+		-- ToDo: will it work to always spill as a double?
+		-- does that cause a stall if the data was a float?
+#else
+x86_mkSpillInstr _ _ _
+    =   panic "X86.RegInfo.mkSpillInstr: not defined for this architecture."
+#endif
+
+
+-- | Make a spill reload instruction.
+x86_mkLoadInstr
+	:: Reg		-- register to load
+	-> Int		-- current stack delta
+	-> Int		-- spill slot to use
+	-> Instr
+
+#if   i386_TARGET_ARCH
+x86_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
+x86_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
+x86_mkLoadInstr _ _ _
+ 	= panic "X86.RegInfo.mkLoadInstr: not defined for this architecture."
+#endif
+
+
+--------------------------------------------------------------------------------
+
+-- | See if this instruction is telling us the current C stack delta
+x86_takeDeltaInstr
+	:: Instr
+	-> Maybe Int
+	
+x86_takeDeltaInstr instr
+ = case instr of
+ 	DELTA i		-> Just i
+	_		-> Nothing
+
+
+x86_isMetaInstr
+	:: Instr
+	-> Bool
+	
+x86_isMetaInstr instr
+ = case instr of
+ 	COMMENT{}	-> True
+	LDATA{}		-> True
+	NEWBLOCK{}	-> True
+	DELTA{}		-> True
+	_		-> False
+
+
+
+-- | Make a reg-reg move instruction.
+--	On SPARC v8 there are no instructions to move directly between
+--	floating point and integer regs. If we need to do that then we
+--	have to go via memory.
+--
+x86_mkRegRegMoveInstr
+	:: Reg
+	-> Reg
+	-> Instr
+
+x86_mkRegRegMoveInstr src dst
+ = case regClass src of
+#if   i386_TARGET_ARCH
+        RcInteger -> MOV II32 (OpReg src) (OpReg dst)
+        RcDouble  -> GMOV src dst
+	RcFloat   -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"
+#else
+        RcInteger -> MOV II64 (OpReg src) (OpReg dst)
+        RcDouble  -> MOV FF64 (OpReg src) (OpReg dst)
+	RcFloat   -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"
+#endif
+
+
+-- | Check whether an instruction represents a reg-reg move.
+-- 	The register allocator attempts to eliminate reg->reg moves whenever it can,
+-- 	by assigning the src and dest temporaries to the same real register.
+--
+x86_takeRegRegMoveInstr
+	:: Instr 
+	-> Maybe (Reg,Reg)
+
+x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2)) 
+	= Just (r1,r2)
+
+x86_takeRegRegMoveInstr _  = Nothing
+
+
+-- | Make an unconditional branch instruction.
+x86_mkJumpInstr
+	:: BlockId
+	-> [Instr]
+
+x86_mkJumpInstr id 
+	= [JXX ALWAYS id]
+
+
+
+
+
+i386_insert_ffrees 
+	:: [GenBasicBlock Instr] 
+	-> [GenBasicBlock Instr]
+
 i386_insert_ffrees blocks
    | or (map (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ])
    = map ffree_before_nonlocal_transfers blocks