Major reworking of the x86 floating point code generation.
Intel, in their infinite wisdom, selected a stack model for floating
point registers on x86. That might have made sense back in 1979 --
nowadays we can see it for the nonsense it really is. A stack model
fits poorly with the existing nativeGen infrastructure, which assumes
flat integer and FP register sets. Prior to this commit, nativeGen
could not generate correct x86 FP code -- to do so would have meant
somehow working the register-stack paradigm into the register
allocator and spiller, which sounds very difficult.
We have decided to cheat, and go for a simple fix which requires no
infrastructure modifications, at the expense of generating ropey but
correct FP code. All notions of the x86 FP stack and its insns have
been removed. Instead, we pretend (to the instruction selector and
register allocator) that x86 has six floating point registers, %fake0
.. %fake5, which can be used in the usual flat manner. We further
claim that x86 has floating point instructions very similar to SPARC
and Alpha, that is, a simple 3-operand register-register arrangement.
Code generation and register allocation proceed on this basis.
When we come to print out the final assembly, our convenient fiction
is converted to dismal reality. Each fake instruction is
independently converted to a series of real x86 instructions.
%fake0 .. %fake5 are mapped to %st(0) .. %st(5). To do reg-reg
arithmetic operations, the two operands are pushed onto the top of the
FP stack, the operation done, and the result copied back into the
relevant register. There are only six %fake registers because 2 are
needed for the translation, and x86 has 8 in total.
The translation is inefficient but is simple and it works. A cleverer
translation would handle a sequence of insns, simulating the FP stack
contents, would not impose a fixed mapping from %fake to %st regs, and
hopefully could avoid most of the redundant reg-reg moves of the
current translation.
nativeCodeGen absC us
= let (stixRaw, us1) = initUs us (genCodeAbstractC absC)
stixOpt = map (map genericOpt) stixRaw
- stixFinal = map x86floatFix stixOpt
- insns = initUs_ us1 (codeGen stixFinal)
- debug_stix = vcat (map pprStixTrees stixFinal)
+ insns = initUs_ us1 (codeGen stixOpt)
+ debug_stix = vcat (map pprStixTrees stixOpt)
in
(debug_stix, insns)
-
-#if i386_TARGET_ARCH
-x86floatFix = floatFix
-#else
-x86floatFix = id
-#endif
-
\end{code}
@codeGen@ is the top-level code-generation function:
static_instrss = scheduleMachCode dynamic_codes
docs = map (vcat . map pprInstr) static_instrss
in
- returnUs (vcat (intersperse (char ' ' $$ char ' ') docs))
+ returnUs (vcat (intersperse (char ' '
+ $$ text "# ___stg_split_marker"
+ $$ char ' ')
+ docs))
\end{code}
Top level code generator for a chunk of stix code:
\begin{code}
primOpt op args = StPrim op args
\end{code}
-
------------------------------------------------------------------------------
-Fix up floating point operations for x86.
-
-The problem is that the code generator can't handle the weird register
-naming scheme for floating point registers on the x86, so we have to
-deal with memory-resident floating point values wherever possible.
-
-We therefore can't stand references to floating-point kinded temporary
-variables, and try to translate them into memory addresses wherever
-possible.
-
-\begin{code}
-floatFix :: [StixTree] -> [StixTree]
-floatFix trees = fltFix emptyUFM trees
-
-fltFix :: UniqFM StixTree -- mapping tmp vars to memory locations
- -> [StixTree]
- -> [StixTree]
-fltFix locs [] = []
-
--- The case we're interested in: loading a temporary from a memory
--- address. Eliminate the instruction and replace all future references
--- to the temporary with the memory address.
-fltFix locs ((StAssign rep (StReg (StixTemp uq _)) loc) : trees)
- | isFloatingRep rep = fltFix (addToUFM locs uq loc) trees
-
-fltFix locs ((StAssign rep src dst) : trees)
- = StAssign rep (fltFix1 locs src) (fltFix1 locs dst) : fltFix locs trees
-
-fltFix locs (tree : trees)
- = fltFix1 locs tree : fltFix locs trees
-
-
-fltFix1 :: UniqFM StixTree -> StixTree -> StixTree
-fltFix1 locs r@(StReg (StixTemp uq rep))
- | isFloatingRep rep = case lookupUFM locs uq of
- Nothing -> panic "fltFix1"
- Just tree -> tree
-
-fltFix1 locs (StIndex rep l r) =
- StIndex rep (fltFix1 locs l) (fltFix1 locs r)
-
-fltFix1 locs (StInd rep tree) =
- StInd rep (fltFix1 locs tree)
-
-fltFix1 locs (StAssign rep dst src) = panic "fltFix1: StAssign"
-
-fltFix1 locs (StJump tree) = StJump (fltFix1 locs tree)
-
-fltFix1 locs (StCondJump lbl tree) =
- StCondJump lbl (fltFix1 locs tree)
-
-fltFix1 locs (StPrim op trees) =
- StPrim op (map (fltFix1 locs) trees)
-
-fltFix1 locs (StCall f conv rep trees) =
- StCall f conv rep (map (fltFix1 locs) trees)
-
-fltFix1 locs tree = tree
-\end{code}
returnUs (Fixed kind reg call)
where
reg = if isFloatingRep kind
- then IF_ARCH_alpha( f0, IF_ARCH_i386( st0, IF_ARCH_sparc( f0,)))
+ then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0,)))
else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0,)))
getRegister (StString s)
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-getRegister (StDouble 0.0)
- = let
- code dst = mkSeqInstrs [FLDZ]
- in
- returnUs (Any DoubleRep code)
-
-getRegister (StDouble 1.0)
- = let
- code dst = mkSeqInstrs [FLD1]
- in
- returnUs (Any DoubleRep code)
-
getRegister (StDouble d)
= getUniqLabelNCG `thenUs` \ lbl ->
- --getNewRegNCG PtrRep `thenUs` \ tmp ->
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
DATA DF [ImmDouble d],
SEGMENT TextSegment,
- FLD DF (OpImm (ImmCLbl lbl))
+ GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
]
in
returnUs (Any DoubleRep code)
+
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (NEGI L) x
-
NotOp -> trivialUCode (NOT L) x
- FloatNegOp -> trivialUFCode FloatRep FCHS x
- FloatSqrtOp -> trivialUFCode FloatRep FSQRT x
- DoubleNegOp -> trivialUFCode DoubleRep FCHS x
+ FloatNegOp -> trivialUFCode FloatRep (GNEG F) x
+ DoubleNegOp -> trivialUFCode DoubleRep (GNEG DF) x
+
+ FloatSqrtOp -> trivialUFCode FloatRep (GSQRT F) x
+ DoubleSqrtOp -> trivialUFCode DoubleRep (GSQRT DF) x
- DoubleSqrtOp -> trivialUFCode DoubleRep FSQRT x
+ Double2FloatOp -> trivialUFCode FloatRep GDTOF x
+ Float2DoubleOp -> trivialUFCode DoubleRep GFTOD x
OrdOp -> coerceIntCode IntRep x
ChrOp -> chrCode x
Double2IntOp -> coerceFP2Int x
Int2DoubleOp -> coerceInt2FP DoubleRep x
- Double2FloatOp -> coerceFltCode x
- Float2DoubleOp -> coerceFltCode x
-
other_op ->
let
- fixed_x = if is_float_op -- promote to double
- then StPrim Float2DoubleOp [x]
- else x
+ fixed_x = if is_float_op -- promote to double
+ then StPrim Float2DoubleOp [x]
+ else x
in
getRegister (StCall fn cCallConv DoubleRep [x])
where
IntRemOp -> quot_code L x y False{-remainder-}
IntMulOp -> trivialCode (IMUL L) x y {-True-}
- FloatAddOp -> trivialFCode FloatRep FADD FADD FADDP FADDP x y
- FloatSubOp -> trivialFCode FloatRep FSUB FSUBR FSUBP FSUBRP x y
- FloatMulOp -> trivialFCode FloatRep FMUL FMUL FMULP FMULP x y
- FloatDivOp -> trivialFCode FloatRep FDIV FDIVR FDIVP FDIVRP x y
+ FloatAddOp -> trivialFCode FloatRep GADD x y
+ FloatSubOp -> trivialFCode FloatRep GSUB x y
+ FloatMulOp -> trivialFCode FloatRep GMUL x y
+ FloatDivOp -> trivialFCode FloatRep GDIV x y
- DoubleAddOp -> trivialFCode DoubleRep FADD FADD FADDP FADDP x y
- DoubleSubOp -> trivialFCode DoubleRep FSUB FSUBR FSUBP FSUBRP x y
- DoubleMulOp -> trivialFCode DoubleRep FMUL FMUL FMULP FMULP x y
- DoubleDivOp -> trivialFCode DoubleRep FDIV FDIVR FDIVP FDIVRP x y
+ DoubleAddOp -> trivialFCode DoubleRep GADD x y
+ DoubleSubOp -> trivialFCode DoubleRep GSUB x y
+ DoubleMulOp -> trivialFCode DoubleRep GMUL x y
+ DoubleDivOp -> trivialFCode DoubleRep GDIV x y
AndOp -> trivialCode (AND L) x y {-True-}
OrOp -> trivialCode (OR L) x y {-True-}
SllOp -> shift_code (SHL L) x y {-False-}
SrlOp -> shift_code (SHR L) x y {-False-}
- ISllOp -> shift_code (SHL L) x y {-False-} --was:panic "I386Gen:isll"
- ISraOp -> shift_code (SAR L) x y {-False-} --was:panic "I386Gen:isra"
- ISrlOp -> shift_code (SHR L) x y {-False-} --was:panic "I386Gen:isrl"
+ ISllOp -> shift_code (SHL L) x y {-False-}
+ ISraOp -> shift_code (SAR L) x y {-False-}
+ ISrlOp -> shift_code (SHR L) x y {-False-}
- FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
+ FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ [promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ [x, y])
where
+
+ --------------------
shift_code :: (Operand -> Operand -> Instr)
-> StixTree
-> StixTree
-> UniqSM Register
+
{- Case1: shift length as immediate -}
-- Code is the same as the first eq. for trivialCode -- sigh.
shift_code instr x y{-amount-}
shift_code instr x y{-amount-}
= getRegister y `thenUs` \ register1 ->
getRegister x `thenUs` \ register2 ->
--- getNewRegNCG IntRep `thenUs` \ dst ->
let
-- Note: we force the shift length to be loaded
-- into ECX, so that we can use CL when shifting.
in
returnUs (Fixed IntRep eax code__2)
+ --------------------
add_code :: Size -> StixTree -> StixTree -> UniqSM Register
add_code sz x (StInt y)
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (fromInteger y)
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
- in
- returnUs (Any IntRep code__2)
-{-
- add_code sz x (StInd _ mem)
- = getRegister x `thenUs` \ register1 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
- getAmode mem `thenUs` \ amode ->
- let
- code2 = amodeCode amode
- src2 = amodeAddr amode
-
- code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in asmParThen [code2 asmVoid,code1 asmVoid] .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- ADD sz (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src2) (OpReg src1)]
+ code__2 dst
+ = code .
+ mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+ (OpReg dst))
in
returnUs (Any IntRep code__2)
- add_code sz (StInd _ mem) y
- = getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
- getAmode mem `thenUs` \ amode ->
- let
- code1 = amodeCode amode
- src1 = amodeAddr amode
-
- code__2 dst = let code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
- if isFixed register2 && src2 /= dst
- then mkSeqInstrs [MOV L (OpReg src2) (OpReg dst),
- ADD sz (OpAddr src1) (OpReg dst)]
- else
- mkSeqInstrs [ADD sz (OpAddr src1) (OpReg src2)]
- in
- returnUs (Any IntRep code__2)
--}
add_code sz x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
src1 = registerName register1 tmp1
code2 = registerCode register2 tmp2 asmVoid
src2 = registerName register2 tmp2
- code__2 dst = asmParThen [code1, code2] .
- mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1)) (ImmInt 0))) (OpReg dst))
+ code__2 dst
+ = asmParThen [code1, code2] .
+ mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) (Just (src2,1))
+ (ImmInt 0)))
+ (OpReg dst))
in
returnUs (Any IntRep code__2)
code = registerCode register tmp
src1 = registerName register tmp
src2 = ImmInt (-(fromInteger y))
- code__2 dst = code .
- mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2)) (OpReg dst))
+ code__2 dst
+ = code .
+ mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+ (OpReg dst))
in
returnUs (Any IntRep code__2)
src2 = ImmInt (fromInteger i)
code__2 = asmParThen [code1] .
mkSeqInstrs [-- we put src2 in (ebx)
- MOV L (OpImm src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ MOV L (OpImm src2)
+ (OpAddr (AddrBaseIndex (Just ebx) Nothing
+ (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing
+ (ImmInt OFFSET_R1)))
+ ]
in
returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
src2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2] .
if src2 == ecx || src2 == esi
- then mkSeqInstrs [ MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpReg src2)]
+ then mkSeqInstrs [
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpReg src2)
+ ]
else mkSeqInstrs [ -- we put src2 in (ebx)
- MOV L (OpReg src2) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
- MOV L (OpReg src1) (OpReg eax),
- CLTD,
- IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)))]
+ MOV L (OpReg src2)
+ (OpAddr (AddrBaseIndex (Just ebx) Nothing
+ (ImmInt OFFSET_R1))),
+ MOV L (OpReg src1) (OpReg eax),
+ CLTD,
+ IDIV sz (OpAddr (AddrBaseIndex (Just ebx) Nothing
+ (ImmInt OFFSET_R1)))
+ ]
in
returnUs (Fixed IntRep (if is_division then eax else edx) code__2)
-----------------------
= getAmode mem `thenUs` \ amode ->
let
code = amodeCode amode
- src = amodeAddr amode
+ src = amodeAddr amode
size = primRepToSize pk
code__2 dst = code .
if pk == DoubleRep || pk == FloatRep
- then mkSeqInstr (FLD {-DF-} size (OpAddr src))
+ then mkSeqInstr (GLD size src dst)
else mkSeqInstr (MOV size (OpAddr src) (OpReg dst))
in
returnUs (Any pk code__2)
-
getRegister (StInt i)
= let
src = ImmInt (fromInteger i)
returnUs (CondCode False cond code__2)
-----------
-
-condFltCode cond x (StDouble 0.0)
- = getRegister x `thenUs` \ register1 ->
- getNewRegNCG (registerRep register1)
- `thenUs` \ tmp1 ->
- let
- pk1 = registerRep register1
- code1 = registerCode register1 tmp1
- src1 = registerName register1 tmp1
-
- code__2 = asmParThen [code1 asmVoid] .
- mkSeqInstrs [FTST, FSTP DF (OpReg st0), -- or FLDZ, FUCOMPP ?
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
- in
- returnUs (CondCode True (fix_FP_cond cond) code__2)
-
condFltCode cond x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
`thenUs` \ tmp1 ->
getNewRegNCG (registerRep register2)
`thenUs` \ tmp2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
pk1 = registerRep register1
code1 = registerCode register1 tmp1
src1 = registerName register1 tmp1
+ pk2 = registerRep register2
code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
- code__2 = asmParThen [code2 asmVoid, code1 asmVoid] .
- mkSeqInstrs [FUCOMPP,
- FNSTSW,
- --AND HB (OpImm (ImmInt 68)) (OpReg eax),
- --XOR HB (OpImm (ImmInt 64)) (OpReg eax)
- SAHF
- ]
+ code__2 = asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr (GCMP (primRepToSize pk1) src1 src2)
+
+ {- On the 486, the flags set by FP compare are the unsigned ones!
+ (This looks like a HACK to me. WDP 96/03)
+ -}
+ fix_FP_cond :: Cond -> Cond
+
+ fix_FP_cond GE = GEU
+ fix_FP_cond GTT = GU
+ fix_FP_cond LTT = LU
+ fix_FP_cond LE = LEU
+ fix_FP_cond any = any
in
returnUs (CondCode True (fix_FP_cond cond) code__2)
-{- On the 486, the flags set by FP compare are the unsigned ones!
- (This looks like a HACK to me. WDP 96/03)
--}
-
-fix_FP_cond :: Cond -> Cond
-fix_FP_cond GE = GEU
-fix_FP_cond GTT = GU
-fix_FP_cond LTT = LU
-fix_FP_cond LE = LEU
-fix_FP_cond any = any
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
= getNewRegNCG IntRep `thenUs` \ tmp ->
getAmode src `thenUs` \ amodesrc ->
getAmode dst `thenUs` \ amodedst ->
- --getRegister src `thenUs` \ register ->
let
codesrc1 = amodeCode amodesrc asmVoid
addrsrc1 = amodeAddr amodesrc
returnUs code__2
assignFltCode pk (StInd _ dst) src
- = --getNewRegNCG pk `thenUs` \ tmp ->
+ = getNewRegNCG pk `thenUs` \ tmp ->
getAmode dst `thenUs` \ amode ->
- getRegister src `thenUs` \ register ->
+ getRegister src `thenUs` \ register ->
let
sz = primRepToSize pk
dst__2 = amodeAddr amode
code1 = amodeCode amode asmVoid
- code2 = registerCode register {-tmp-}st0 asmVoid
+ code2 = registerCode register tmp asmVoid
- --src__2= registerName register tmp
- pk__2 = registerRep register
- sz__2 = primRepToSize pk__2
+ src__2 = registerName register tmp
code__2 = asmParThen [code1, code2] .
- mkSeqInstr (FSTP sz (OpAddr dst__2))
+ mkSeqInstr (GST sz src__2 dst__2)
in
returnUs code__2
assignFltCode pk dst src
= getRegister dst `thenUs` \ register1 ->
getRegister src `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp ->
+ getNewRegNCG pk `thenUs` \ tmp ->
let
- sz = primRepToSize pk
- dst__2 = registerName register1 st0 --tmp
-
- code = registerCode register2 dst__2
+ -- the register which is dst
+ dst__2 = registerName register1 tmp
+ -- the register into which src is computed, preferably dst__2
src__2 = registerName register2 dst__2
+ -- code to compute src into src__2
+ code = registerCode register2 dst__2
- code__2 = code
+ code__2 = if isFixed register2
+ then code . mkSeqInstr (GMOV src__2 dst__2)
+ else code
in
returnUs code__2
get_call_arg arg
= get_op arg `thenUs` \ (code, op, sz) ->
case sz of
- DF -> returnUs (sz,
+ DF -> --getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ returnUs (sz,
code .
- mkSeqInstr (FLD L op) .
+ --mkSeqInstr (GLD DF op tmp) .
mkSeqInstr (SUB L (OpImm (ImmInt 8)) (OpReg esp)) .
- mkSeqInstr (FSTP DF (OpAddr (AddrBaseIndex
+ mkSeqInstr (GST DF {-tmp-}op (AddrBaseIndex
(Just esp)
- Nothing (ImmInt 0))))
+ Nothing (ImmInt 0)))
)
_ -> returnUs (sz,
- code . mkSeqInstr (PUSH sz op))
+ code . mkSeqInstr (PUSH sz (OpReg op)))
------------
get_op
:: StixTree
- -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
-
+ -> UniqSM (InstrBlock, {-Operand-}Reg, Size) -- code, operator, size
+{-
get_op (StInt i)
= returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
sz = primRepToSize pk
in
returnUs (code, OpAddr addr, sz)
-
+-}
get_op op
= getRegister op `thenUs` \ register ->
getNewRegNCG (registerRep register)
pk = registerRep register
sz = primRepToSize pk
in
- returnUs (code, OpReg reg, sz)
+ returnUs (code, {-OpReg-} reg, sz)
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
:: PrimRep
-> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
- ,IF_ARCH_i386 (
- {-this bizarre type for i386 seems a little too weird (WDP 96/03)-}
- (Size -> Operand -> Instr)
- -> (Size -> Operand -> Instr) {-reversed instr-}
- -> Instr {-pop-}
- -> Instr {-reversed instr: pop-}
+ ,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
,)))
-> StixTree -> StixTree -- the two arguments
-> UniqSM Register
trivialUFCode
:: PrimRep
-> IF_ARCH_alpha((Reg -> Reg -> Instr)
- ,IF_ARCH_i386 (Instr
+ ,IF_ARCH_i386 ((Reg -> Reg -> Instr)
,IF_ARCH_sparc((Reg -> Reg -> Instr)
,)))
-> StixTree -- the one argument
trivialCode instr x y
| maybeToBool imm
= getRegister x `thenUs` \ register1 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
trivialCode instr x y
| maybeToBool imm
= getRegister y `thenUs` \ register1 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
let
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
where
imm = maybeImm x
imm__2 = case imm of Just x -> x
-{-
-trivialCode instr x (StInd pk mem)
- = getRegister x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode mem `thenUs` \ amode ->
- let
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 dst = let code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
- in
- returnUs (Any pk code__2)
-trivialCode instr (StInd pk mem) y
- = getRegister y `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ tmp ->
- getAmode mem `thenUs` \ amode ->
- let
- code2 = amodeCode amode asmVoid
- src2 = amodeAddr amode
- code__2 dst = let
- code1 = registerCode register dst asmVoid
- src1 = registerName register dst
- in asmParThen [code1, code2] .
- if isFixed register && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpAddr src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpAddr src2) (OpReg src1))
- in
- returnUs (Any pk code__2)
--}
trivialCode instr x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
getNewRegNCG IntRep `thenUs` \ tmp2 ->
let
code2 = registerCode register2 tmp2 asmVoid
-----------
trivialUCode instr x
= getRegister x `thenUs` \ register ->
--- getNewRegNCG IntRep `thenUs` \ tmp ->
let
code__2 dst = let
code = registerCode register dst
returnUs (Any IntRep code__2)
-----------
+{-
trivialFCode pk _ instrr _ _ (StInd pk' mem) y
= getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
getAmode mem `thenUs` \ amode ->
let
code1 = amodeCode amode
trivialFCode pk instr _ _ _ x (StInd pk' mem)
= getRegister x `thenUs` \ register1 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
getAmode mem `thenUs` \ amode ->
let
code2 = amodeCode amode
trivialFCode pk _ _ _ instrpr x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
getNewRegNCG DoubleRep `thenUs` \ tmp ->
let
pk1 = registerRep register1
mkSeqInstr instrpr
in
returnUs (Any pk1 code__2)
+-}
+
+trivialFCode pk instr x y
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+
+ code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
+ in
+ returnUs (Any DoubleRep code__2)
+
-------------
+trivialUFCode pk instr x
+ = getRegister x `thenUs` \ register ->
+ getNewRegNCG pk `thenUs` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (instr src dst)
+ in
+ returnUs (Any pk code__2)
+
+{-
trivialUFCode pk instr (StInd pk' mem)
= getAmode mem `thenUs` \ amode ->
let
trivialUFCode pk instr x
= getRegister x `thenUs` \ register ->
- --getNewRegNCG pk `thenUs` \ tmp ->
let
code__2 dst = let
code = registerCode register dst
in code . mkSeqInstrs [instr]
in
returnUs (Any pk code__2)
-
+-}
#endif {- i386_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if sparc_TARGET_ARCH
let
code = registerCode register reg
src = registerName register reg
-
- code__2 dst = code . mkSeqInstrs [
- -- to fix: should spill instead of using R1
- MOV L (OpReg src) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))),
- FILD (primRepToSize pk) (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)) dst]
+ opc = case pk of FloatRep -> GITOF ; DoubleRep -> GITOD
+ code__2 dst = code .
+ mkSeqInstr (opc src dst)
in
returnUs (Any pk code__2)
src = registerName register tmp
pk = registerRep register
- code__2 dst = code . mkSeqInstrs [
- FRNDINT,
- FIST L (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1)),
- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt OFFSET_R1))) (OpReg dst)]
+ opc = case pk of FloatRep -> GFTOI ; DoubleRep -> GDTOI
+ code__2 dst = code .
+ mkSeqInstr (opc src dst)
in
returnUs (Any IntRep code__2)
-- Float Arithmetic. -- ToDo for 386
--- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single instructions
+-- Note that we cheat by treating G{ABS,MOV,NEG} of doubles as single instructions
-- right up until we spit them out.
- | SAHF -- stores ah into flags
- | FABS
- | FADD Size Operand -- src
- | FADDP
- | FIADD Size MachRegsAddr -- src
- | FCHS
- | FCOM Size Operand -- src
- | FCOS
- | FDIV Size Operand -- src
- | FDIVP
- | FIDIV Size MachRegsAddr -- src
- | FDIVR Size Operand -- src
- | FDIVRP
- | FIDIVR Size MachRegsAddr -- src
- | FICOM Size MachRegsAddr -- src
- | FILD Size MachRegsAddr Reg -- src, dst
- | FIST Size MachRegsAddr -- dst
- | FLD Size Operand -- src
- | FLD1
- | FLDZ
- | FMUL Size Operand -- src
- | FMULP
- | FIMUL Size MachRegsAddr -- src
- | FRNDINT
- | FSIN
- | FSQRT
- | FST Size Operand -- dst
- | FSTP Size Operand -- dst
- | FSUB Size Operand -- src
- | FSUBP
- | FISUB Size MachRegsAddr -- src
- | FSUBR Size Operand -- src
- | FSUBRP
- | FISUBR Size MachRegsAddr -- src
- | FTST
- | FCOMP Size Operand -- src
- | FUCOMPP
- | FXCH
- | FNSTSW
- | FNOP
+ -- all the 3-operand fake fp insns are src1 src2 dst
+ -- and furthermore are constrained to be fp regs only.
+ | GMOV Reg Reg -- src(fpreg), dst(fpreg)
+ | GLD Size MachRegsAddr Reg -- src, dst(fpreg)
+ | GST Size Reg MachRegsAddr -- src(fpreg), dst
+
+ | GFTOD Reg Reg -- src(fpreg), dst(fpreg)
+ | GFTOI Reg Reg -- src(fpreg), dst(intreg)
+
+ | GDTOF Reg Reg -- src(fpreg), dst(fpreg)
+ | GDTOI Reg Reg -- src(fpreg), dst(intreg)
+
+ | GITOF Reg Reg -- src(intreg), dst(fpreg)
+ | GITOD Reg Reg -- src(intreg), dst(fpreg)
+
+ | GADD Size Reg Reg Reg -- src1, src2, dst
+ | GDIV Size Reg Reg Reg -- src1, src2, dst
+ | GSUB Size Reg Reg Reg -- src1, src2, dst
+ | GMUL Size Reg Reg Reg -- src1, src2, dst
+
+ | GCMP Size Reg Reg -- src1, src2
+
+ | GABS Size Reg Reg -- src, dst
+ | GNEG Size Reg Reg -- src, dst
+ | GSQRT Size Reg Reg -- src, dst
-- Comparison
#endif
#if i386_TARGET_ARCH
, eax, ebx, ecx, edx, esi, esp
- , st0, st1, st2, st3, st4, st5, st6, st7
+ , fake0, fake1, fake2, fake3, fake4, fake5
#endif
#if sparc_TARGET_ARCH
, allArgRegs
- Only ebx, esi, edi and esp are available across a C call (they are callee-saves).
- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
-- Registers 8-15 hold extended floating point values.
+- Registers 8-13 are fakes; we pretend x86 has 6 conventionally-addressable
+ fp registers, and 3-operand insns for them, and we translate this into
+ real stack-based x86 fp code after register allocation.
+
\begin{code}
#if i386_TARGET_ARCH
gReg x = x
fReg x = (8 + x)
-st0, st1, st2, st3, st4, st5, st6, st7, eax, ebx, ecx, edx, esp :: Reg
+fake0, fake1, fake2, fake3, fake4, fake5, eax, ebx, ecx, edx, esp :: Reg
eax = realReg (gReg 0)
ebx = realReg (gReg 1)
ecx = realReg (gReg 2)
edi = realReg (gReg 5)
ebp = realReg (gReg 6)
esp = realReg (gReg 7)
-st0 = realReg (fReg 0)
-st1 = realReg (fReg 1)
-st2 = realReg (fReg 2)
-st3 = realReg (fReg 3)
-st4 = realReg (fReg 4)
-st5 = realReg (fReg 5)
-st6 = realReg (fReg 6)
-st7 = realReg (fReg 7)
-
+fake0 = realReg (fReg 0)
+fake1 = realReg (fReg 1)
+fake2 = realReg (fReg 2)
+fake3 = realReg (fReg 3)
+fake4 = realReg (fReg 4)
+fake5 = realReg (fReg 5)
#endif
\end{code}
#define edi 5
#define ebp 6
#define esp 7
-#define st0 8
-#define st1 9
-#define st2 10
-#define st3 11
-#define st4 12
-#define st5 13
-#define st6 14
-#define st7 15
+#define fake0 8
+#define fake1 9
+#define fake2 10
+#define fake3 11
+#define fake4 12
+#define fake5 13
#endif
#if sparc_TARGET_ARCH
#define g0 0
freeRegs :: [Reg]
freeRegs
= freeMappedRegs IF_ARCH_alpha( [0..63],
- IF_ARCH_i386( [0..15],
+ IF_ARCH_i386( [0..13],
IF_ARCH_sparc( [0..63],)))
-------------------------------
_ -> SLIT("very naughty I386 byte register")
})
- {- UNUSED:
+{- UNUSED:
ppr_reg_no HB i = ptext
(case i of {
ILIT( 0) -> SLIT("%ah"); ILIT( 1) -> SLIT("%bh");
ILIT( 2) -> SLIT("%ch"); ILIT( 3) -> SLIT("%dh");
_ -> SLIT("very naughty I386 high byte register")
})
- -}
+-}
{- UNUSED:
ppr_reg_no S i = ptext
ppr_reg_no F i = ptext
(case i of {
- --ToDo: rm these (???)
- ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
- ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
- ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
- ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
+ ILIT( 8) -> SLIT("%fake0"); ILIT( 9) -> SLIT("%fake1");
+ ILIT(10) -> SLIT("%fake2"); ILIT(11) -> SLIT("%fake3");
+ ILIT(12) -> SLIT("%fake4"); ILIT(13) -> SLIT("%fake5");
_ -> SLIT("very naughty I386 float register")
})
ppr_reg_no DF i = ptext
(case i of {
- --ToDo: rm these (???)
- ILIT( 8) -> SLIT("%st(0)"); ILIT( 9) -> SLIT("%st(1)");
- ILIT(10) -> SLIT("%st(2)"); ILIT(11) -> SLIT("%st(3)");
- ILIT(12) -> SLIT("%st(4)"); ILIT(13) -> SLIT("%st(5)");
- ILIT(14) -> SLIT("%st(6)"); ILIT(15) -> SLIT("%st(7)");
+ ILIT( 8) -> SLIT("%fake0"); ILIT( 9) -> SLIT("%fake1");
+ ILIT(10) -> SLIT("%fake2"); ILIT(11) -> SLIT("%fake3");
+ ILIT(12) -> SLIT("%fake4"); ILIT(13) -> SLIT("%fake5");
_ -> SLIT("very naughty I386 float register")
})
#endif
= ptext
IF_ARCH_alpha(SLIT("\t.text\n\t.align 3") {-word boundary-}
,IF_ARCH_sparc(SLIT("\t.text\n\t.align 4") {-word boundary-}
- ,IF_ARCH_i386(SLIT(".text\n\t.align 4") {-needs per-OS variation!-}
+ ,IF_ARCH_i386(SLIT(".text\n\t.align 4,0x90") {-needs per-OS variation!-}
,)))
pprInstr (SEGMENT DataSegment)
pprInstr (JMP op) = (<>) (ptext SLIT("\tjmp *")) (pprOperand L op)
pprInstr (CALL imm)
- = hcat [ ptext SLIT("\tcall "), pprImm imm ]
-
-pprInstr SAHF = ptext SLIT("\tsahf")
-pprInstr FABS = ptext SLIT("\tfabs")
-
-pprInstr (FADD sz src@(OpAddr _))
- = hcat [ptext SLIT("\tfadd"), pprSize sz, space, pprOperand sz src]
-pprInstr (FADD sz src)
- = ptext SLIT("\tfadd")
-pprInstr FADDP
- = ptext SLIT("\tfaddp")
-pprInstr (FMUL sz src)
- = hcat [ptext SLIT("\tfmul"), pprSize sz, space, pprOperand sz src]
-pprInstr FMULP
- = ptext SLIT("\tfmulp")
-pprInstr (FIADD size op) = pprSizeAddr SLIT("fiadd") size op
-pprInstr FCHS = ptext SLIT("\tfchs")
-pprInstr (FCOM size op) = pprSizeOp SLIT("fcom") size op
-pprInstr FCOS = ptext SLIT("\tfcos")
-pprInstr (FIDIV size op) = pprSizeAddr SLIT("fidiv") size op
-pprInstr (FDIV sz src)
- = hcat [ptext SLIT("\tfdiv"), pprSize sz, space, pprOperand sz src]
-pprInstr FDIVP
- = ptext SLIT("\tfdivp")
-pprInstr (FDIVR sz src)
- = hcat [ptext SLIT("\tfdivr"), pprSize sz, space, pprOperand sz src]
-pprInstr FDIVRP
- = ptext SLIT("\tfdivpr")
-pprInstr (FIDIVR size op) = pprSizeAddr SLIT("fidivr") size op
-pprInstr (FICOM size op) = pprSizeAddr SLIT("ficom") size op
-pprInstr (FILD sz op reg) = pprSizeAddrReg SLIT("fild") sz op reg
-pprInstr (FIST size op) = pprSizeAddr SLIT("fist") size op
-pprInstr (FLD sz (OpImm (ImmCLbl src)))
- = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprCLabel_asm src]
-pprInstr (FLD sz src)
- = hcat [ptext SLIT("\tfld"),pprSize sz,space,pprOperand sz src]
-pprInstr FLD1 = ptext SLIT("\tfld1")
-pprInstr FLDZ = ptext SLIT("\tfldz")
-pprInstr (FIMUL size op) = pprSizeAddr SLIT("fimul") size op
-pprInstr FRNDINT = ptext SLIT("\tfrndint")
-pprInstr FSIN = ptext SLIT("\tfsin")
-pprInstr FSQRT = ptext SLIT("\tfsqrt")
-pprInstr (FST sz dst)
- = hcat [ptext SLIT("\tfst"), pprSize sz, space, pprOperand sz dst]
-pprInstr (FSTP sz dst)
- = hcat [ptext SLIT("\tfstp"), pprSize sz, space, pprOperand sz dst]
-pprInstr (FISUB size op) = pprSizeAddr SLIT("fisub") size op
-pprInstr (FSUB sz src)
- = hcat [ptext SLIT("\tfsub"), pprSize sz, space, pprOperand sz src]
-pprInstr FSUBP
- = ptext SLIT("\tfsubp")
-pprInstr (FSUBR size src)
- = pprSizeOp SLIT("fsubr") size src
-pprInstr FSUBRP
- = ptext SLIT("\tfsubpr")
-pprInstr (FISUBR size op)
- = pprSizeAddr SLIT("fisubr") size op
-pprInstr FTST = ptext SLIT("\tftst")
-pprInstr (FCOMP sz op)
- = hcat [ptext SLIT("\tfcomp"), pprSize sz, space, pprOperand sz op]
-pprInstr FUCOMPP = ptext SLIT("\tfucompp")
-pprInstr FXCH = ptext SLIT("\tfxch")
-pprInstr FNSTSW = ptext SLIT("\tfnstsw %ax")
-pprInstr FNOP = ptext SLIT("")
+ = hcat [ ptext SLIT("\tffree %st(0) ; call "), pprImm imm ]
+
+
+-- Simulating a flat register set on the x86 FP stack is tricky.
+-- you have to free %st(7) before pushing anything on the FP reg stack
+-- so as to preclude the possibility of a FP stack overflow exception.
+-- ToDo: make gpop into a single instruction, FST
+pprInstr g@(GMOV src dst)
+ = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
+
+-- GLD sz addr dst ==> FFREE %st(7) ; FLDsz addr ; FXCH (dst+1) ; FINCSTP
+pprInstr g@(GLD sz addr dst)
+ = pprG g (hcat [gtab, text "ffree %st(7) ; fld", pprSize sz, gsp,
+ pprAddr addr, gsemi, gpop dst 1])
+
+-- GST sz src addr ==> FFREE %st(7) ; FLD dst ; FSTPsz addr
+pprInstr g@(GST sz src addr)
+ = pprG g (hcat [gtab, gpush src 0, gsemi,
+ text "fstp", pprSize sz, gsp, pprAddr addr])
+
+pprInstr g@(GFTOD src dst)
+ = pprG g bogus
+pprInstr g@(GFTOI src dst)
+ = pprG g bogus
+
+pprInstr g@(GDTOF src dst)
+ = pprG g bogus
+pprInstr g@(GDTOI src dst)
+ = pprG g bogus
+
+pprInstr g@(GITOF src dst)
+ = pprG g bogus
+pprInstr g@(GITOD src dst)
+ = pprG g bogus
+
+pprInstr g@(GCMP sz src1 src2)
+ = pprG g (hcat [gtab, text "pushl %eax ; ",
+ gpush src2 0, gsemi, gpush src1 1]
+ $$
+ hcat [gtab, text "fcompp ; fstsw %ax ; sahf ; popl %eax"])
+
+pprInstr g@(GABS sz src dst)
+ = pprG g bogus
+pprInstr g@(GNEG sz src dst)
+ = pprG g bogus
+pprInstr g@(GSQRT sz src dst)
+ = pprG g bogus
+
+pprInstr g@(GADD sz src1 src2 dst)
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fadd ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+pprInstr g@(GSUB sz src1 src2 dst)
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fsub ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+pprInstr g@(GMUL sz src1 src2 dst)
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fmul ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+pprInstr g@(GDIV sz src1 src2 dst)
+ = pprG g (hcat [gtab, gpush src1 0,
+ text " ; fdiv ", greg src2 1, text ",%st(0)",
+ gsemi, gpop dst 1])
+
+--------------------------
+gpush reg offset
+ = hcat [text "ffree %st(7) ; fld ", greg reg offset]
+gpop reg offset
+ = hcat [text "fxch ", greg reg offset, gsemi, text "fincstp"]
+
+bogus = text "\tbogus"
+greg reg offset = text "%st(" <> int (gregno reg - 8+offset) <> char ')'
+gsemi = text " ; "
+gtab = char '\t'
+gsp = char ' '
+gregno (FixedReg i) = I# i
+gregno (MappedReg i) = I# i
+
+pprG :: Instr -> SDoc -> SDoc
+pprG fake actual
+ = (char '#' <> pprGInstr fake) $$ actual
+
+pprGInstr (GMOV src dst) = pprSizeRegReg SLIT("gmov") DF src dst
+pprGInstr (GLD sz src dst) = pprSizeAddrReg SLIT("gld") sz src dst
+pprGInstr (GST sz src dst) = pprSizeRegAddr SLIT("gst") sz src dst
+
+pprGInstr (GFTOD src dst) = pprSizeSizeRegReg SLIT("gftod") F DF src dst
+pprGInstr (GFTOI src dst) = pprSizeSizeRegReg SLIT("gftoi") F L src dst
+
+pprGInstr (GDTOF src dst) = pprSizeSizeRegReg SLIT("gdtof") DF F src dst
+pprGInstr (GDTOI src dst) = pprSizeSizeRegReg SLIT("gdtoi") DF L src dst
+
+pprGInstr (GITOF src dst) = pprSizeSizeRegReg SLIT("gitof") L F src dst
+pprGInstr (GITOD src dst) = pprSizeSizeRegReg SLIT("gitod") L DF src dst
+
+pprGInstr (GCMP sz src dst) = pprSizeRegReg SLIT("gcmp") sz src dst
+pprGInstr (GABS sz src dst) = pprSizeRegReg SLIT("gabs") sz src dst
+pprGInstr (GNEG sz src dst) = pprSizeRegReg SLIT("gneg") sz src dst
+pprGInstr (GSQRT sz src dst) = pprSizeRegReg SLIT("gsqrt") sz src dst
+
+pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg SLIT("gadd") sz src1 src2 dst
+pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg SLIT("gsub") sz src1 src2 dst
+pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg SLIT("gmul") sz src1 src2 dst
+pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg SLIT("gdiv") sz src1 src2 dst
\end{code}
Continue with I386-only printing bits and bobs:
pprReg size reg
]
+pprSizeRegReg :: FAST_STRING -> Size -> Reg -> Reg -> SDoc
+pprSizeRegReg name size reg1 reg2
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size,
+ space,
+ pprReg size reg1,
+ comma,
+ pprReg size reg2
+ ]
+
+pprSizeSizeRegReg :: FAST_STRING -> Size -> Size -> Reg -> Reg -> SDoc
+pprSizeSizeRegReg name size1 size2 reg1 reg2
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size1,
+ pprSize size2,
+ space,
+ pprReg size1 reg1,
+ comma,
+ pprReg size2 reg2
+ ]
+
+pprSizeRegRegReg :: FAST_STRING -> Size -> Reg -> Reg -> Reg -> SDoc
+pprSizeRegRegReg name size reg1 reg2 reg3
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size,
+ space,
+ pprReg size reg1,
+ comma,
+ pprReg size reg2,
+ comma,
+ pprReg size reg3
+ ]
+
pprSizeAddr :: FAST_STRING -> Size -> MachRegsAddr -> SDoc
pprSizeAddr name size op
= hcat [
pprReg size dst
]
+pprSizeRegAddr :: FAST_STRING -> Size -> Reg -> MachRegsAddr -> SDoc
+pprSizeRegAddr name size src op
+ = hcat [
+ char '\t',
+ ptext name,
+ pprSize size,
+ space,
+ pprReg size src,
+ comma,
+ pprAddr op
+ ]
+
pprOpOp :: FAST_STRING -> Size -> Operand -> Operand -> SDoc
pprOpOp name size op1 op2
= hcat [
import PrimRep ( PrimRep(..) )
import UniqSet -- quite a bit of it
import Outputable
+import PprMach ( pprInstr )
\end{code}
%************************************************************************
CALL imm -> usage [] callClobberedRegs
CLTD -> usage [eax] [edx]
NOP -> usage [] []
- SAHF -> usage [eax] []
- FABS -> usage [st0] [st0]
- FADD sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
- FADDP -> usage [st0,st1] [st0] -- allFPRegs
- FIADD sz asrc -> usage (addrToRegs asrc) [st0]
- FCHS -> usage [st0] [st0]
- FCOM sz src -> usage (st0:opToReg src) []
- FCOS -> usage [st0] [st0]
- FDIV sz src -> usage (st0:opToReg src) [st0]
- FDIVP -> usage [st0,st1] [st0]
- FDIVRP -> usage [st0,st1] [st0]
- FIDIV sz asrc -> usage (addrToRegs asrc) [st0]
- FDIVR sz src -> usage (st0:opToReg src) [st0]
- FIDIVR sz asrc -> usage (addrToRegs asrc) [st0]
- FICOM sz asrc -> usage (addrToRegs asrc) []
- FILD sz asrc dst -> usage (addrToRegs asrc) [dst] -- allFPRegs
- FIST sz adst -> usage (st0:addrToRegs adst) []
- FLD sz src -> usage (opToReg src) [st0] -- allFPRegs
- FLD1 -> usage [] [st0] -- allFPRegs
- FLDZ -> usage [] [st0] -- allFPRegs
- FMUL sz src -> usage (st0:opToReg src) [st0]
- FMULP -> usage [st0,st1] [st0]
- FIMUL sz asrc -> usage (addrToRegs asrc) [st0]
- FRNDINT -> usage [st0] [st0]
- FSIN -> usage [st0] [st0]
- FSQRT -> usage [st0] [st0]
- FST sz (OpReg r) -> usage [st0] [r]
- FST sz dst -> usage (st0:opToReg dst) []
- FSTP sz (OpReg r) -> usage [st0] [r] -- allFPRegs
- FSTP sz dst -> usage (st0:opToReg dst) [] -- allFPRegs
- FSUB sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
- FSUBR sz src -> usage (st0:opToReg src) [st0] -- allFPRegs
- FISUB sz asrc -> usage (addrToRegs asrc) [st0]
- FSUBP -> usage [st0,st1] [st0] -- allFPRegs
- FSUBRP -> usage [st0,st1] [st0] -- allFPRegs
- FISUBR sz asrc -> usage (addrToRegs asrc) [st0]
- FTST -> usage [st0] []
- FCOMP sz op -> usage (st0:opToReg op) [st0] -- allFPRegs
- FUCOMPP -> usage [st0, st1] [st0, st1] -- allFPRegs
- FXCH -> usage [st0, st1] [st0, st1]
- FNSTSW -> usage [] [eax]
- _ -> noUsage
+
+ GMOV src dst -> usage [src] [dst]
+ GLD sz src dst -> usage (addrToRegs src) [dst]
+ GST sz src dst -> usage [src] (addrToRegs dst)
+
+ GFTOD src dst -> usage [src] [dst]
+ GFTOI src dst -> usage [src] [dst]
+
+ GDTOF src dst -> usage [src] [dst]
+ GDTOI src dst -> usage [src] [dst]
+
+ GITOF src dst -> usage [src] [dst]
+ GITOD src dst -> usage [src] [dst]
+
+ GADD sz s1 s2 dst -> usage [s1,s2] [dst]
+ GSUB sz s1 s2 dst -> usage [s1,s2] [dst]
+ GMUL sz s1 s2 dst -> usage [s1,s2] [dst]
+ GDIV sz s1 s2 dst -> usage [s1,s2] [dst]
+
+ GCMP sz src1 src2 -> usage [src1,src2] []
+ GABS sz src dst -> usage [src] [dst]
+ GNEG sz src dst -> usage [src] [dst]
+ GSQRT sz src dst -> usage [src] [dst]
+
+ COMMENT _ -> noUsage
+ SEGMENT _ -> noUsage
+ LABEL _ -> noUsage
+ ASCII _ _ -> noUsage
+ DATA _ _ -> noUsage
+ _ -> error ("regUsage: " ++ showSDoc (pprInstr instr)) --noUsage
where
usage2 :: Operand -> Operand -> RegUsage
usage2 op (OpReg reg) = usage (opToReg op) [reg]
usage1 :: Operand -> RegUsage
usage1 (OpReg reg) = usage [reg] [reg]
usage1 (OpAddr ea) = usage (addrToRegs ea) []
- allFPRegs = [st0,st1,st2,st3,st4,st5,st6,st7]
+ allFPRegs = [fake0,fake1,fake2,fake3,fake4,fake5]
--callClobberedRegs = [ eax, ecx, edx ] -- according to gcc, anyway.
- callClobberedRegs = [eax]
+ callClobberedRegs = [eax,fake0,fake1,fake2,fake3,fake4,fake5]
-- General purpose register collecting functions.
POP sz op -> patch1 (POP sz) op
SETCC cond op -> patch1 (SETCC cond) op
JMP op -> patch1 JMP op
- FADD sz src -> FADD sz (patchOp src)
- FIADD sz asrc -> FIADD sz (lookupAddr asrc)
- FCOM sz src -> patch1 (FCOM sz) src
- FDIV sz src -> FDIV sz (patchOp src)
- --FDIVP sz src -> FDIVP sz (patchOp src)
- FIDIV sz asrc -> FIDIV sz (lookupAddr asrc)
- FDIVR sz src -> FDIVR sz (patchOp src)
- --FDIVRP sz src -> FDIVRP sz (patchOp src)
- FIDIVR sz asrc -> FIDIVR sz (lookupAddr asrc)
- FICOM sz asrc -> FICOM sz (lookupAddr asrc)
- FILD sz asrc dst -> FILD sz (lookupAddr asrc) (env dst)
- FIST sz adst -> FIST sz (lookupAddr adst)
- FLD sz src -> patch1 (FLD sz) (patchOp src)
- FMUL sz src -> FMUL sz (patchOp src)
- --FMULP sz src -> FMULP sz (patchOp src)
- FIMUL sz asrc -> FIMUL sz (lookupAddr asrc)
- FST sz dst -> FST sz (patchOp dst)
- FSTP sz dst -> FSTP sz (patchOp dst)
- FSUB sz src -> FSUB sz (patchOp src)
- --FSUBP sz src -> FSUBP sz (patchOp src)
- FISUB sz asrc -> FISUB sz (lookupAddr asrc)
- FSUBR sz src -> FSUBR sz (patchOp src)
- --FSUBRP sz src -> FSUBRP sz (patchOp src)
- FISUBR sz asrc -> FISUBR sz (lookupAddr asrc)
- FCOMP sz src -> FCOMP sz (patchOp src)
- _ -> instr
+
+ 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)
+
+ GFTOD src dst -> GFTOD (env src) (env dst)
+ GFTOI src dst -> GFTOI (env src) (env dst)
+
+ GDTOF src dst -> GDTOF (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)
+
+ COMMENT _ -> instr
+ SEGMENT _ -> instr
+ LABEL _ -> instr
+ ASCII _ _ -> instr
+ DATA _ _ -> instr
+ JXX _ _ -> instr
+ CALL _ -> instr
+ CLTD -> instr
+ _ -> error ("patchInstr: " ++ showSDoc (pprInstr instr)) --instr
where
patch1 insn op = insn (patchOp op)
patch2 insn src dst = insn (patchOp src) (patchOp dst)
Spill to memory, and load it back...
+JRS, 000122: on x86, don't spill directly below the stack pointer, since
+some insn sequences (int <-> conversions) use this as a temp location.
+Leave 16 bytes of slop.
+
\begin{code}
spillReg, loadReg :: Reg -> Reg -> InstrList
spillReg dyn (MemoryReg i pk)
+ | i >= 0 -- JRS paranoia
= let
sz = primRepToSize pk
in
IF_ARCH_alpha( ST sz dyn (spRel i)
{-I386: spill below stack pointer leaving 2 words/spill-}
- ,IF_ARCH_i386 ( MOV sz (OpReg dyn) (OpAddr (spRel (-2 * i)))
+ ,IF_ARCH_i386 ( if pk == FloatRep || pk == DoubleRep
+ then GST sz dyn (spRel (-16 + (-2 * i)))
+ else MOV sz (OpReg dyn) (OpAddr (spRel (-16 + (-2 * i))))
{-SPARC: spill below frame pointer leaving 2 words/spill-}
,IF_ARCH_sparc( ST sz dyn (fpRel (-2 * i))
----------------------------
loadReg (MemoryReg i pk) dyn
+ | i >= 0 -- JRS paranoia
= let
sz = primRepToSize pk
in
mkUnitList (
IF_ARCH_alpha( LD sz dyn (spRel i)
- ,IF_ARCH_i386 ( MOV sz (OpAddr (spRel (-2 * i))) (OpReg dyn)
+ ,IF_ARCH_i386 ( if pk == FloatRep || pk == DoubleRep
+ then GLD sz (spRel (-16 + (-2 * i))) dyn
+ else MOV sz (OpAddr (spRel (-16 + (-2 * i)))) (OpReg dyn)
,IF_ARCH_sparc( LD sz (fpRel (-2 * i)) dyn
,)))
)
obj' = amodeToStix obj
ix' = amodeToStix ix
v' = amodeToStix v
- base = StIndex IntRep obj' arrHS
+ base = StIndex IntRep obj' arrHS --(StInt (toInteger 3))
assign = StAssign PtrRep (StInd PtrRep (StIndex PtrRep base ix')) v'
in
returnUs (\xs -> assign : xs)
projects / ghc-hetmet.git / commitdiff