%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[MachCode]{Generating machine code}
import AbsCSyn ( MagicId )
import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv )
-import CLabel ( isAsmTemp, CLabel )
+import CLabel ( isAsmTemp, CLabel, pprCLabel_asm )
import Maybes ( maybeToBool, expectJust )
import OrdList -- quite a bit of it
import PrimRep ( isFloatingRep, PrimRep(..) )
-import PrimOp ( PrimOp(..), showPrimOp )
+import PrimOp ( PrimOp(..) )
import CallConv ( cCallConv )
import Stix ( getUniqLabelNCG, StixTree(..),
- StixReg(..), CodeSegment(..)
+ StixReg(..), CodeSegment(..),
+ pprStixTrees, ppStixReg
)
import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
mapAccumLUs, UniqSM
stmt2Instrs stmt = case stmt of
StComment s -> returnInstr (COMMENT s)
StSegment seg -> returnInstr (SEGMENT seg)
+
StFunBegin lab -> returnInstr (IF_ARCH_alpha(FUNBEGIN lab,LABEL lab))
StFunEnd lab -> IF_ARCH_alpha(returnInstr (FUNEND lab),returnUs id)
StLabel lab -> returnInstr (LABEL lab)
StData kind args
-> mapAndUnzipUs getData args `thenUs` \ (codes, imms) ->
returnUs (\xs -> mkSeqList (asmInstr (DATA (primRepToSize kind) imms))
- (foldr1 (.) codes xs))
+ (foldr (.) id codes xs))
where
getData :: StixTree -> UniqSM (InstrBlock, Imm)
getData (StInt i) = returnUs (id, ImmInteger i)
- getData (StDouble d) = returnUs (id, dblImmLit d)
+ getData (StDouble d) = returnUs (id, ImmDouble d)
getData (StLitLbl s) = returnUs (id, ImmLab s)
- getData (StLitLit s) = returnUs (id, strImmLit (cvtLitLit (_UNPK_ s)))
getData (StCLbl l) = returnUs (id, ImmCLbl l)
getData (StString s) =
getUniqLabelNCG `thenUs` \ lbl ->
returnUs (mkSeqInstrs [LABEL lbl,
ASCII True (_UNPK_ s)],
ImmCLbl lbl)
+ -- the linker can handle simple arithmetic...
+ getData (StIndex rep (StCLbl lbl) (StInt off)) =
+ returnUs (id, ImmIndex lbl (fromInteger (off * sizeOf rep)))
\end{code}
%************************************************************************
where
off = StInt (i * sizeOf pk)
-#ifndef i386_TARGET_ARCH
mangleIndexTree (StIndex pk base off)
- = StPrim IntAddOp [base,
- case pk of
- CharRep -> off
- _ -> let
- s = shift pk
- in
- ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
- StPrim SllOp [off, StInt s]
- ]
+ = StPrim IntAddOp [
+ base,
+ let s = shift pk
+ in ASSERT(toInteger s == expectJust "MachCode" (exactLog2 (sizeOf pk)))
+ if s == 0 then off else StPrim SllOp [off, StInt s]
+ ]
where
shift DoubleRep = 3::Integer
+ shift CharRep = 0::Integer
shift _ = IF_ARCH_alpha(3,2)
-#else
--- Hmm..this is an attempt at fixing Adress amodes (i.e., *[disp](base,index,<n>),
--- that do include the size of the primitive kind we're addressing. When StIndex
--- is expanded to actual code, the index (in units) is by the above code approp.
--- shifted to get the no. of bytes. Since Address amodes do contain size info
--- explicitly, we disable the shifting for x86s.
-mangleIndexTree (StIndex pk base off) = StPrim IntAddOp [base, off]
-#endif
-
\end{code}
\begin{code}
maybeImm :: StixTree -> Maybe Imm
maybeImm (StLitLbl s) = Just (ImmLab s)
-maybeImm (StLitLit s) = Just (strImmLit (cvtLitLit (_UNPK_ s)))
maybeImm (StCLbl l) = Just (ImmCLbl l)
+maybeImm (StIndex rep (StCLbl l) (StInt off)) =
+ Just (ImmIndex l (fromInteger (off * sizeOf rep)))
+
maybeImm (StInt i)
| i >= toInteger minInt && i <= toInteger maxInt
= Just (ImmInt (fromInteger i))
getRegister (StReg (StixMagicId stgreg))
= case (magicIdRegMaybe stgreg) of
Just reg -> returnUs (Fixed (magicIdPrimRep stgreg) reg id)
- -- cannae be Nothing
+ -- cannae be Nothing
getRegister (StReg (StixTemp u pk))
= returnUs (Fixed pk (UnmappedReg u pk) id)
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)
in
returnUs (Any PtrRep code)
-getRegister (StLitLit s) | _HEAD_ s == '"' && last xs == '"'
- = getUniqLabelNCG `thenUs` \ lbl ->
- let
- imm_lbl = ImmCLbl lbl
- code dst = mkSeqInstrs [
- SEGMENT DataSegment,
- LABEL lbl,
- ASCII False (init xs),
- SEGMENT TextSegment,
-#if alpha_TARGET_ARCH
- LDA dst (AddrImm imm_lbl)
-#endif
-#if i386_TARGET_ARCH
- MOV L (OpImm imm_lbl) (OpReg dst)
-#endif
-#if sparc_TARGET_ARCH
- SETHI (HI imm_lbl) dst,
- OR False dst (RIImm (LO imm_lbl)) dst
-#endif
- ]
- in
- returnUs (Any PtrRep code)
- where
- xs = _UNPK_ (_TAIL_ s)
-- end of machine-"independent" bit; here we go on the rest...
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (NEG Q False) x
- IntAbsOp -> trivialUCode (ABS Q) x
NotOp -> trivialUCode NOT x
Double2FloatOp -> coerceFltCode x
Float2DoubleOp -> coerceFltCode x
- other_op -> getRegister (StCall fn cconv DoubleRep [x])
+ other_op -> getRegister (StCall fn cCallConv DoubleRep [x])
where
fn = case other_op of
FloatExpOp -> SLIT("exp")
SllOp -> trivialCode SLL x y
SrlOp -> trivialCode SRL x y
- ISllOp -> panic "AlphaGen:isll"
+ ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll"
ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra"
- ISrlOp -> panic "AlphaGen:isrl"
+ ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl"
FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x,y])
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#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 [dblImmLit d],
+ DATA DF [ImmDouble d],
SEGMENT TextSegment,
- FLD DF (OpImm (ImmCLbl lbl))
+ GLD DF (ImmAddr (ImmCLbl lbl) 0) dst
]
in
returnUs (Any DoubleRep code)
+-- incorrectly assumes that %esp doesn't move (as does spilling); ToDo: fix
+getRegister (StScratchWord i)
+ | i >= 0 && i < 6
+ = let code dst = mkSeqInstr (LEA L (OpAddr (spRel (i+1))) (OpReg dst))
+ in returnUs (Any PtrRep code)
+
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (NEGI L) x
- IntAbsOp -> absIntCode 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
+
+ FloatSinOp -> trivialUFCode FloatRep (GSIN F) x
+ DoubleSinOp -> trivialUFCode DoubleRep (GSIN DF) x
+
+ FloatCosOp -> trivialUFCode FloatRep (GCOS F) x
+ DoubleCosOp -> trivialUFCode DoubleRep (GCOS DF) x
+
+ FloatTanOp -> trivialUFCode FloatRep (GTAN F) x
+ DoubleTanOp -> trivialUFCode DoubleRep (GTAN 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
FloatExpOp -> (True, SLIT("exp"))
FloatLogOp -> (True, SLIT("log"))
- FloatSinOp -> (True, SLIT("sin"))
- FloatCosOp -> (True, SLIT("cos"))
- FloatTanOp -> (True, SLIT("tan"))
+ --FloatSinOp -> (True, SLIT("sin"))
+ --FloatCosOp -> (True, SLIT("cos"))
+ --FloatTanOp -> (True, SLIT("tan"))
FloatAsinOp -> (True, SLIT("asin"))
FloatAcosOp -> (True, SLIT("acos"))
DoubleExpOp -> (False, SLIT("exp"))
DoubleLogOp -> (False, SLIT("log"))
- DoubleSinOp -> (False, SLIT("sin"))
- DoubleCosOp -> (False, SLIT("cos"))
- DoubleTanOp -> (False, SLIT("tan"))
+ --DoubleSinOp -> (False, SLIT("sin"))
+ --DoubleCosOp -> (False, SLIT("cos"))
+ --DoubleTanOp -> (False, SLIT("tan"))
DoubleAsinOp -> (False, SLIT("asin"))
DoubleAcosOp -> (False, SLIT("acos"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
+ other
+ -> pprPanic "getRegister(x86,unary primop)"
+ (pprStixTrees [StPrim primop [x]])
+
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
CharGtOp -> condIntReg GTT x y
DoubleLtOp -> condFltReg LTT x y
DoubleLeOp -> condFltReg LE x y
- IntAddOp -> {- ToDo: fix this, whatever it is (WDP 96/04)...
- -- this should be optimised by the generic Opts,
- -- I don't know why it is not (sometimes)!
- case args of
- [x, StInt 0] -> getRegister x
- _ -> add_code L x y
- -}
- add_code L x y
-
+ IntAddOp -> add_code L x y
IntSubOp -> sub_code L x y
IntQuotOp -> quot_code L x y True{-division-}
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-}
=> trivialCode's is not restrictive enough (sigh.)
-}
- SllOp -> shift_code (SHL L) x y {-False-}
- SrlOp -> shift_code (SHR L) x y {-False-}
-
- {- ToDo: nuke? -}
- ISllOp -> panic "I386Gen:isll"
- ISraOp -> shift_code (SAR L) x y {-False-} --panic "I386Gen:isra"
- ISrlOp -> panic "I386Gen:isrl"
-
- FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
+ SllOp -> shift_code (SHL L) x y {-False-}
+ SrlOp -> shift_code (SHR L) x y {-False-}
+ 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])
where promote x = StPrim Float2DoubleOp [x]
- DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [x, y])
+ DoublePowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep
+ [x, y])
+ other
+ -> pprPanic "getRegister(x86,dyadic primop)"
+ (pprStixTrees [StPrim primop [x, y]])
where
- shift_code :: (Operand -> Operand -> Instr)
+
+ --------------------
+ shift_code :: (Imm -> 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-}
| maybeToBool imm
= getRegister x `thenUs` \ register ->
- let
- op_imm = OpImm imm__2
+ let op_imm = OpImm imm__2
code__2 dst =
- let
- code = registerCode register dst
- src = registerName register dst
+ let code = registerCode register dst
+ src = registerName register dst
in
- mkSeqInstr (COMMENT SLIT("shift_code")) .
code .
if isFixed register && src /= dst
- then
- mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- instr op_imm (OpReg dst)]
- else
- mkSeqInstr (instr op_imm (OpReg src))
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ instr imm__2 (OpReg dst)]
+ else mkSeqInstr (instr imm__2 (OpReg src))
in
returnUs (Any IntRep code__2)
where
imm__2 = case imm of Just x -> x
{- Case2: shift length is complex (non-immediate) -}
+ -- Since ECX is always used as a spill temporary, we can't
+ -- use it here to do non-immediate shifts. No big deal --
+ -- they are only very rare, and we can use an equivalent
+ -- test-and-jump sequence which doesn't use ECX.
+ -- DO NOT USE REPLACE THIS CODE WITH THE "OBVIOUS" shl/shr/sar CODE,
+ -- SINCE IT WILL CAUSE SERIOUS PROBLEMS WITH THE SPILLER
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.
- -- (only register location we are allowed
- -- to put shift amounts.)
- --
- -- The shift instruction is fed ECX as src reg,
- -- but we coerce this into CL when printing out.
- src1 = registerName register1 ecx
- code1 = if src1 /= ecx then -- if it is not in ecx already, force it!
- registerCode register1 ecx .
- mkSeqInstr (MOV L (OpReg src1) (OpReg ecx))
- else
- registerCode register1 ecx
- code__2 =
- let
- code2 = registerCode register2 eax
- src2 = registerName register2 eax
- in
- code1 . code2 .
- mkSeqInstr (instr (OpReg ecx) (OpReg eax))
+ = getRegister x `thenUs` \ register1 ->
+ getRegister y `thenUs` \ register2 ->
+ getUniqLabelNCG `thenUs` \ lbl_test3 ->
+ getUniqLabelNCG `thenUs` \ lbl_test2 ->
+ getUniqLabelNCG `thenUs` \ lbl_test1 ->
+ getUniqLabelNCG `thenUs` \ lbl_test0 ->
+ getUniqLabelNCG `thenUs` \ lbl_after ->
+ getNewRegNCG IntRep `thenUs` \ tmp ->
+ let code__2 dst
+ = let src_val = registerName register1 dst
+ code_val = registerCode register1 dst
+ src_amt = registerName register2 tmp
+ code_amt = registerCode register2 tmp
+ r_dst = OpReg dst
+ r_tmp = OpReg tmp
+ in
+ code_val .
+ code_amt .
+ mkSeqInstrs [
+ COMMENT (_PK_ "begin shift sequence"),
+ MOV L (OpReg src_val) r_dst,
+ MOV L (OpReg src_amt) r_tmp,
+
+ BT L (ImmInt 4) r_tmp,
+ JXX GEU lbl_test3,
+ instr (ImmInt 16) r_dst,
+
+ LABEL lbl_test3,
+ BT L (ImmInt 3) r_tmp,
+ JXX GEU lbl_test2,
+ instr (ImmInt 8) r_dst,
+
+ LABEL lbl_test2,
+ BT L (ImmInt 2) r_tmp,
+ JXX GEU lbl_test1,
+ instr (ImmInt 4) r_dst,
+
+ LABEL lbl_test1,
+ BT L (ImmInt 1) r_tmp,
+ JXX GEU lbl_test0,
+ instr (ImmInt 2) r_dst,
+
+ LABEL lbl_test0,
+ BT L (ImmInt 0) r_tmp,
+ JXX GEU lbl_after,
+ instr (ImmInt 1) r_dst,
+ LABEL lbl_after,
+
+ COMMENT (_PK_ "end shift sequence")
+ ]
in
- returnUs (Fixed IntRep eax code__2)
+ returnUs (Any IntRep 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
-
--- fixedname = registerName register1 eax
- 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)]
- 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
-
--- fixedname = registerName register2 eax
- 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)]
+ code__2 dst
+ = code .
+ mkSeqInstr (LEA sz (OpAddr (AddrBaseIndex (Just src1) Nothing src2))
+ (OpReg dst))
in
returnUs (Any IntRep code__2)
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)
code dst = mkSeqInstr (MOV L (OpImm imm__2) (OpReg dst))
in
returnUs (Any PtrRep code)
+ | otherwise
+ = pprPanic "getRegister(x86)" (pprStixTrees [leaf])
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
let code dst = mkSeqInstrs [
SEGMENT DataSegment,
LABEL lbl,
- DATA DF [dblImmLit d],
+ DATA DF [ImmDouble d],
SEGMENT TextSegment,
SETHI (HI (ImmCLbl lbl)) tmp,
LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
getRegister (StPrim primop [x]) -- unary PrimOps
= case primop of
IntNegOp -> trivialUCode (SUB False False g0) x
- IntAbsOp -> absIntCode x
NotOp -> trivialUCode (XNOR False g0) x
FloatNegOp -> trivialUFCode FloatRep (FNEG F) x
DoubleSinhOp -> (False, SLIT("sinh"))
DoubleCoshOp -> (False, SLIT("cosh"))
DoubleTanhOp -> (False, SLIT("tanh"))
- _ -> panic ("Monadic PrimOp not handled: " ++ showPrimOp primop)
+ _ -> panic ("Monadic PrimOp not handled: " ++ show primop)
getRegister (StPrim primop [x, y]) -- dyadic PrimOps
= case primop of
SllOp -> trivialCode SLL x y
SrlOp -> trivialCode SRL x y
- ISllOp -> panic "SparcGen:isll"
+ ISllOp -> trivialCode SLL x y --was: panic "SparcGen:isll"
ISraOp -> trivialCode SRA x y --was: panic "SparcGen:isra"
- ISrlOp -> panic "SparcGen:isrl"
+ ISrlOp -> trivialCode SRL x y --was: panic "SparcGen:isrl"
FloatPowerOp -> getRegister (StCall SLIT("pow") cCallConv DoubleRep [promote x, promote y])
where promote x = StPrim Float2DoubleOp [x]
in
returnUs (Amode (AddrBaseIndex (Just reg) Nothing off) code)
-getAmode (StPrim IntAddOp [x, y])
+getAmode (StPrim IntAddOp [x, StPrim SllOp [y, StInt shift]])
+ | shift == 0 || shift == 1 || shift == 2 || shift == 3
= getNewRegNCG PtrRep `thenUs` \ tmp1 ->
getNewRegNCG IntRep `thenUs` \ tmp2 ->
getRegister x `thenUs` \ register1 ->
code2 = registerCode register2 tmp2 asmVoid
reg2 = registerName register2 tmp2
code__2 = asmParThen [code1, code2]
+ base = case shift of 0 -> 1 ; 1 -> 2; 2 -> 4; 3 -> 8
in
- returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,4)) (ImmInt 0)) code__2)
+ returnUs (Amode (AddrBaseIndex (Just reg1) (Just (reg2,base)) (ImmInt 0))
+ code__2)
getAmode leaf
| maybeToBool imm
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 -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-assignIntCode pk (StInd _ dst) src
+assignIntCode pk dd@(StInd _ dst) src
= getAmode dst `thenUs` \ amode ->
- get_op_RI src `thenUs` \ (codesrc, opsrc, sz) ->
+ get_op_RI src `thenUs` \ (codesrc, opsrc) ->
let
code1 = amodeCode amode asmVoid
dst__2 = amodeAddr amode
code__2 = asmParThen [code1, codesrc asmVoid] .
- mkSeqInstr (MOV sz opsrc (OpAddr dst__2))
+ mkSeqInstr (MOV (primRepToSize pk) opsrc (OpAddr dst__2))
in
returnUs code__2
where
get_op_RI
:: StixTree
- -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
+ -> UniqSM (InstrBlock,Operand) -- code, operator
get_op_RI op
| maybeToBool imm
- = returnUs (asmParThen [], OpImm imm_op, L)
+ = returnUs (asmParThen [], OpImm imm_op)
where
imm = maybeImm op
imm_op = case imm of Just x -> x
let
code = registerCode register tmp
reg = registerName register tmp
- pk = registerRep register
- sz = primRepToSize pk
in
- returnUs (code, OpReg reg, sz)
+ returnUs (code, OpReg reg)
-assignIntCode pk dst (StInd _ src)
+assignIntCode pk dst (StInd pks src)
= getNewRegNCG IntRep `thenUs` \ tmp ->
getAmode src `thenUs` \ amode ->
getRegister dst `thenUs` \ register ->
src__2 = amodeAddr amode
code2 = registerCode register tmp asmVoid
dst__2 = registerName register tmp
- sz = primRepToSize pk
+ szs = primRepToSize pks
code__2 = asmParThen [code1, code2] .
- mkSeqInstr (MOV sz (OpAddr src__2) (OpReg dst__2))
+ case szs of
+ L -> mkSeqInstr (MOV L (OpAddr src__2) (OpReg dst__2))
+ B -> mkSeqInstr (MOVZxL B (OpAddr src__2) (OpReg dst__2))
in
returnUs code__2
= 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
genCCall fn cconv kind [StInt i]
| fn == SLIT ("PerformGC_wrapper")
- = let
- call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- CALL (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))]
+ = let call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
+ CALL (ImmLit (ptext (if underscorePrefix
+ then (SLIT ("_PerformGC_wrapper"))
+ else (SLIT ("PerformGC_wrapper")))))]
in
returnInstrs call
-{- OLD:
- = getUniqLabelNCG `thenUs` \ lbl ->
- let
- call = [MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax),
- MOV L (OpImm (ImmCLbl lbl))
- -- this is hardwired
- (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 104))),
- JMP (OpImm (ImmLit (ptext (if underscorePrefix then (SLIT ("_PerformGC_wrapper")) else (SLIT ("PerformGC_wrapper")))))),
- LABEL lbl]
- in
- returnInstrs call
--}
genCCall fn cconv kind args
- = mapUs get_call_arg args `thenUs` \ argCode ->
+ = get_call_args args `thenUs` \ (tot_arg_size, argCode) ->
let
- nargs = length args
+ code2 = asmParThen (map ($ asmVoid) argCode)
+ call = [SUB L (OpImm (ImmInt tot_arg_size)) (OpReg esp),
+ CALL fn__2 ,
+ ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)
+ ]
+ in
+ returnSeq code2 call
-{- OLD: Since there's no attempt at stealing %esp at the moment,
- restoring %esp from MainRegTable.rCstkptr is not done. -- SOF 97/09
- (ditto for saving away old-esp in MainRegTable.Hp (!!) )
- code1 = asmParThen [asmSeq [ -- MOV L (OpReg esp) (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))),
- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 100))) (OpReg esp)
- ]
- ]
--}
- code2 = asmParThen (map ($ asmVoid) (reverse argCode))
- call = [CALL fn__2 ,
- -- pop args; all args word sized?
- ADD L (OpImm (ImmInt (nargs * 4))) (OpReg esp) --,
-
- -- Don't restore %esp (see above)
- -- MOV L (OpAddr (AddrBaseIndex (Just ebx) Nothing (ImmInt 80))) (OpReg esp)
- ]
- in
- returnSeq (code2) call
where
-- function names that begin with '.' are assumed to be special
-- internally generated names like '.mul,' which don't get an
'.' -> ImmLit (ptext fn)
_ -> ImmLab (ptext fn)
+ arg_size DF = 8
+ arg_size F = 8
+ arg_size _ = 4
+
------------
- get_call_arg :: StixTree{-current argument-} -> UniqSM InstrBlock -- code
+ -- do get_call_arg on each arg, threading the total arg size along
+ -- process the args right-to-left
+ get_call_args :: [StixTree] -> UniqSM (Int, [InstrBlock])
+ get_call_args args
+ = f 0 args
+ where
+ f curr_sz []
+ = returnUs (curr_sz, [])
+ f curr_sz (arg:args)
+ = f curr_sz args `thenUs` \ (new_sz, iblocks) ->
+ get_call_arg arg new_sz `thenUs` \ (new_sz2, iblock) ->
+ returnUs (new_sz2, iblock:iblocks)
- get_call_arg arg
- = get_op arg `thenUs` \ (code, op, sz) ->
- returnUs (code . mkSeqInstr (PUSH sz op))
------------
+ get_call_arg :: StixTree{-current argument-}
+ -> Int{-running total of arg sizes seen so far-}
+ -> UniqSM (Int, InstrBlock) -- updated tot argsz, code
+
+ get_call_arg arg old_sz
+ = get_op arg `thenUs` \ (code, reg, sz) ->
+ let new_sz = old_sz + arg_size sz
+ in if (case sz of DF -> True; F -> True; _ -> False)
+ then returnUs (new_sz,
+ code .
+ mkSeqInstr (GST DF reg
+ (AddrBaseIndex (Just esp)
+ Nothing (ImmInt (- new_sz))))
+ )
+ else returnUs (new_sz,
+ code .
+ mkSeqInstr (MOV L (OpReg reg)
+ (OpAddr
+ (AddrBaseIndex (Just esp)
+ Nothing (ImmInt (- new_sz)))))
+ )
+ ------------
get_op
:: StixTree
- -> UniqSM (InstrBlock,Operand, Size) -- code, operator, size
-
- get_op (StInt i)
- = returnUs (asmParThen [], OpImm (ImmInt (fromInteger i)), L)
-
- get_op (StInd pk mem)
- = getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode --asmVoid
- addr = amodeAddr amode
- sz = primRepToSize pk
- in
- returnUs (code, OpAddr addr, sz)
+ -> UniqSM (InstrBlock, Reg, Size) -- code, reg, size
get_op op
= getRegister op `thenUs` \ register ->
pk = registerRep register
sz = primRepToSize pk
in
- returnUs (code, OpReg reg, sz)
+ returnUs (code, 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
--- fixedname = registerName register1 eax
code__2 dst = let code1 = registerCode register1 dst
src1 = registerName register1 dst
in code1 .
- if isFixed register1 && src1 /= dst
+ if isFixed register1 && src1 /= dst
then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
+ else mkSeqInstrs [instr (OpImm imm__2) (OpReg src1)]
in
returnUs (Any IntRep code__2)
where
imm__2 = case imm of Just x -> x
trivialCode instr x y
- | maybeToBool imm
- = getRegister y `thenUs` \ register1 ->
- --getNewRegNCG IntRep `thenUs` \ tmp1 ->
- let
--- fixedname = registerName register1 eax
- code__2 dst = let code1 = registerCode register1 dst
- src1 = registerName register1 dst
- in code1 .
- if isFixed register1 && src1 /= dst
- then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
- instr (OpImm imm__2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpImm imm__2) (OpReg src1))
- in
- returnUs (Any IntRep code__2)
- 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
--- fixedname = registerName register eax
- 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
--- fixedname = registerName register eax
- 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
--- fixedname = registerName register1 eax
- code2 = registerCode register2 tmp2 asmVoid
+ code2 = registerCode register2 tmp2 --asmVoid
src2 = registerName register2 tmp2
- code__2 dst = let
- code1 = registerCode register1 dst asmVoid
+ code__2 dst = let code1 = registerCode register1 dst --asmVoid
src1 = registerName register1 dst
- in asmParThen [code1, code2] .
- if isFixed register1 && src1 /= dst
+ in code2 . code1 . --asmParThen [code1, code2] .
+ if isFixed register1 && src1 /= dst
then mkSeqInstrs [MOV L (OpReg src1) (OpReg dst),
instr (OpReg src2) (OpReg dst)]
- else
- mkSeqInstr (instr (OpReg src2) (OpReg src1))
+ else mkSeqInstr (instr (OpReg src2) (OpReg src1))
in
returnUs (Any IntRep code__2)
-----------
trivialUCode instr x
= getRegister x `thenUs` \ register ->
--- getNewRegNCG IntRep `thenUs` \ tmp ->
let
--- fixedname = registerName register eax
- code__2 dst = let
- code = registerCode register dst
+ code__2 dst = let code = registerCode register dst
src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- instr (OpReg dst)]
- else mkSeqInstr (instr (OpReg src))
+ in code .
+ if isFixed register && dst /= src
+ then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
+ instr (OpReg dst)]
+ else mkSeqInstr (instr (OpReg src))
in
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
- src1 = amodeAddr amode
-
- code__2 dst = let
- code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid,code2 asmVoid] .
- mkSeqInstrs [instrr (primRepToSize pk) (OpAddr src1)]
- in
- returnUs (Any pk code__2)
-
-trivialFCode pk instr _ _ _ x (StInd pk' 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] .
- mkSeqInstrs [instr (primRepToSize pk) (OpAddr src2)]
- in
- returnUs (Any pk code__2)
-
-trivialFCode pk _ _ _ instrpr x y
+trivialFCode pk instr x y
= getRegister x `thenUs` \ register1 ->
getRegister y `thenUs` \ register2 ->
- --getNewRegNCG (registerRep register1)
- -- `thenUs` \ tmp1 ->
- --getNewRegNCG (registerRep register2)
- -- `thenUs` \ tmp2 ->
- getNewRegNCG DoubleRep `thenUs` \ tmp ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp1 ->
+ getNewRegNCG DoubleRep `thenUs` \ tmp2 ->
let
- pk1 = registerRep register1
- code1 = registerCode register1 st0 --tmp1
- src1 = registerName register1 st0 --tmp1
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
- pk2 = registerRep register2
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
- code__2 dst = let
- code2 = registerCode register2 dst
- src2 = registerName register2 dst
- in asmParThen [code1 asmVoid, code2 asmVoid] .
- mkSeqInstr instrpr
+ code__2 dst = asmParThen [code1 asmVoid, code2 asmVoid] .
+ mkSeqInstr (instr (primRepToSize pk) src1 src2 dst)
in
- returnUs (Any pk1 code__2)
+ returnUs (Any DoubleRep code__2)
--------------
-trivialUFCode pk instr (StInd pk' mem)
- = getAmode mem `thenUs` \ amode ->
- let
- code = amodeCode amode
- src = amodeAddr amode
- code__2 dst = code . mkSeqInstrs [FLD (primRepToSize pk) (OpAddr src),
- instr]
- in
- returnUs (Any pk code__2)
+-------------
trivialUFCode pk instr x
= getRegister x `thenUs` \ register ->
- --getNewRegNCG pk `thenUs` \ tmp ->
+ getNewRegNCG pk `thenUs` \ tmp ->
let
- code__2 dst = let
- code = registerCode register dst
- src = registerName register dst
- in code . mkSeqInstrs [instr]
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code . mkSeqInstr (instr src dst)
in
returnUs (Any pk code__2)
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)
chrCode x
= getRegister x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ reg ->
let
--- fixedname = registerName register eax
code__2 dst = let
code = registerCode register dst
src = registerName register dst
#endif {- sparc_TARGET_ARCH -}
\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Absolute value on integers}
-%* *
-%************************************************************************
-
-Absolute value on integers, mostly for gmp size check macros. Again,
-the argument cannot be an StInt, because genericOpt already folded
-constants.
-
-If applicable, do not fill the delay slots here; you will confuse the
-register allocator.
-
-\begin{code}
-absIntCode :: StixTree -> UniqSM Register
-
-#if alpha_TARGET_ARCH
-absIntCode = panic "MachCode.absIntCode: not on Alphas"
-#endif {- alpha_TARGET_ARCH -}
-
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH
-
-absIntCode x
- = getRegister x `thenUs` \ register ->
- --getNewRegNCG IntRep `thenUs` \ reg ->
- getUniqLabelNCG `thenUs` \ lbl ->
- let
- code__2 dst = let code = registerCode register dst
- src = registerName register dst
- in code . if isFixed register && dst /= src
- then mkSeqInstrs [MOV L (OpReg src) (OpReg dst),
- TEST L (OpReg dst) (OpReg dst),
- JXX GE lbl,
- NEGI L (OpReg dst),
- LABEL lbl]
- else mkSeqInstrs [TEST L (OpReg src) (OpReg src),
- JXX GE lbl,
- NEGI L (OpReg src),
- LABEL lbl]
- in
- returnUs (Any IntRep code__2)
-
-#endif {- i386_TARGET_ARCH -}
--- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if sparc_TARGET_ARCH
-
-absIntCode x
- = getRegister x `thenUs` \ register ->
- getNewRegNCG IntRep `thenUs` \ reg ->
- getUniqLabelNCG `thenUs` \ lbl ->
- let
- code = registerCode register reg
- src = registerName register reg
- code__2 dst = code . mkSeqInstrs [
- SUB False True g0 (RIReg src) dst,
- BI GE False (ImmCLbl lbl), NOP,
- OR False g0 (RIReg src) dst,
- LABEL lbl]
- in
- returnUs (Any IntRep code__2)
-
-#endif {- sparc_TARGET_ARCH -}
-\end{code}
-
projects / ghc-hetmet.git / blobdiff