#include "HsVersions.h"
#include "nativeGen/NCG.h"
module X86.Instr
where
import X86.Cond
import X86.Regs
import Instruction
import Size
import RegClass
import Reg
import TargetReg
import BlockId
import Cmm
import FastString
import FastBool
import Outputable
import Constants (rESERVED_C_STACK_BYTES)
import CLabel
import UniqSet
import Unique
archWordSize :: Size
#if i386_TARGET_ARCH
archWordSize = II32
#elif x86_64_TARGET_ARCH
archWordSize = II64
#else
archWordSize = panic "X86.Instr.archWordSize: not defined"
#endif
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
data Instr
= COMMENT FastString
| LDATA Section [CmmStatic]
| NEWBLOCK BlockId
| DELTA Int
| MOV Size Operand Operand
| MOVZxL Size Operand Operand
| MOVSxL Size Operand Operand
| LEA Size Operand Operand
| ADD Size Operand Operand
| ADC Size Operand Operand
| SUB Size Operand Operand
| MUL Size Operand Operand
| IMUL Size Operand Operand
| IMUL2 Size Operand
| DIV Size Operand
| IDIV Size Operand
| AND Size Operand Operand
| OR Size Operand Operand
| XOR Size Operand Operand
| NOT Size Operand
| NEGI Size Operand
| SHL Size Operand Operand
| SAR Size Operand Operand
| SHR Size Operand Operand
| BT Size Imm Operand
| NOP
| GMOV Reg Reg
| GLD Size AddrMode Reg
| GST Size Reg AddrMode
| GLDZ Reg
| GLD1 Reg
| GFTOI Reg Reg
| GDTOI Reg Reg
| GITOF Reg Reg
| GITOD Reg Reg
| GADD Size Reg Reg Reg
| GDIV Size Reg Reg Reg
| GSUB Size Reg Reg Reg
| GMUL Size Reg Reg Reg
| GCMP Cond Reg Reg
| GABS Size Reg Reg
| GNEG Size Reg Reg
| GSQRT Size Reg Reg
| GSIN Size CLabel CLabel Reg Reg
| GCOS Size CLabel CLabel Reg Reg
| GTAN Size CLabel CLabel Reg Reg
| GFREE
| CVTSS2SD Reg Reg
| CVTSD2SS Reg Reg
| CVTTSS2SIQ Size Operand Reg
| CVTTSD2SIQ Size Operand Reg
| CVTSI2SS Size Operand Reg
| CVTSI2SD Size Operand Reg
| FDIV Size Operand Operand
| SQRT Size Operand Reg
| TEST Size Operand Operand
| CMP Size Operand Operand
| SETCC Cond Operand
| PUSH Size Operand
| POP Size Operand
| JMP Operand
| JXX Cond BlockId
| JXX_GBL Cond Imm
| JMP_TBL Operand [BlockId]
| CALL (Either Imm Reg) [Reg]
| CLTD Size
| FETCHGOT Reg
| FETCHPC Reg
data Operand
= OpReg Reg
| OpImm Imm
| OpAddr AddrMode
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 [] []
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]
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
FETCHGOT reg -> mkRU [] [reg]
FETCHPC reg -> mkRU [] [reg]
COMMENT _ -> noUsage
DELTA _ -> noUsage
_other -> panic "regUsage: unrecognised instr"
where
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"
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"
usageM :: Operand -> RegUsage
usageM (OpReg reg) = mkRU [reg] [reg]
usageM (OpAddr ea) = mkRUR (use_EA ea)
usageM _ = panic "X86.RegInfo.usageM: no match"
def_W (OpReg reg) = [reg]
def_W (OpAddr _ ) = []
def_W _ = panic "X86.RegInfo.def_W: no match"
use_R (OpReg reg) = [reg]
use_R (OpImm _) = []
use_R (OpAddr ea) = use_EA ea
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 (RegVirtual _) = True
interesting (RegReal (RealRegSingle i)) = isFastTrue (freeReg i)
interesting (RegReal (RealRegPair{})) = panic "X86.interesting: no reg pairs on this arch"
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
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)
CVTSS2SD src dst -> CVTSS2SD (env src) (env dst)
CVTSD2SS src dst -> CVTSD2SS (env src) (env dst)
CVTTSS2SIQ sz src dst -> CVTTSS2SIQ sz (patchOp src) (env dst)
CVTTSD2SIQ sz src dst -> CVTTSD2SIQ sz (patchOp src) (env dst)
CVTSI2SS sz src dst -> CVTSI2SS sz (patchOp src) (env dst)
CVTSI2SD sz src dst -> CVTSI2SD sz (patchOp src) (env dst)
FDIV sz src dst -> FDIV sz (patchOp src) (patchOp dst)
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 :: (Operand -> a) -> Operand -> a
patch1 insn op = insn $! patchOp op
patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a
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
x86_mkSpillInstr
:: Reg
-> Int
-> Int
-> Instr
x86_mkSpillInstr reg delta slot
= let off = spillSlotToOffset slot
in
let off_w = (offdelta) `div` IF_ARCH_i386(4,8)
in case targetClassOfReg reg of
RcInteger -> MOV IF_ARCH_i386(II32,II64)
(OpReg reg) (OpAddr (spRel off_w))
RcDouble -> GST FF80 reg (spRel off_w)
RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel off_w))
_ -> panic "X86.mkSpillInstr: no match"
x86_mkLoadInstr
:: Reg
-> Int
-> Int
-> Instr
x86_mkLoadInstr reg delta slot
= let off = spillSlotToOffset slot
in
let off_w = (offdelta) `div` IF_ARCH_i386(4,8)
in case targetClassOfReg reg of
RcInteger -> MOV IF_ARCH_i386(II32,II64)
(OpAddr (spRel off_w)) (OpReg reg)
RcDouble -> GLD FF80 (spRel off_w) reg
RcDoubleSSE -> MOV FF64 (OpAddr (spRel off_w)) (OpReg reg)
_ -> panic "X86.x86_mkLoadInstr"
spillSlotSize :: Int
spillSlotSize = IF_ARCH_i386(12, 8)
maxSpillSlots :: Int
maxSpillSlots = ((rESERVED_C_STACK_BYTES 64) `div` spillSlotSize) 1
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)
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
x86_mkRegRegMoveInstr
:: Reg
-> Reg
-> Instr
x86_mkRegRegMoveInstr src dst
= case targetClassOfReg src of
#if i386_TARGET_ARCH
RcInteger -> MOV II32 (OpReg src) (OpReg dst)
#else
RcInteger -> MOV II64 (OpReg src) (OpReg dst)
#endif
RcDouble -> GMOV src dst
RcDoubleSSE -> MOV FF64 (OpReg src) (OpReg dst)
_ -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"
x86_takeRegRegMoveInstr
:: Instr
-> Maybe (Reg,Reg)
x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))
= Just (r1,r2)
x86_takeRegRegMoveInstr _ = Nothing
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
| otherwise
= blocks
where
ffree_before_nonlocal_transfers (BasicBlock id insns)
= BasicBlock id (foldr p [] insns)
where p insn r = case insn of
CALL _ _ -> GFREE : insn : r
JMP _ -> GFREE : insn : r
JXX_GBL _ _ -> GFREE : insn : r
_ -> insn : r
is_G_instr :: Instr -> Bool
is_G_instr instr
= case instr of
GMOV{} -> True
GLD{} -> True
GST{} -> True
GLDZ{} -> True
GLD1{} -> True
GFTOI{} -> True
GDTOI{} -> True
GITOF{} -> True
GITOD{} -> True
GADD{} -> True
GDIV{} -> True
GSUB{} -> True
GMUL{} -> True
GCMP{} -> True
GABS{} -> True
GNEG{} -> True
GSQRT{} -> True
GSIN{} -> True
GCOS{} -> True
GTAN{} -> True
GFREE -> panic "is_G_instr: GFREE (!)"
_ -> False
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 = shortcutJump' fn emptyBlockSet insn
where shortcutJump' fn seen insn@(JXX cc id) =
if elemBlockSet id seen then insn
else case fn id of
Nothing -> insn
Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm)
where seen' = extendBlockSet seen id
shortcutJump' _ _ other = other
shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic fn (CmmStaticLit (CmmLabel lab))
| Just uq <- maybeAsmTemp lab
= CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (BlockId uq)))
shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
| Just uq <- maybeAsmTemp lbl1
= CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (BlockId uq)) lbl2 off)
shortcutStatic _ other_static
= other_static
shortBlockId
:: (BlockId -> Maybe JumpDest)
-> UniqSet Unique
-> BlockId
-> CLabel
shortBlockId fn seen blockid@(BlockId uq) =
case (elementOfUniqSet uq seen, fn blockid) of
(True, _) -> mkAsmTempLabel uq
(_, Nothing) -> mkAsmTempLabel uq
(_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
(_, Just (DestImm (ImmCLbl lbl))) -> lbl
(_, _other) -> panic "shortBlockId"