module X86.CodeGen (
cmmTopCodeGen,
InstrBlock
)
where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
#include "../includes/MachDeps.h"
import X86.Instr
import X86.Cond
import X86.Regs
import X86.RegInfo
import X86.Ppr
import Instruction
import PIC
import NCGMonad
import Size
import Reg
import RegClass
import Platform
import BasicTypes
import BlockId
import PprCmm ( pprExpr )
import Cmm
import CLabel
import ClosureInfo ( C_SRT(..) )
import StaticFlags ( opt_PIC )
import ForeignCall ( CCallConv(..) )
import OrdList
import Pretty
import qualified Outputable as O
import Outputable
import FastString
import FastBool ( isFastTrue )
import Constants ( wORD_SIZE )
import DynFlags
import Debug.Trace ( trace )
import Control.Monad ( mapAndUnzipM )
import Data.Maybe ( fromJust )
import Data.Bits
import Data.Word
import Data.Int
cmmTopCodeGen
:: DynFlags
-> RawCmmTop
-> NatM [NatCmmTop Instr]
cmmTopCodeGen dynflags
(CmmProc info lab params (ListGraph blocks)) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat
let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
tops = proc : concat statics
os = platformOS $ targetPlatform dynflags
case picBaseMb of
Just picBase -> initializePicBase_x86 ArchX86 os picBase tops
Nothing -> return tops
cmmTopCodeGen _ (CmmData sec dat) = do
return [CmmData sec dat]
basicBlockCodeGen
:: CmmBasicBlock
-> NatM ( [NatBasicBlock Instr]
, [NatCmmTop Instr])
basicBlockCodeGen (BasicBlock id stmts) = do
instrs <- stmtsToInstrs stmts
let
(top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
= ([], BasicBlock id instrs : blocks, statics)
mkBlocks (LDATA sec dat) (instrs,blocks,statics)
= (instrs, blocks, CmmData sec dat:statics)
mkBlocks instr (instrs,blocks,statics)
= (instr:instrs, blocks, statics)
return (BasicBlock id top : other_blocks, statics)
stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
stmtsToInstrs stmts
= do instrss <- mapM stmtToInstrs stmts
return (concatOL instrss)
stmtToInstrs :: CmmStmt -> NatM InstrBlock
stmtToInstrs stmt = case stmt of
CmmNop -> return nilOL
CmmComment s -> return (unitOL (COMMENT s))
CmmAssign reg src
| isFloatType ty -> assignReg_FltCode size reg src
#if WORD_SIZE_IN_BITS==32
| isWord64 ty -> assignReg_I64Code reg src
#endif
| otherwise -> assignReg_IntCode size reg src
where ty = cmmRegType reg
size = cmmTypeSize ty
CmmStore addr src
| isFloatType ty -> assignMem_FltCode size addr src
#if WORD_SIZE_IN_BITS==32
| isWord64 ty -> assignMem_I64Code addr src
#endif
| otherwise -> assignMem_IntCode size addr src
where ty = cmmExprType src
size = cmmTypeSize ty
CmmCall target result_regs args _ _
-> genCCall target result_regs args
CmmBranch id -> genBranch id
CmmCondBranch arg id -> genCondJump id arg
CmmSwitch arg ids -> genSwitch arg ids
CmmJump arg params -> genJump arg
CmmReturn params ->
panic "stmtToInstrs: return statement should have been cps'd away"
type InstrBlock
= OrdList Instr
data CondCode
= CondCode Bool Cond InstrBlock
data ChildCode64
= ChildCode64
InstrBlock
Reg
data Register
= Fixed Size Reg InstrBlock
| Any Size (Reg -> InstrBlock)
swizzleRegisterRep :: Register -> Size -> Register
swizzleRegisterRep (Fixed _ reg code) size = Fixed size reg code
swizzleRegisterRep (Any _ codefn) size = Any size codefn
getRegisterReg :: CmmReg -> Reg
getRegisterReg (CmmLocal (LocalReg u pk))
= RegVirtual $ mkVirtualReg u (cmmTypeSize pk)
getRegisterReg (CmmGlobal mid)
= case get_GlobalReg_reg_or_addr mid of
Left reg -> RegReal $ reg
_other -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
data Amode
= Amode AddrMode InstrBlock
is32BitInteger :: Integer -> Bool
is32BitInteger i = i64 <= 0x7fffffff && i64 >= 0x80000000
where i64 = fromIntegral i :: Int64
jumpTableEntry :: Maybe BlockId -> CmmStatic
jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
where blockLabel = mkAsmTempLabel id
mangleIndexTree :: CmmExpr -> CmmExpr
mangleIndexTree (CmmRegOff reg off)
= CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
where width = typeWidth (cmmRegType reg)
getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg expr = do
r <- getRegister expr
case r of
Any rep code -> do
tmp <- getNewRegNat rep
return (tmp, code tmp)
Fixed _ reg code ->
return (reg, code)
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code addrTree valueTree = do
Amode addr addr_code <- getAmode addrTree
ChildCode64 vcode rlo <- iselExpr64 valueTree
let
rhi = getHiVRegFromLo rlo
mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)
mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))
return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do
ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
let
r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
r_dst_hi = getHiVRegFromLo r_dst_lo
r_src_hi = getHiVRegFromLo r_src_lo
mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)
mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)
return (
vcode `snocOL` mov_lo `snocOL` mov_hi
)
assignReg_I64Code lvalue valueTree
= panic "assignReg_I64Code(i386): invalid lvalue"
iselExpr64 :: CmmExpr -> NatM ChildCode64
iselExpr64 (CmmLit (CmmInt i _)) = do
(rlo,rhi) <- getNewRegPairNat II32
let
r = fromIntegral (fromIntegral i :: Word32)
q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32)
code = toOL [
MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),
MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)
]
return (ChildCode64 code rlo)
iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
Amode addr addr_code <- getAmode addrTree
(rlo,rhi) <- getNewRegPairNat II32
let
mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)
mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)
return (
ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
)
iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
= return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do
ChildCode64 code1 r1lo <- iselExpr64 e1
(rlo,rhi) <- getNewRegPairNat II32
let
r = fromIntegral (fromIntegral i :: Word32)
q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32)
r1hi = getHiVRegFromLo r1lo
code = code1 `appOL`
toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),
MOV II32 (OpReg r1hi) (OpReg rhi),
ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]
return (ChildCode64 code rlo)
iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
ChildCode64 code1 r1lo <- iselExpr64 e1
ChildCode64 code2 r2lo <- iselExpr64 e2
(rlo,rhi) <- getNewRegPairNat II32
let
r1hi = getHiVRegFromLo r1lo
r2hi = getHiVRegFromLo r2lo
code = code1 `appOL`
code2 `appOL`
toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
ADD II32 (OpReg r2lo) (OpReg rlo),
MOV II32 (OpReg r1hi) (OpReg rhi),
ADC II32 (OpReg r2hi) (OpReg rhi) ]
return (ChildCode64 code rlo)
iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do
fn <- getAnyReg expr
r_dst_lo <- getNewRegNat II32
let r_dst_hi = getHiVRegFromLo r_dst_lo
code = fn r_dst_lo
return (
ChildCode64 (code `snocOL`
MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))
r_dst_lo
)
iselExpr64 expr
= pprPanic "iselExpr64(i386)" (ppr expr)
getRegister :: CmmExpr -> NatM Register
#if !x86_64_TARGET_ARCH
getRegister (CmmReg (CmmGlobal PicBaseReg))
= do
reg <- getPicBaseNat archWordSize
return (Fixed archWordSize reg nilOL)
#endif
getRegister (CmmReg reg)
= return (Fixed (cmmTypeSize (cmmRegType reg))
(getRegisterReg reg) nilOL)
getRegister tree@(CmmRegOff _ _)
= getRegister (mangleIndexTree tree)
#if WORD_SIZE_IN_BITS==32
getRegister (CmmMachOp (MO_UU_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister (CmmMachOp (MO_SS_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
#endif
#if i386_TARGET_ARCH
getRegister (CmmLit (CmmFloat f W32)) = do
lbl <- getNewLabelNat
dflags <- getDynFlagsNat
dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
Amode addr addr_code <- getAmode dynRef
let code dst =
LDATA ReadOnlyData
[CmmDataLabel lbl,
CmmStaticLit (CmmFloat f W32)]
`consOL` (addr_code `snocOL`
GLD FF32 addr dst)
return (Any FF32 code)
getRegister (CmmLit (CmmFloat d W64))
| d == 0.0
= let code dst = unitOL (GLDZ dst)
in return (Any FF64 code)
| d == 1.0
= let code dst = unitOL (GLD1 dst)
in return (Any FF64 code)
| otherwise = do
lbl <- getNewLabelNat
dflags <- getDynFlagsNat
dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
Amode addr addr_code <- getAmode dynRef
let code dst =
LDATA ReadOnlyData
[CmmDataLabel lbl,
CmmStaticLit (CmmFloat d W64)]
`consOL` (addr_code `snocOL`
GLD FF64 addr dst)
return (Any FF64 code)
#endif /* i386_TARGET_ARCH */
#if x86_64_TARGET_ARCH
getRegister (CmmLit (CmmFloat 0.0 w)) = do
let size = floatSize w
code dst = unitOL (XOR size (OpReg dst) (OpReg dst))
return (Any size code)
getRegister (CmmLit (CmmFloat f w)) = do
lbl <- getNewLabelNat
let code dst = toOL [
LDATA ReadOnlyData
[CmmDataLabel lbl,
CmmStaticLit (CmmFloat f w)],
MOV size (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst)
]
return (Any size code)
where size = floatSize w
#endif /* x86_64_TARGET_ARCH */
getRegister (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do
code <- intLoadCode (MOVZxL II8) addr
return (Any II32 code)
getRegister (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do
code <- intLoadCode (MOVSxL II8) addr
return (Any II32 code)
getRegister (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do
code <- intLoadCode (MOVZxL II16) addr
return (Any II32 code)
getRegister (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do
code <- intLoadCode (MOVSxL II16) addr
return (Any II32 code)
#if x86_64_TARGET_ARCH
getRegister (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) = do
code <- intLoadCode (MOVZxL II8) addr
return (Any II64 code)
getRegister (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) = do
code <- intLoadCode (MOVSxL II8) addr
return (Any II64 code)
getRegister (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) = do
code <- intLoadCode (MOVZxL II16) addr
return (Any II64 code)
getRegister (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) = do
code <- intLoadCode (MOVSxL II16) addr
return (Any II64 code)
getRegister (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) = do
code <- intLoadCode (MOV II32) addr
return (Any II64 code)
getRegister (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) = do
code <- intLoadCode (MOVSxL II32) addr
return (Any II64 code)
getRegister (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
CmmLit displacement])
= return $ Any II64 (\dst -> unitOL $
LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))
getRegister (CmmMachOp (MO_F_Neg W32) [x]) = do
x_code <- getAnyReg x
lbl <- getNewLabelNat
let
code dst = x_code dst `appOL` toOL [
LDATA ReadOnlyData16 [
CmmAlign 16,
CmmDataLabel lbl,
CmmStaticLit (CmmInt 0x80000000 W32),
CmmStaticLit (CmmInt 0 W32),
CmmStaticLit (CmmInt 0 W32),
CmmStaticLit (CmmInt 0 W32)
],
XOR FF32 (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst)
]
return (Any FF32 code)
getRegister (CmmMachOp (MO_F_Neg W64) [x]) = do
x_code <- getAnyReg x
lbl <- getNewLabelNat
let
code dst = x_code dst `appOL` toOL [
LDATA ReadOnlyData16 [
CmmAlign 16,
CmmDataLabel lbl,
CmmStaticLit (CmmInt 0x8000000000000000 W64),
CmmStaticLit (CmmInt 0 W64)
],
XOR FF64 (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst)
]
return (Any FF64 code)
#endif /* x86_64_TARGET_ARCH */
getRegister (CmmMachOp mop [x])
= case mop of
#if i386_TARGET_ARCH
MO_F_Neg W32 -> trivialUFCode FF32 (GNEG FF32) x
MO_F_Neg W64 -> trivialUFCode FF64 (GNEG FF64) x
#endif
MO_S_Neg w -> triv_ucode NEGI (intSize w)
MO_F_Neg w -> triv_ucode NEGI (floatSize w)
MO_Not w -> triv_ucode NOT (intSize w)
MO_UU_Conv W32 W8 -> toI8Reg W32 x
MO_SS_Conv W32 W8 -> toI8Reg W32 x
MO_UU_Conv W16 W8 -> toI8Reg W16 x
MO_SS_Conv W16 W8 -> toI8Reg W16 x
MO_UU_Conv W32 W16 -> toI16Reg W32 x
MO_SS_Conv W32 W16 -> toI16Reg W32 x
#if x86_64_TARGET_ARCH
MO_UU_Conv W64 W32 -> conversionNop II64 x
MO_SS_Conv W64 W32 -> conversionNop II64 x
MO_UU_Conv W64 W16 -> toI16Reg W64 x
MO_SS_Conv W64 W16 -> toI16Reg W64 x
MO_UU_Conv W64 W8 -> toI8Reg W64 x
MO_SS_Conv W64 W8 -> toI8Reg W64 x
#endif
MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x
MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x
MO_UU_Conv W8 W32 -> integerExtend W8 W32 MOVZxL x
MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x
MO_UU_Conv W8 W16 -> integerExtend W8 W16 MOVZxL x
MO_SS_Conv W8 W32 -> integerExtend W8 W32 MOVSxL x
MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x
MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x
#if x86_64_TARGET_ARCH
MO_UU_Conv W8 W64 -> integerExtend W8 W64 MOVZxL x
MO_UU_Conv W16 W64 -> integerExtend W16 W64 MOVZxL x
MO_UU_Conv W32 W64 -> integerExtend W32 W64 MOVZxL x
MO_SS_Conv W8 W64 -> integerExtend W8 W64 MOVSxL x
MO_SS_Conv W16 W64 -> integerExtend W16 W64 MOVSxL x
MO_SS_Conv W32 W64 -> integerExtend W32 W64 MOVSxL x
#endif
#if i386_TARGET_ARCH
MO_FF_Conv W32 W64 -> conversionNop FF64 x
MO_FF_Conv W64 W32 -> conversionNop FF32 x
#else
MO_FF_Conv W32 W64 -> coerceFP2FP W64 x
MO_FF_Conv W64 W32 -> coerceFP2FP W32 x
#endif
MO_FS_Conv from to -> coerceFP2Int from to x
MO_SF_Conv from to -> coerceInt2FP from to x
other -> pprPanic "getRegister" (pprMachOp mop)
where
triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register
triv_ucode instr size = trivialUCode size (instr size) x
integerExtend :: Width -> Width
-> (Size -> Operand -> Operand -> Instr)
-> CmmExpr -> NatM Register
integerExtend from to instr expr = do
(reg,e_code) <- if from == W8 then getByteReg expr
else getSomeReg expr
let
code dst =
e_code `snocOL`
instr (intSize from) (OpReg reg) (OpReg dst)
return (Any (intSize to) code)
toI8Reg :: Width -> CmmExpr -> NatM Register
toI8Reg new_rep expr
= do codefn <- getAnyReg expr
return (Any (intSize new_rep) codefn)
toI16Reg = toI8Reg
conversionNop :: Size -> CmmExpr -> NatM Register
conversionNop new_size expr
= do e_code <- getRegister expr
return (swizzleRegisterRep e_code new_size)
getRegister e@(CmmMachOp mop [x, y])
= case mop of
MO_F_Eq w -> condFltReg EQQ x y
MO_F_Ne w -> condFltReg NE x y
MO_F_Gt w -> condFltReg GTT x y
MO_F_Ge w -> condFltReg GE x y
MO_F_Lt w -> condFltReg LTT x y
MO_F_Le w -> condFltReg LE x y
MO_Eq rep -> condIntReg EQQ x y
MO_Ne rep -> condIntReg NE x y
MO_S_Gt rep -> condIntReg GTT x y
MO_S_Ge rep -> condIntReg GE x y
MO_S_Lt rep -> condIntReg LTT x y
MO_S_Le rep -> condIntReg LE x y
MO_U_Gt rep -> condIntReg GU x y
MO_U_Ge rep -> condIntReg GEU x y
MO_U_Lt rep -> condIntReg LU x y
MO_U_Le rep -> condIntReg LEU x y
#if i386_TARGET_ARCH
MO_F_Add w -> trivialFCode w GADD x y
MO_F_Sub w -> trivialFCode w GSUB x y
MO_F_Quot w -> trivialFCode w GDIV x y
MO_F_Mul w -> trivialFCode w GMUL x y
#endif
#if x86_64_TARGET_ARCH
MO_F_Add w -> trivialFCode w ADD x y
MO_F_Sub w -> trivialFCode w SUB x y
MO_F_Quot w -> trivialFCode w FDIV x y
MO_F_Mul w -> trivialFCode w MUL x y
#endif
MO_Add rep -> add_code rep x y
MO_Sub rep -> sub_code rep x y
MO_S_Quot rep -> div_code rep True True x y
MO_S_Rem rep -> div_code rep True False x y
MO_U_Quot rep -> div_code rep False True x y
MO_U_Rem rep -> div_code rep False False x y
MO_S_MulMayOflo rep -> imulMayOflo rep x y
MO_Mul rep -> triv_op rep IMUL
MO_And rep -> triv_op rep AND
MO_Or rep -> triv_op rep OR
MO_Xor rep -> triv_op rep XOR
MO_Shl rep -> shift_code rep SHL x y
MO_U_Shr rep -> shift_code rep SHR x y
MO_S_Shr rep -> shift_code rep SAR x y
other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
where
triv_op width instr = trivialCode width op (Just op) x y
where op = instr (intSize width)
imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo rep a b = do
(a_reg, a_code) <- getNonClobberedReg a
b_code <- getAnyReg b
let
shift_amt = case rep of
W32 -> 31
W64 -> 63
_ -> panic "shift_amt"
size = intSize rep
code = a_code `appOL` b_code eax `appOL`
toOL [
IMUL2 size (OpReg a_reg),
SAR size (OpImm (ImmInt shift_amt)) (OpReg eax),
SUB size (OpReg edx) (OpReg eax)
]
return (Fixed size eax code)
shift_code :: Width
-> (Size -> Operand -> Operand -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shift_code width instr x y@(CmmLit lit) = do
x_code <- getAnyReg x
let
size = intSize width
code dst
= x_code dst `snocOL`
instr size (OpImm (litToImm lit)) (OpReg dst)
return (Any size code)
shift_code width instr x y = do
x_code <- getAnyReg x
let size = intSize width
tmp <- getNewRegNat size
y_code <- getAnyReg y
let
code = x_code tmp `appOL`
y_code ecx `snocOL`
instr size (OpReg ecx) (OpReg tmp)
return (Fixed size tmp code)
add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
add_code rep x (CmmLit (CmmInt y _))
| is32BitInteger y = add_int rep x y
add_code rep x y = trivialCode rep (ADD size) (Just (ADD size)) x y
where size = intSize rep
sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
sub_code rep x (CmmLit (CmmInt y _))
| is32BitInteger (y) = add_int rep x (y)
sub_code rep x y = trivialCode rep (SUB (intSize rep)) Nothing x y
add_int width x y = do
(x_reg, x_code) <- getSomeReg x
let
size = intSize width
imm = ImmInt (fromInteger y)
code dst
= x_code `snocOL`
LEA size
(OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))
(OpReg dst)
return (Any size code)
div_code width signed quotient x y = do
(y_op, y_code) <- getRegOrMem y
x_code <- getAnyReg x
let
size = intSize width
widen | signed = CLTD size
| otherwise = XOR size (OpReg edx) (OpReg edx)
instr | signed = IDIV
| otherwise = DIV
code = y_code `appOL`
x_code eax `appOL`
toOL [widen, instr size y_op]
result | quotient = eax
| otherwise = edx
return (Fixed size result code)
getRegister (CmmLoad mem pk)
| isFloatType pk
= do
Amode src mem_code <- getAmode mem
let
size = cmmTypeSize pk
code dst = mem_code `snocOL`
IF_ARCH_i386(GLD size src dst,
MOV size (OpAddr src) (OpReg dst))
return (Any size code)
#if i386_TARGET_ARCH
getRegister (CmmLoad mem pk)
| not (isWord64 pk)
= do
code <- intLoadCode instr mem
return (Any size code)
where
width = typeWidth pk
size = intSize width
instr = case width of
W8 -> MOVZxL II8
_other -> MOV size
#endif
#if x86_64_TARGET_ARCH
getRegister (CmmLoad mem pk)
= do
code <- intLoadCode (MOV size) mem
return (Any size code)
where size = intSize $ typeWidth pk
#endif
getRegister (CmmLit (CmmInt 0 width))
= let
size = intSize width
adj_size = case size of II64 -> II32; _ -> size
size1 = IF_ARCH_i386( size, adj_size )
code dst
= unitOL (XOR size1 (OpReg dst) (OpReg dst))
in
return (Any size code)
#if x86_64_TARGET_ARCH
getRegister (CmmLit lit)
| isWord64 (cmmLitType lit), not (isBigLit lit)
= let
imm = litToImm lit
code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))
in
return (Any II64 code)
where
isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff
isBigLit _ = False
#endif
getRegister (CmmLit lit)
= let
size = cmmTypeSize (cmmLitType lit)
imm = litToImm lit
code dst = unitOL (MOV size (OpImm imm) (OpReg dst))
in
return (Any size code)
getRegister other = pprPanic "getRegister(x86)" (ppr other)
intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
-> NatM (Reg -> InstrBlock)
intLoadCode instr mem = do
Amode src mem_code <- getAmode mem
return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))
getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
getAnyReg expr = do
r <- getRegister expr
anyReg r
anyReg :: Register -> NatM (Reg -> InstrBlock)
anyReg (Any _ code) = return code
anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)
getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
#if x86_64_TARGET_ARCH
getByteReg = getSomeReg
#else
getByteReg expr = do
r <- getRegister expr
case r of
Any rep code -> do
tmp <- getNewRegNat rep
return (tmp, code tmp)
Fixed rep reg code
| isVirtualReg reg -> return (reg,code)
| otherwise -> do
tmp <- getNewRegNat rep
return (tmp, code `snocOL` reg2reg rep reg tmp)
#endif
getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
getNonClobberedReg expr = do
r <- getRegister expr
case r of
Any rep code -> do
tmp <- getNewRegNat rep
return (tmp, code tmp)
Fixed rep reg code
| RegReal (RealRegSingle rr) <- reg
, isFastTrue (freeReg rr)
-> do
tmp <- getNewRegNat rep
return (tmp, code `snocOL` reg2reg rep reg tmp)
| otherwise ->
return (reg, code)
reg2reg :: Size -> Reg -> Reg -> Instr
reg2reg size src dst
#if i386_TARGET_ARCH
| isFloatSize size = GMOV src dst
#endif
| otherwise = MOV size (OpReg src) (OpReg dst)
getAmode :: CmmExpr -> NatM Amode
getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree)
#if x86_64_TARGET_ARCH
getAmode (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
CmmLit displacement])
= return $ Amode (ripRel (litToImm displacement)) nilOL
#endif
getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit lit@(CmmInt i _)])
| is32BitLit lit
= do (x_reg, x_code) <- getSomeReg x
let off = ImmInt ((fromInteger i))
return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
getAmode (CmmMachOp (MO_Add rep) [x, CmmLit lit@(CmmInt i _)])
| is32BitLit lit
= do (x_reg, x_code) <- getSomeReg x
let off = ImmInt (fromInteger i)
return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
getAmode (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),
b@(CmmLit _)])
= getAmode (CmmMachOp (MO_Add rep) [b,a])
getAmode (CmmMachOp (MO_Add rep) [x, CmmMachOp (MO_Shl _)
[y, CmmLit (CmmInt shift _)]])
| shift == 0 || shift == 1 || shift == 2 || shift == 3
= x86_complex_amode x y shift 0
getAmode (CmmMachOp (MO_Add rep)
[x, CmmMachOp (MO_Add _)
[CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],
CmmLit (CmmInt offset _)]])
| shift == 0 || shift == 1 || shift == 2 || shift == 3
&& is32BitInteger offset
= x86_complex_amode x y shift offset
getAmode (CmmMachOp (MO_Add rep) [x,y])
= x86_complex_amode x y 0 0
getAmode (CmmLit lit) | is32BitLit lit
= return (Amode (ImmAddr (litToImm lit) 0) nilOL)
getAmode expr = do
(reg,code) <- getSomeReg expr
return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)
x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
x86_complex_amode base index shift offset
= do (x_reg, x_code) <- getNonClobberedReg base
(y_reg, y_code) <- getSomeReg index
let
code = x_code `appOL` y_code
base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8
return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))
code)
getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
#if x86_64_TARGET_ARCH
getNonClobberedOperand (CmmLit lit)
| isSuitableFloatingPointLit lit = do
lbl <- getNewLabelNat
let code = unitOL (LDATA ReadOnlyData [CmmDataLabel lbl,
CmmStaticLit lit])
return (OpAddr (ripRel (ImmCLbl lbl)), code)
#endif
getNonClobberedOperand (CmmLit lit)
| is32BitLit lit && not (isFloatType (cmmLitType lit)) =
return (OpImm (litToImm lit), nilOL)
getNonClobberedOperand (CmmLoad mem pk)
| IF_ARCH_i386(not (isFloatType pk) && not (isWord64 pk), True) = do
Amode src mem_code <- getAmode mem
(src',save_code) <-
if (amodeCouldBeClobbered src)
then do
tmp <- getNewRegNat archWordSize
return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),
unitOL (LEA II32 (OpAddr src) (OpReg tmp)))
else
return (src, nilOL)
return (OpAddr src', save_code `appOL` mem_code)
getNonClobberedOperand e = do
(reg, code) <- getNonClobberedReg e
return (OpReg reg, code)
amodeCouldBeClobbered :: AddrMode -> Bool
amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode)
regClobbered (RegReal (RealRegSingle rr)) = isFastTrue (freeReg rr)
regClobbered _ = False
getOperand :: CmmExpr -> NatM (Operand, InstrBlock)
#if x86_64_TARGET_ARCH
getOperand (CmmLit lit)
| isSuitableFloatingPointLit lit = do
lbl <- getNewLabelNat
let code = unitOL (LDATA ReadOnlyData [CmmDataLabel lbl,
CmmStaticLit lit])
return (OpAddr (ripRel (ImmCLbl lbl)), code)
#endif
getOperand (CmmLit lit)
| is32BitLit lit && not (isFloatType (cmmLitType lit)) = do
return (OpImm (litToImm lit), nilOL)
getOperand (CmmLoad mem pk)
| IF_ARCH_i386(not (isFloatType pk) && not (isWord64 pk), True) = do
Amode src mem_code <- getAmode mem
return (OpAddr src, mem_code)
getOperand e = do
(reg, code) <- getSomeReg e
return (OpReg reg, code)
isOperand :: CmmExpr -> Bool
isOperand (CmmLoad _ _) = True
isOperand (CmmLit lit) = is32BitLit lit
|| isSuitableFloatingPointLit lit
isOperand _ = False
isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0
isSuitableFloatingPointLit _ = False
getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
getRegOrMem (CmmLoad mem pk)
| IF_ARCH_i386(not (isFloatType pk) && not (isWord64 pk), True) = do
Amode src mem_code <- getAmode mem
return (OpAddr src, mem_code)
getRegOrMem e = do
(reg, code) <- getNonClobberedReg e
return (OpReg reg, code)
#if x86_64_TARGET_ARCH
is32BitLit (CmmInt i W64) = is32BitInteger i
#endif
is32BitLit x = True
getCondCode :: CmmExpr -> NatM CondCode
getCondCode (CmmMachOp mop [x, y])
=
case mop of
MO_F_Eq W32 -> condFltCode EQQ x y
MO_F_Ne W32 -> condFltCode NE x y
MO_F_Gt W32 -> condFltCode GTT x y
MO_F_Ge W32 -> condFltCode GE x y
MO_F_Lt W32 -> condFltCode LTT x y
MO_F_Le W32 -> condFltCode LE x y
MO_F_Eq W64 -> condFltCode EQQ x y
MO_F_Ne W64 -> condFltCode NE x y
MO_F_Gt W64 -> condFltCode GTT x y
MO_F_Ge W64 -> condFltCode GE x y
MO_F_Lt W64 -> condFltCode LTT x y
MO_F_Le W64 -> condFltCode LE x y
MO_Eq rep -> condIntCode EQQ x y
MO_Ne rep -> condIntCode NE x y
MO_S_Gt rep -> condIntCode GTT x y
MO_S_Ge rep -> condIntCode GE x y
MO_S_Lt rep -> condIntCode LTT x y
MO_S_Le rep -> condIntCode LE x y
MO_U_Gt rep -> condIntCode GU x y
MO_U_Ge rep -> condIntCode GEU x y
MO_U_Lt rep -> condIntCode LU x y
MO_U_Le rep -> condIntCode LEU x y
other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y]))
getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other)
condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode cond (CmmLoad x pk) (CmmLit lit) | is32BitLit lit = do
Amode x_addr x_code <- getAmode x
let
imm = litToImm lit
code = x_code `snocOL`
CMP (cmmTypeSize pk) (OpImm imm) (OpAddr x_addr)
return (CondCode False cond code)
condIntCode cond (CmmMachOp (MO_And rep) [x,o2]) (CmmLit (CmmInt 0 pk))
| (CmmLit lit@(CmmInt mask pk2)) <- o2, is32BitLit lit
= do
(x_reg, x_code) <- getSomeReg x
let
code = x_code `snocOL`
TEST (intSize pk) (OpImm (ImmInteger mask)) (OpReg x_reg)
return (CondCode False cond code)
condIntCode cond x (CmmLit (CmmInt 0 pk)) = do
(x_reg, x_code) <- getSomeReg x
let
code = x_code `snocOL`
TEST (intSize pk) (OpReg x_reg) (OpReg x_reg)
return (CondCode False cond code)
condIntCode cond x y | isOperand y = do
(x_reg, x_code) <- getNonClobberedReg x
(y_op, y_code) <- getOperand y
let
code = x_code `appOL` y_code `snocOL`
CMP (cmmTypeSize (cmmExprType x)) y_op (OpReg x_reg)
return (CondCode False cond code)
condIntCode cond x y = do
(y_reg, y_code) <- getNonClobberedReg y
(x_op, x_code) <- getRegOrMem x
let
code = y_code `appOL`
x_code `snocOL`
CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op
return (CondCode False cond code)
condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
#if i386_TARGET_ARCH
condFltCode cond x y
= ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do
(x_reg, x_code) <- getNonClobberedReg x
(y_reg, y_code) <- getSomeReg y
let
code = x_code `appOL` y_code `snocOL`
GCMP cond x_reg y_reg
return (CondCode True EQQ code)
#elif x86_64_TARGET_ARCH
condFltCode cond x y = do
(x_reg, x_code) <- getNonClobberedReg x
(y_op, y_code) <- getOperand y
let
code = x_code `appOL`
y_code `snocOL`
CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg)
return (CondCode True (condToUnsigned cond) code)
#else
condFltCode = panic "X86.condFltCode: not defined"
#endif
assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock
assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,
CmmLit (CmmInt i _)])
| addr == addr2, pk /= II64 || is32BitInteger i,
Just instr <- check op
= do Amode amode code_addr <- getAmode addr
let code = code_addr `snocOL`
instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)
return code
where
check (MO_Add _) = Just ADD
check (MO_Sub _) = Just SUB
check _ = Nothing
assignMem_IntCode pk addr src = do
Amode addr code_addr <- getAmode addr
(code_src, op_src) <- get_op_RI src
let
code = code_src `appOL`
code_addr `snocOL`
MOV pk op_src (OpAddr addr)
return code
where
get_op_RI :: CmmExpr -> NatM (InstrBlock,Operand)
get_op_RI (CmmLit lit) | is32BitLit lit
= return (nilOL, OpImm (litToImm lit))
get_op_RI op
= do (reg,code) <- getNonClobberedReg op
return (code, OpReg reg)
assignReg_IntCode pk reg (CmmLoad src _) = do
load_code <- intLoadCode (MOV pk) src
return (load_code (getRegisterReg reg))
assignReg_IntCode pk reg src = do
code <- getAnyReg src
return (code (getRegisterReg reg))
assignMem_FltCode pk addr src = do
(src_reg, src_code) <- getNonClobberedReg src
Amode addr addr_code <- getAmode addr
let
code = src_code `appOL`
addr_code `snocOL`
IF_ARCH_i386(GST pk src_reg addr,
MOV pk (OpReg src_reg) (OpAddr addr))
return code
assignReg_FltCode pk reg src = do
src_code <- getAnyReg src
return (src_code (getRegisterReg reg))
genJump :: CmmExpr -> NatM InstrBlock
genJump (CmmLoad mem pk) = do
Amode target code <- getAmode mem
return (code `snocOL` JMP (OpAddr target))
genJump (CmmLit lit) = do
return (unitOL (JMP (OpImm (litToImm lit))))
genJump expr = do
(reg,code) <- getSomeReg expr
return (code `snocOL` JMP (OpReg reg))
genBranch :: BlockId -> NatM InstrBlock
genBranch = return . toOL . mkJumpInstr
genCondJump
:: BlockId
-> CmmExpr
-> NatM InstrBlock
#if i386_TARGET_ARCH
genCondJump id bool = do
CondCode _ cond code <- getCondCode bool
return (code `snocOL` JXX cond id)
#elif x86_64_TARGET_ARCH
genCondJump id bool = do
CondCode is_float cond cond_code <- getCondCode bool
if not is_float
then
return (cond_code `snocOL` JXX cond id)
else do
lbl <- getBlockIdNat
let code = case cond of
NE -> or_unordered
GU -> plain_test
GEU -> plain_test
_ -> and_ordered
plain_test = unitOL (
JXX cond id
)
or_unordered = toOL [
JXX cond id,
JXX PARITY id
]
and_ordered = toOL [
JXX PARITY lbl,
JXX cond id,
JXX ALWAYS lbl,
NEWBLOCK lbl
]
return (cond_code `appOL` code)
#else
genCondJump = panic "X86.genCondJump: not defined"
#endif
genCCall
:: CmmCallTarget
-> HintedCmmFormals
-> HintedCmmActuals
-> NatM InstrBlock
#if i386_TARGET_ARCH
genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
genCCall (CmmPrim op) [CmmHinted r _] args = do
l1 <- getNewLabelNat
l2 <- getNewLabelNat
case op of
MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args
MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args
MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args
MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args
MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args
MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args
MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args
MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args
other_op -> outOfLineFloatOp op r args
where
actuallyInlineFloatOp instr size [CmmHinted x _]
= do res <- trivialUFCode size (instr size) x
any <- anyReg res
return (any (getRegisterReg (CmmLocal r)))
genCCall target dest_regs args = do
let
sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args)
#if !darwin_TARGET_OS
tot_arg_size = sum sizes
#else
raw_arg_size = sum sizes
tot_arg_size = roundTo 16 raw_arg_size
arg_pad_size = tot_arg_size raw_arg_size
delta0 <- getDeltaNat
setDeltaNat (delta0 arg_pad_size)
#endif
push_codes <- mapM push_arg (reverse args)
delta <- getDeltaNat
(callinsns,cconv) <-
case target of
CmmCallee (CmmLit (CmmLabel lbl)) conv
->
return (unitOL (CALL (Left fn_imm) []), conv)
where fn_imm = ImmCLbl lbl
CmmCallee expr conv
-> do { (dyn_c, dyn_r) <- get_op expr
; ASSERT( isWord32 (cmmExprType expr) )
return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
let push_code
#if darwin_TARGET_OS
| arg_pad_size /= 0
= toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),
DELTA (delta0 arg_pad_size)]
`appOL` concatOL push_codes
| otherwise
#endif
= concatOL push_codes
call = callinsns `appOL`
toOL (
(if cconv == StdCallConv || tot_arg_size==0 then [] else
[ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)])
++
[DELTA (delta + tot_arg_size)]
)
setDeltaNat (delta + tot_arg_size)
let
assign_code [] = nilOL
assign_code [CmmHinted dest _hint]
| isFloatType ty = unitOL (GMOV fake0 r_dest)
| isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest),
MOV II32 (OpReg edx) (OpReg r_dest_hi)]
| otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest))
where
ty = localRegType dest
w = typeWidth ty
r_dest_hi = getHiVRegFromLo r_dest
r_dest = getRegisterReg (CmmLocal dest)
assign_code many = panic "genCCall.assign_code many"
return (push_code `appOL`
call `appOL`
assign_code dest_regs)
where
arg_size :: CmmType -> Int
arg_size ty = widthInBytes (typeWidth ty)
roundTo a x | x `mod` a == 0 = x
| otherwise = x + a (x `mod` a)
push_arg :: HintedCmmActual
-> NatM InstrBlock
push_arg (CmmHinted arg _hint)
| isWord64 arg_ty = do
ChildCode64 code r_lo <- iselExpr64 arg
delta <- getDeltaNat
setDeltaNat (delta 8)
let
r_hi = getHiVRegFromLo r_lo
return ( code `appOL`
toOL [PUSH II32 (OpReg r_hi), DELTA (delta 4),
PUSH II32 (OpReg r_lo), DELTA (delta 8),
DELTA (delta8)]
)
| otherwise = do
(code, reg) <- get_op arg
delta <- getDeltaNat
let size = arg_size arg_ty
setDeltaNat (deltasize)
if (isFloatType arg_ty)
then return (code `appOL`
toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),
DELTA (deltasize),
GST (floatSize (typeWidth arg_ty))
reg (AddrBaseIndex (EABaseReg esp)
EAIndexNone
(ImmInt 0))]
)
else return (code `snocOL`
PUSH II32 (OpReg reg) `snocOL`
DELTA (deltasize)
)
where
arg_ty = cmmExprType arg
get_op :: CmmExpr -> NatM (InstrBlock, Reg)
get_op op = do
(reg,code) <- getSomeReg op
return (code, reg)
#elif x86_64_TARGET_ARCH
genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL
genCCall (CmmPrim op) [CmmHinted r _] args =
outOfLineFloatOp op r args
genCCall target dest_regs args = do
(stack_args, aregs, fregs, load_args_code)
<- load_args args allArgRegs allFPArgRegs nilOL
let
fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs))
int_regs_used = reverse (drop (length aregs) (reverse allArgRegs))
arg_regs = [eax] ++ int_regs_used ++ fp_regs_used
sse_regs = length fp_regs_used
tot_arg_size = arg_size * length stack_args
(real_size, adjust_rsp) <-
if tot_arg_size `rem` 16 == 0
then return (tot_arg_size, nilOL)
else do
delta <- getDeltaNat
setDeltaNat (delta8)
return (tot_arg_size+8, toOL [
SUB II64 (OpImm (ImmInt 8)) (OpReg rsp),
DELTA (delta8)
])
push_code <- push_args (reverse stack_args) nilOL
delta <- getDeltaNat
(callinsns,cconv) <-
case target of
CmmCallee (CmmLit (CmmLabel lbl)) conv
->
return (unitOL (CALL (Left fn_imm) arg_regs), conv)
where fn_imm = ImmCLbl lbl
CmmCallee expr conv
-> do (dyn_r, dyn_c) <- getSomeReg expr
return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
let
assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))
let call = callinsns `appOL`
toOL (
(if cconv == StdCallConv || real_size==0 then [] else
[ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)])
++
[DELTA (delta + real_size)]
)
setDeltaNat (delta + real_size)
let
assign_code [] = nilOL
assign_code [CmmHinted dest _hint] =
case typeWidth rep of
W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest))
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
r_dest = getRegisterReg (CmmLocal dest)
assign_code many = panic "genCCall.assign_code many"
return (load_args_code `appOL`
adjust_rsp `appOL`
push_code `appOL`
assign_eax sse_regs `appOL`
call `appOL`
assign_code dest_regs)
where
arg_size = 8
load_args :: [CmmHinted CmmExpr]
-> [Reg]
-> [Reg]
-> InstrBlock
-> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock)
load_args args [] [] code = return (args, [], [], code)
load_args [] aregs fregs code = return ([], aregs, fregs, code)
load_args ((CmmHinted arg hint) : rest) aregs fregs code
| isFloatType arg_rep =
case fregs of
[] -> push_this_arg
(r:rs) -> do
arg_code <- getAnyReg arg
load_args rest aregs rs (code `appOL` arg_code r)
| otherwise =
case aregs of
[] -> push_this_arg
(r:rs) -> do
arg_code <- getAnyReg arg
load_args rest rs fregs (code `appOL` arg_code r)
where
arg_rep = cmmExprType arg
push_this_arg = do
(args',ars,frs,code') <- load_args rest aregs fregs code
return ((CmmHinted arg hint):args', ars, frs, code')
push_args [] code = return code
push_args ((CmmHinted arg hint):rest) code
| isFloatType arg_rep = do
(arg_reg, arg_code) <- getSomeReg arg
delta <- getDeltaNat
setDeltaNat (deltaarg_size)
let code' = code `appOL` arg_code `appOL` toOL [
SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) ,
DELTA (deltaarg_size),
MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel 0))]
push_args rest code'
| otherwise = do
ASSERT(width == W64) return ()
(arg_op, arg_code) <- getOperand arg
delta <- getDeltaNat
setDeltaNat (deltaarg_size)
let code' = code `appOL` arg_code `appOL` toOL [
PUSH II64 arg_op,
DELTA (deltaarg_size)]
push_args rest code'
where
arg_rep = cmmExprType arg
width = typeWidth arg_rep
#else
genCCall = panic "X86.genCCAll: not defined"
#endif /* x86_64_TARGET_ARCH */
outOfLineFloatOp :: CallishMachOp -> CmmFormal -> HintedCmmActuals -> NatM InstrBlock
outOfLineFloatOp mop res args
= do
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)
else do
uq <- getUniqueNat
let
tmp = LocalReg uq f64
code1 <- stmtToInstrs (CmmCall target [CmmHinted tmp NoHint] args CmmUnsafe CmmMayReturn)
code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
return (code1 `appOL` code2)
where
lbl = mkForeignLabel fn Nothing False IsFunction
fn = case mop of
MO_F32_Sqrt -> fsLit "sqrtf"
MO_F32_Sin -> fsLit "sinf"
MO_F32_Cos -> fsLit "cosf"
MO_F32_Tan -> fsLit "tanf"
MO_F32_Exp -> fsLit "expf"
MO_F32_Log -> fsLit "logf"
MO_F32_Asin -> fsLit "asinf"
MO_F32_Acos -> fsLit "acosf"
MO_F32_Atan -> fsLit "atanf"
MO_F32_Sinh -> fsLit "sinhf"
MO_F32_Cosh -> fsLit "coshf"
MO_F32_Tanh -> fsLit "tanhf"
MO_F32_Pwr -> fsLit "powf"
MO_F64_Sqrt -> fsLit "sqrt"
MO_F64_Sin -> fsLit "sin"
MO_F64_Cos -> fsLit "cos"
MO_F64_Tan -> fsLit "tan"
MO_F64_Exp -> fsLit "exp"
MO_F64_Log -> fsLit "log"
MO_F64_Asin -> fsLit "asin"
MO_F64_Acos -> fsLit "acos"
MO_F64_Atan -> fsLit "atan"
MO_F64_Sinh -> fsLit "sinh"
MO_F64_Cosh -> fsLit "cosh"
MO_F64_Tanh -> fsLit "tanh"
MO_F64_Pwr -> fsLit "pow"
genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock
genSwitch expr ids
| opt_PIC
= do
(reg,e_code) <- getSomeReg expr
lbl <- getNewLabelNat
dflags <- getDynFlagsNat
dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let
jumpTable = map jumpTableEntryRel ids
jumpTableEntryRel Nothing
= CmmStaticLit (CmmInt 0 wordWidth)
jumpTableEntryRel (Just (BlockId id))
= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
where blockLabel = mkAsmTempLabel id
op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg wORD_SIZE) (ImmInt 0))
#if x86_64_TARGET_ARCH
#if darwin_TARGET_OS
code = e_code `appOL` t_code `appOL` toOL [
ADD (intSize wordWidth) op (OpReg tableReg),
JMP_TBL (OpReg tableReg) [ id | Just id <- ids ],
LDATA Text (CmmDataLabel lbl : jumpTable)
]
#else
code = e_code `appOL` t_code `appOL` toOL [
LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
MOVSxL II32
(OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg wORD_SIZE) (ImmInt 0)))
(OpReg reg),
ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg),
JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
]
#endif
#else
code = e_code `appOL` t_code `appOL` toOL [
LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
ADD (intSize wordWidth) op (OpReg tableReg),
JMP_TBL (OpReg tableReg) [ id | Just id <- ids ]
]
#endif
return code
| otherwise
= do
(reg,e_code) <- getSomeReg expr
lbl <- getNewLabelNat
let
jumpTable = map jumpTableEntry ids
op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl))
code = e_code `appOL` toOL [
LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
JMP_TBL op [ id | Just id <- ids ]
]
return code
condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condIntReg cond x y = do
CondCode _ cond cond_code <- condIntCode cond x y
tmp <- getNewRegNat II8
let
code dst = cond_code `appOL` toOL [
SETCC cond (OpReg tmp),
MOVZxL II8 (OpReg tmp) (OpReg dst)
]
return (Any II32 code)
condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
#if i386_TARGET_ARCH
condFltReg cond x y = do
CondCode _ cond cond_code <- condFltCode cond x y
tmp <- getNewRegNat II8
let
code dst = cond_code `appOL` toOL [
SETCC cond (OpReg tmp),
MOVZxL II8 (OpReg tmp) (OpReg dst)
]
return (Any II32 code)
#elif x86_64_TARGET_ARCH
condFltReg cond x y = do
CondCode _ cond cond_code <- condFltCode cond x y
tmp1 <- getNewRegNat archWordSize
tmp2 <- getNewRegNat archWordSize
let
code dst =
cond_code `appOL`
(case cond of
NE -> or_unordered dst
GU -> plain_test dst
GEU -> plain_test dst
_ -> and_ordered dst)
plain_test dst = toOL [
SETCC cond (OpReg tmp1),
MOVZxL II8 (OpReg tmp1) (OpReg dst)
]
or_unordered dst = toOL [
SETCC cond (OpReg tmp1),
SETCC PARITY (OpReg tmp2),
OR II8 (OpReg tmp1) (OpReg tmp2),
MOVZxL II8 (OpReg tmp2) (OpReg dst)
]
and_ordered dst = toOL [
SETCC cond (OpReg tmp1),
SETCC NOTPARITY (OpReg tmp2),
AND II8 (OpReg tmp1) (OpReg tmp2),
MOVZxL II8 (OpReg tmp2) (OpReg dst)
]
return (Any II32 code)
#else
condFltReg = panic "X86.condFltReg: not defined"
#endif
trivialCode width instr (Just revinstr) (CmmLit lit_a) b
| is32BitLit lit_a = do
b_code <- getAnyReg b
let
code dst
= b_code dst `snocOL`
revinstr (OpImm (litToImm lit_a)) (OpReg dst)
return (Any (intSize width) code)
trivialCode width instr maybe_revinstr a b
= genTrivialCode (intSize width) instr a b
genTrivialCode rep instr a b = do
(b_op, b_code) <- getNonClobberedOperand b
a_code <- getAnyReg a
tmp <- getNewRegNat rep
let
code dst
| dst `regClashesWithOp` b_op =
b_code `appOL`
unitOL (MOV rep b_op (OpReg tmp)) `appOL`
a_code dst `snocOL`
instr (OpReg tmp) (OpReg dst)
| otherwise =
b_code `appOL`
a_code dst `snocOL`
instr b_op (OpReg dst)
return (Any rep code)
reg `regClashesWithOp` OpReg reg2 = reg == reg2
reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)
reg `regClashesWithOp` _ = False
trivialUCode rep instr x = do
x_code <- getAnyReg x
let
code dst =
x_code dst `snocOL`
instr (OpReg dst)
return (Any rep code)
#if i386_TARGET_ARCH
trivialFCode width instr x y = do
(x_reg, x_code) <- getNonClobberedReg x
(y_reg, y_code) <- getSomeReg y
let
size = floatSize width
code dst =
x_code `appOL`
y_code `snocOL`
instr size x_reg y_reg dst
return (Any size code)
#endif
#if x86_64_TARGET_ARCH
trivialFCode pk instr x y
= genTrivialCode size (instr size) x y
where size = floatSize pk
#endif
trivialUFCode size instr x = do
(x_reg, x_code) <- getSomeReg x
let
code dst =
x_code `snocOL`
instr x_reg dst
return (Any size code)
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
#if i386_TARGET_ARCH
coerceInt2FP from to x = do
(x_reg, x_code) <- getSomeReg x
let
opc = case to of W32 -> GITOF; W64 -> GITOD
code dst = x_code `snocOL` opc x_reg dst
return (Any (floatSize to) code)
#elif x86_64_TARGET_ARCH
coerceInt2FP from to x = do
(x_op, x_code) <- getOperand x
let
opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD
code dst = x_code `snocOL` opc x_op dst
return (Any (floatSize to) code)
#else
coerceInt2FP = panic "X86.coerceInt2FP: not defined"
#endif
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
#if i386_TARGET_ARCH
coerceFP2Int from to x = do
(x_reg, x_code) <- getSomeReg x
let
opc = case from of W32 -> GFTOI; W64 -> GDTOI
code dst = x_code `snocOL` opc x_reg dst
return (Any (intSize to) code)
#elif x86_64_TARGET_ARCH
coerceFP2Int from to x = do
(x_op, x_code) <- getOperand x
let
opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ
code dst = x_code `snocOL` opc x_op dst
return (Any (intSize to) code)
#else
coerceFP2Int = panic "X86.coerceFP2Int: not defined"
#endif
coerceFP2FP :: Width -> CmmExpr -> NatM Register
#if x86_64_TARGET_ARCH
coerceFP2FP to x = do
(x_reg, x_code) <- getSomeReg x
let
opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD
code dst = x_code `snocOL` opc x_reg dst
return (Any (floatSize to) code)
#else
coerceFP2FP = panic "X86.coerceFP2FP: not defined"
#endif