#include "HsVersions.h"
#include "nativeGen/NCG.h"
-import Unique ( Unique )
import MachMisc -- may differ per-platform
import MachRegs
import OrdList ( OrdList, nilOL, isNilOL, unitOL, appOL, toOL,
#endif
import Maybes ( maybeToBool )
import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..),
+#if powerpc_TARGET_ARCH
+ getPrimRepSize,
+#endif
getPrimRepSizeInBytes )
import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..),
StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
DestInfo, hasDestInfo,
pprStixExpr, repOfStixExpr,
- liftStrings,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
- getDeltaNat, setDeltaNat, getUniqueNat,
+ getDeltaNat, setDeltaNat,
+ IF_ARCH_powerpc(addImportNat COMMA,)
ncgPrimopMoan,
ncg_target_is_32bit
)
import CmdLineOpts ( opt_Static )
import Stix ( pprStixStmt )
+import Maybe ( fromMaybe )
+
-- DEBUGGING ONLY
-import IOExts ( trace )
import Outputable ( assertPanic )
import FastString
+import TRACE ( trace )
infixr 3 `bind`
\end{code}
iselExpr64 expr
= pprPanic "iselExpr64(i386)" (pprStixExpr expr)
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
iselExpr64 expr
= pprPanic "iselExpr64(sparc)" (pprStixExpr expr)
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+#if powerpc_TARGET_ARCH
+
+assignMem_I64Code addrTree valueTree
+ = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) ->
+ getRegister addrTree `thenNat` \ register_addr ->
+ getNewRegNCG IntRep `thenNat` \ t_addr ->
+ let rlo = VirtualRegI vrlo
+ rhi = getHiVRegFromLo rlo
+ code_addr = registerCode register_addr t_addr
+ reg_addr = registerName register_addr t_addr
+ -- Big-endian store
+ mov_hi = ST W rhi (AddrRegImm reg_addr (ImmInt 0))
+ mov_lo = ST W rlo (AddrRegImm reg_addr (ImmInt 4))
+ in
+ returnNat (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo)
+
+
+assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree
+ = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) ->
+ let
+ r_dst_lo = mkVReg u_dst IntRep
+ r_src_lo = VirtualRegI vr_src_lo
+ r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = MR r_dst_lo r_src_lo
+ mov_hi = MR r_dst_hi r_src_hi
+ in
+ returnNat (
+ vcode `snocOL` mov_hi `snocOL` mov_lo
+ )
+assignReg_I64Code lvalue valueTree
+ = pprPanic "assignReg_I64Code(powerpc): invalid lvalue"
+ (pprStixReg lvalue)
+
+
+-- Don't delete this -- it's very handy for debugging.
+--iselExpr64 expr
+-- | trace ("iselExpr64: " ++ showSDoc (pprStixExpr expr)) False
+-- = panic "iselExpr64(???)"
+
+iselExpr64 (StInd pk addrTree)
+ | is64BitRep pk
+ = getRegister addrTree `thenNat` \ register_addr ->
+ getNewRegNCG IntRep `thenNat` \ t_addr ->
+ getNewRegNCG IntRep `thenNat` \ rlo ->
+ let rhi = getHiVRegFromLo rlo
+ code_addr = registerCode register_addr t_addr
+ reg_addr = registerName register_addr t_addr
+ mov_hi = LD W rhi (AddrRegImm reg_addr (ImmInt 0))
+ mov_lo = LD W rlo (AddrRegImm reg_addr (ImmInt 4))
+ in
+ returnNat (
+ ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo)
+ (getVRegUnique rlo)
+ )
+
+iselExpr64 (StReg (StixTemp (StixVReg vu pk)))
+ | is64BitRep pk
+ = getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
+ let r_dst_hi = getHiVRegFromLo r_dst_lo
+ r_src_lo = mkVReg vu IntRep
+ r_src_hi = getHiVRegFromLo r_src_lo
+ mov_lo = MR r_dst_lo r_src_lo
+ mov_hi = MR r_dst_hi r_src_hi
+ in
+ returnNat (
+ ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo)
+ )
+
+iselExpr64 (StCall fn cconv kind args)
+ | is64BitRep kind
+ = genCCall fn cconv kind args `thenNat` \ call ->
+ getNewRegNCG IntRep `thenNat` \ r_dst_lo ->
+ let r_dst_hi = getHiVRegFromLo r_dst_lo
+ mov_lo = MR r_dst_lo r4
+ mov_hi = MR r_dst_hi r3
+ in
+ returnNat (
+ ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo)
+ (getVRegUnique r_dst_lo)
+ )
+
+iselExpr64 expr
+ = pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
+
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
returnNat (Fixed kind reg call)
where
reg = if isFloatingRep kind
- 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,)))
+ then IF_ARCH_alpha( f0, IF_ARCH_i386( fake0, IF_ARCH_sparc( f0, IF_ARCH_powerpc( f1,))))
+ else IF_ARCH_alpha( v0, IF_ARCH_i386( eax, IF_ARCH_sparc( o0, IF_ARCH_powerpc( r3,))))
getRegister (StString s)
= getNatLabelNCG `thenNat` \ lbl ->
SETHI (HI imm_lbl) dst,
OR False dst (RIImm (LO imm_lbl)) dst
#endif
+#if powerpc_TARGET_ARCH
+ LIS dst (HI imm_lbl),
+ OR dst dst (RIImm (LO imm_lbl))
+#endif
]
in
returnNat (Any PtrRep code)
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
-- Conversions which are a nop on x86
- MO_NatS_to_32U -> conversionNop WordRep x
MO_32U_to_NatS -> conversionNop IntRep x
+ MO_32S_to_NatS -> conversionNop IntRep x
+ MO_NatS_to_32U -> conversionNop WordRep x
MO_32U_to_NatU -> conversionNop WordRep x
MO_NatU_to_NatS -> conversionNop IntRep x
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- Conversions which are a nop on sparc
MO_32U_to_NatS -> conversionNop IntRep x
+ MO_32S_to_NatS -> conversionNop IntRep x
MO_NatS_to_32U -> conversionNop WordRep x
MO_32U_to_NatU -> conversionNop WordRep x
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+getRegister (StMachOp mop [x]) -- unary MachOps
+ = case mop of
+ MO_NatS_Neg -> trivialUCode NEG x
+ MO_Nat_Not -> trivialUCode NOT x
+ MO_32U_to_8U -> trivialCode AND x (StInt 255)
+
+ MO_Flt_to_NatS -> coerceFP2Int FloatRep x
+ MO_NatS_to_Flt -> coerceInt2FP FloatRep x
+ MO_Dbl_to_NatS -> coerceFP2Int DoubleRep x
+ MO_NatS_to_Dbl -> coerceInt2FP DoubleRep x
+
+ -- Conversions which are a nop on PPC
+ MO_NatS_to_32U -> conversionNop WordRep x
+ MO_32U_to_NatS -> conversionNop IntRep x
+ MO_32U_to_NatU -> conversionNop WordRep x
+
+ MO_NatU_to_NatS -> conversionNop IntRep x
+ MO_NatS_to_NatU -> conversionNop WordRep x
+ MO_NatP_to_NatU -> conversionNop WordRep x
+ MO_NatU_to_NatP -> conversionNop PtrRep x
+ MO_NatS_to_NatP -> conversionNop PtrRep x
+ MO_NatP_to_NatS -> conversionNop IntRep x
+
+ MO_Dbl_to_Flt -> conversionNop FloatRep x
+ MO_Flt_to_Dbl -> conversionNop DoubleRep x
+
+ -- sign-extending widenings ###PPC This is inefficient: use ext* instructions
+ MO_8U_to_NatU -> integerExtend False 24 x
+ MO_8S_to_NatS -> integerExtend True 24 x
+ MO_16U_to_NatU -> integerExtend False 16 x
+ MO_16S_to_NatS -> integerExtend True 16 x
+ MO_8U_to_32U -> integerExtend False 24 x
+
+ MO_Flt_Neg -> trivialUFCode FloatRep FNEG x
+ MO_Dbl_Neg -> trivialUFCode FloatRep FNEG x
+
+ other_op -> getRegister (StCall (Left fn) CCallConv DoubleRep [x])
+ where
+ integerExtend signed nBits x
+ = getRegister (
+ StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr)
+ [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits]
+ )
+ conversionNop new_rep expr
+ = getRegister expr `thenNat` \ e_code ->
+ returnNat (swizzleRegisterRep e_code new_rep)
+
+ (is_float_op, fn)
+ = case mop of
+ MO_Flt_Exp -> (True, FSLIT("exp"))
+ MO_Flt_Log -> (True, FSLIT("log"))
+ MO_Flt_Sqrt -> (True, FSLIT("sqrt"))
+
+ MO_Flt_Sin -> (True, FSLIT("sin"))
+ MO_Flt_Cos -> (True, FSLIT("cos"))
+ MO_Flt_Tan -> (True, FSLIT("tan"))
+
+ MO_Flt_Asin -> (True, FSLIT("asin"))
+ MO_Flt_Acos -> (True, FSLIT("acos"))
+ MO_Flt_Atan -> (True, FSLIT("atan"))
+
+ MO_Flt_Sinh -> (True, FSLIT("sinh"))
+ MO_Flt_Cosh -> (True, FSLIT("cosh"))
+ MO_Flt_Tanh -> (True, FSLIT("tanh"))
+
+ MO_Dbl_Exp -> (False, FSLIT("exp"))
+ MO_Dbl_Log -> (False, FSLIT("log"))
+ MO_Dbl_Sqrt -> (False, FSLIT("sqrt"))
+
+ MO_Dbl_Sin -> (False, FSLIT("sin"))
+ MO_Dbl_Cos -> (False, FSLIT("cos"))
+ MO_Dbl_Tan -> (False, FSLIT("tan"))
+
+ MO_Dbl_Asin -> (False, FSLIT("asin"))
+ MO_Dbl_Acos -> (False, FSLIT("acos"))
+ MO_Dbl_Atan -> (False, FSLIT("atan"))
+
+ MO_Dbl_Sinh -> (False, FSLIT("sinh"))
+ MO_Dbl_Cosh -> (False, FSLIT("cosh"))
+ MO_Dbl_Tanh -> (False, FSLIT("tanh"))
+
+ other -> pprPanic "getRegister(powerpc) - unary StMachOp"
+ (pprMachOp mop)
+
+
+getRegister (StMachOp mop [x, y]) -- dyadic PrimOps
+ = case mop of
+ MO_32U_Gt -> condIntReg GTT x y
+ MO_32U_Ge -> condIntReg GE x y
+ MO_32U_Eq -> condIntReg EQQ x y
+ MO_32U_Ne -> condIntReg NE x y
+ MO_32U_Lt -> condIntReg LTT x y
+ MO_32U_Le -> condIntReg LE x y
+
+ MO_Nat_Eq -> condIntReg EQQ x y
+ MO_Nat_Ne -> condIntReg NE x y
+
+ MO_NatS_Gt -> condIntReg GTT x y
+ MO_NatS_Ge -> condIntReg GE x y
+ MO_NatS_Lt -> condIntReg LTT x y
+ MO_NatS_Le -> condIntReg LE x y
+
+ MO_NatU_Gt -> condIntReg GU x y
+ MO_NatU_Ge -> condIntReg GEU x y
+ MO_NatU_Lt -> condIntReg LU x y
+ MO_NatU_Le -> condIntReg LEU x y
+
+ MO_Flt_Gt -> condFltReg GTT x y
+ MO_Flt_Ge -> condFltReg GE x y
+ MO_Flt_Eq -> condFltReg EQQ x y
+ MO_Flt_Ne -> condFltReg NE x y
+ MO_Flt_Lt -> condFltReg LTT x y
+ MO_Flt_Le -> condFltReg LE x y
+
+ MO_Dbl_Gt -> condFltReg GTT x y
+ MO_Dbl_Ge -> condFltReg GE x y
+ MO_Dbl_Eq -> condFltReg EQQ x y
+ MO_Dbl_Ne -> condFltReg NE x y
+ MO_Dbl_Lt -> condFltReg LTT x y
+ MO_Dbl_Le -> condFltReg LE x y
+
+ MO_Nat_Add -> trivialCode ADD x y
+ MO_Nat_Sub -> fromMaybe (trivialCode2 SUBF y x) $
+ case y of -- subfi ('substract from' with immediate) doesn't exist
+ StInt imm -> if fits16Bits imm && imm /= (-32768)
+ then Just $ trivialCode ADD x (StInt (-imm))
+ else Nothing
+ _ -> Nothing
+
+ MO_NatS_Mul -> trivialCode MULLW x y
+ MO_NatU_Mul -> trivialCode MULLW x y
+ -- MO_NatS_MulMayOflo ->
+
+ MO_NatS_Quot -> trivialCode2 DIVW x y
+ MO_NatU_Quot -> trivialCode2 DIVWU x y
+
+ MO_NatS_Rem -> remainderCode DIVW x y
+ MO_NatU_Rem -> remainderCode DIVWU x y
+
+ MO_Nat_And -> trivialCode AND x y
+ MO_Nat_Or -> trivialCode OR x y
+ MO_Nat_Xor -> trivialCode XOR x y
+
+ MO_Nat_Shl -> trivialCode SLW x y
+ MO_Nat_Shr -> trivialCode SRW x y
+ MO_Nat_Sar -> trivialCode SRAW x y
+
+ MO_Flt_Add -> trivialFCode FloatRep FADD x y
+ MO_Flt_Sub -> trivialFCode FloatRep FSUB x y
+ MO_Flt_Mul -> trivialFCode FloatRep FMUL x y
+ MO_Flt_Div -> trivialFCode FloatRep FDIV x y
+
+ MO_Dbl_Add -> trivialFCode DoubleRep FADD x y
+ MO_Dbl_Sub -> trivialFCode DoubleRep FSUB x y
+ MO_Dbl_Mul -> trivialFCode DoubleRep FMUL x y
+ MO_Dbl_Div -> trivialFCode DoubleRep FDIV x y
+
+ MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
+ [x, y])
+ MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep
+ [x, y])
+
+ other -> pprPanic "getRegister(powerpc) - binary StMachOp (1)" (pprMachOp mop)
+
+getRegister (StInd pk mem)
+ = getAmode mem `thenNat` \ amode ->
+ let
+ code = amodeCode amode
+ src = amodeAddr amode
+ size = primRepToSize pk
+ code__2 dst = code `snocOL` LD size dst src
+ in
+ returnNat (Any pk code__2)
+
+getRegister (StInt i)
+ | fits16Bits i
+ = let
+ src = ImmInt (fromInteger i)
+ code dst = unitOL (LI dst src)
+ in
+ returnNat (Any IntRep code)
+
+getRegister (StFloat d)
+ = getNatLabelNCG `thenNat` \ lbl ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
+ let code dst = toOL [
+ SEGMENT RoDataSegment,
+ LABEL lbl,
+ DATA F [ImmFloat d],
+ SEGMENT TextSegment,
+ LIS tmp (HA (ImmCLbl lbl)),
+ LD F dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
+ in
+ returnNat (Any FloatRep code)
+
+getRegister (StDouble d)
+ = getNatLabelNCG `thenNat` \ lbl ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
+ let code dst = toOL [
+ SEGMENT RoDataSegment,
+ LABEL lbl,
+ DATA DF [ImmDouble d],
+ SEGMENT TextSegment,
+ LIS tmp (HA (ImmCLbl lbl)),
+ LD DF dst (AddrRegImm tmp (LO (ImmCLbl lbl)))]
+ in
+ returnNat (Any DoubleRep code)
+
+getRegister leaf
+ | maybeToBool imm
+ = let
+ code dst = toOL [
+ LIS dst (HI imm__2),
+ OR dst dst (RIImm (LO imm__2))]
+ in
+ returnNat (Any PtrRep code)
+ | otherwise
+ = ncgPrimopMoan "getRegister(powerpc)" (pprStixExpr leaf)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+#endif /* powerpc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (Amode (AddrReg reg) code)
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code)
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (Amode (AddrRegImm reg off) code)
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#ifdef powerpc_TARGET_ARCH
+getAmode (StMachOp MO_Nat_Sub [x, StInt i])
+ | fits16Bits (-i)
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (-(fromInteger i))
+ in
+ returnNat (Amode (AddrRegImm reg off) code)
+
+
+getAmode (StMachOp MO_Nat_Add [x, StInt i])
+ | fits16Bits i
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister x `thenNat` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt (fromInteger i)
+ in
+ returnNat (Amode (AddrRegImm reg off) code)
+
+getAmode leaf
+ | maybeToBool imm
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ let
+ code = unitOL (LIS tmp (HA imm__2))
+ in
+ returnNat (Amode (AddrRegImm tmp (LO imm__2)) code)
+ where
+ imm = maybeImm leaf
+ imm__2 = case imm of Just x -> x
+
+getAmode other
+ = getNewRegNCG PtrRep `thenNat` \ tmp ->
+ getRegister other `thenNat` \ register ->
+ let
+ code = registerCode register tmp
+ reg = registerName register tmp
+ off = ImmInt 0
+ in
+ returnNat (Amode (AddrRegImm reg off) code)
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
#if alpha_TARGET_ARCH
getCondCode = panic "MachCode.getCondCode: not on Alphas"
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-#if i386_TARGET_ARCH || sparc_TARGET_ARCH
+#if i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH
-- yes, they really do seem to want exactly the same!
getCondCode (StMachOp mop [x, y])
MO_Dbl_Lt -> condFltCode LTT x y
MO_Dbl_Le -> condFltCode LE x y
- other -> pprPanic "getCondCode(x86,sparc)" (pprMachOp mop)
+ other -> pprPanic "getCondCode(x86,sparc,powerpc)" (pprMachOp mop)
+
+getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
-getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (pprStixExpr other)
+#endif /* i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH */
-#endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
#if alpha_TARGET_ARCH
condIntCode = panic "MachCode.condIntCode: not on Alphas"
condFltCode = panic "MachCode.condFltCode: not on Alphas"
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#if i386_TARGET_ARCH
-- and true. Hence we always supply EQQ as the condition to test.
returnNat (CondCode True EQQ code__2)
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
code1 `appOL` code2 `snocOL` promote src2 `snocOL`
FCMP True DF src1 tmp
in
- returnNat (CondCode True cond code__2)
+ returnNat (CondCode True cond code__2)
+
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+condIntCode cond x (StInt y)
+ | fits16Bits y
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (fromInteger y)
+ code__2 = code `snocOL`
+ (if condUnsigned cond then CMPL else CMP) W src1 (RIImm src2)
+ in
+ returnNat (CondCode False cond code__2)
+
+condIntCode cond x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+ code__2 = code1 `appOL` code2 `snocOL`
+ (if condUnsigned cond then CMPL else CMP) W src1 (RIReg src2)
+ in
+ returnNat (CondCode False cond code__2)
+
+condFltCode cond x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG (registerRep register1)
+ `thenNat` \ tmp1 ->
+ getNewRegNCG (registerRep register2)
+ `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+ code__2 = code1 `appOL` code2 `snocOL`
+ FCMP src1 src2
+ in
+ returnNat (CondCode False cond code__2)
+
+#endif /* powerpc_TARGET_ARCH */
-#endif {- sparc_TARGET_ARCH -}
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
in
returnNat code__2
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
r_dst = registerName registerd tmp
r_src = registerName registers r_dst
c_src = registerCode registers r_dst
-
+
code = c_src `snocOL`
MOV L (OpReg r_src) (OpReg r_dst)
in
returnNat code
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
assignReg_IntCode pk reg src
= getRegister src `thenNat` \ register2 ->
getRegisterReg reg `thenNat` \ register1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
let
- dst__2 = registerName register1 g0
+ dst__2 = registerName register1 tmp
code = registerCode register2 dst__2
src__2 = registerName register2 dst__2
code__2 = if isFixed register2
in
returnNat code__2
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+assignMem_IntCode pk addr src
+ = getNewRegNCG IntRep `thenNat` \ tmp ->
+ getAmode addr `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
+ let
+ code1 = amodeCode amode
+ dst__2 = amodeAddr amode
+ code2 = registerCode register tmp
+ src__2 = registerName register tmp
+ sz = primRepToSize pk
+ code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
+ in
+ returnNat code__2
+
+assignReg_IntCode pk reg src
+ = getRegister src `thenNat` \ register2 ->
+ getRegisterReg reg `thenNat` \ register1 ->
+ let
+ dst__2 = registerName register1 (panic "###PPC where are we assigning this int???")
+ code = registerCode register2 dst__2
+ src__2 = registerName register2 dst__2
+ code__2 = if isFixed register2
+ then code `snocOL` MR dst__2 src__2
+ else code
+ in
+ returnNat code__2
+
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
in
returnNat code__2
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
returnNat code
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat code__2
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src
+ = getNewRegNCG pk `thenNat` \ tmp1 ->
+ getAmode addr `thenNat` \ amode ->
+ getRegister src `thenNat` \ register ->
+ let
+ sz = primRepToSize pk
+ dst__2 = amodeAddr amode
+
+ code1 = amodeCode amode
+ code2 = registerCode register tmp1
+
+ src__2 = registerName register tmp1
+ pk__2 = registerRep register
+
+ code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
+ in
+ returnNat code__2
+
+-- Floating point assignment to a register/temporary
+assignReg_FltCode pk reg src
+ = getRegisterReg reg `thenNat` \ reg_dst ->
+ getRegister src `thenNat` \ reg_src ->
+ getNewRegNCG pk `thenNat` \ tmp ->
+ let
+ r_dst = registerName reg_dst tmp
+ r_src = registerName reg_src r_dst
+ c_src = registerCode reg_src r_dst
+
+ code = if isFixed reg_src
+ then c_src `snocOL` MR r_dst r_src
+ else c_src
+ in
+ returnNat code
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
else
returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0))
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
imm = maybeImm tree
target = case imm of Just x -> x
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP)
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+genJump dsts (StCLbl lbl)
+ | hasDestInfo dsts = panic "genJump(powerpc): CLbl and dsts"
+ | otherwise = returnNat (toOL [BCC ALWAYS lbl])
+
+genJump dsts tree
+ = getRegister tree `thenNat` \ register ->
+ getNewRegNCG PtrRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ target = registerName register tmp
+ in
+ returnNat (code `snocOL` MTCTR target `snocOL` BCTR dsts)
+#endif /* sparc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
AddrLtOp -> (CMP ULT, NE)
AddrLeOp -> (CMP ULE, NE)
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (code `snocOL` JXX cond lbl)
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
)
)
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+genCondJump lbl bool
+ = getCondCode bool `thenNat` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ target = ImmCLbl lbl
+ in
+ returnNat (
+ code `snocOL` BCC cond lbl )
+
+#endif /* powerpc_TARGET_ARCH */
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
in
returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset)))
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (code, reg, sz)
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
,
[v1]
)
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+
+#if darwin_TARGET_OS
+{-
+ The PowerPC calling convention for Darwin/Mac OS X
+ is described in Apple's document
+ "Inside Mac OS X - Mach-O Runtime Architecture".
+ Parameters may be passed in general-purpose registers, in
+ floating point registers, or on the stack. Stack space is
+ always reserved for parameters, even if they are passed in registers.
+ The called routine may choose to save parameters from registers
+ to the corresponding space on the stack.
+ The parameter area should be part of the caller's stack frame,
+ allocated in the caller's prologue code (large enough to hold
+ the parameter lists for all called routines). The NCG already
+ uses the space that we should use as a parameter area for register
+ spilling, so we allocate a new stack frame just before ccalling.
+ That way we don't need to decide beforehand how much space to
+ reserve for parameters.
+-}
+
+genCCall fn cconv kind args
+ = mapNat prepArg args `thenNat` \ preppedArgs ->
+ let
+ (argReps,argCodes,vregs) = unzip3 preppedArgs
+
+ -- size of linkage area + size of arguments, in bytes
+ stackDelta = roundTo16 $ (24 +) $ max 32 $ (4 *) $ sum $ map getPrimRepSize argReps
+ roundTo16 x | x `mod` 16 == 0 = x
+ | otherwise = x + 16 - (x `mod` 16)
+
+ move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
+ move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
+
+ (moveFinalCode,usedRegs) = move_final
+ (zip vregs argReps)
+ allArgRegs allFPArgRegs
+ eXTRA_STK_ARGS_HERE
+ (toOL []) []
+
+ passArguments = concatOL argCodes
+ `appOL` move_sp_down
+ `appOL` moveFinalCode
+ in
+ case fn of
+ Left lbl ->
+ addImportNat lbl `thenNat` \ _ ->
+ returnNat (passArguments
+ `snocOL` BL (ImmLit $ ftext
+ (FSLIT("L_")
+ `appendFS` lbl
+ `appendFS` FSLIT("$stub")))
+ usedRegs
+ `appOL` move_sp_up)
+ Right dyn ->
+ getRegister dyn `thenNat` \ dynReg ->
+ getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
+ returnNat (registerCode dynReg tmp
+ `appOL` passArguments
+ `snocOL` MTCTR (registerName dynReg tmp)
+ `snocOL` BCTRL usedRegs
+ `appOL` move_sp_up)
+ where
+ prepArg arg
+ | is64BitRep (repOfStixExpr arg)
+ = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
+ let r_lo = VirtualRegI vr_lo
+ r_hi = getHiVRegFromLo r_lo
+ in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
+ | otherwise
+ = getRegister arg `thenNat` \ register ->
+ getNewRegNCG (registerRep register) `thenNat` \ tmp ->
+ returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
+ move_final [] _ _ _ accumCode accumUsed = (accumCode, accumUsed)
+ move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
+ | not (is64BitRep rep) =
+ case rep of
+ FloatRep ->
+ move_final vregs (drop 1 gprs) (drop 1 fprs) (stackOffset+4)
+ (accumCode `snocOL`
+ (case fprs of
+ fpr : fprs -> MR fpr vr
+ [] -> ST F vr (AddrRegImm sp (ImmInt stackOffset))))
+ ((take 1 fprs) ++ accumUsed)
+ DoubleRep ->
+ move_final vregs (drop 2 gprs) (drop 1 fprs) (stackOffset+8)
+ (accumCode `snocOL`
+ (case fprs of
+ fpr : fprs -> MR fpr vr
+ [] -> ST DF vr (AddrRegImm sp (ImmInt stackOffset))))
+ ((take 1 fprs) ++ accumUsed)
+ VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
+ _ ->
+ move_final vregs (drop 1 gprs) fprs (stackOffset+4)
+ (accumCode `snocOL`
+ (case gprs of
+ gpr : gprs -> MR gpr vr
+ [] -> ST W vr (AddrRegImm sp (ImmInt stackOffset))))
+ ((take 1 gprs) ++ accumUsed)
+
+ move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
+ | is64BitRep rep =
+ let
+ storeWord vr (gpr:_) offset = MR gpr vr
+ storeWord vr [] offset = ST W vr (AddrRegImm sp (ImmInt offset))
+ in
+ move_final vregs (drop 2 gprs) fprs (stackOffset+8)
+ (accumCode
+ `snocOL` storeWord vr_hi gprs stackOffset
+ `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
+ ((take 2 gprs) ++ accumUsed)
+#else
+
+{-
+ PowerPC Linux uses the System V Release 4 Calling Convention
+ for PowerPC. It is described in the
+ "System V Application Binary Interface PowerPC Processor Supplement".
+
+ Like the Darwin/Mac OS X code above, this allocates a new stack frame
+ so that the parameter area doesn't conflict with the spill slots.
+-}
+
+genCCall fn cconv kind args
+ = mapNat prepArg args `thenNat` \ preppedArgs ->
+ let
+ (argReps,argCodes,vregs) = unzip3 preppedArgs
+
+ -- size of linkage area + size of arguments, in bytes
+ stackDelta = roundTo16 finalStack
+ roundTo16 x | x `mod` 16 == 0 = x
+ | otherwise = x + 16 - (x `mod` 16)
+
+ move_sp_down = toOL [STU W sp (AddrRegImm sp (ImmInt (-stackDelta))), DELTA (-stackDelta)]
+ move_sp_up = toOL [ADD sp sp (RIImm (ImmInt stackDelta)), DELTA 0]
+
+ (moveFinalCode,usedRegs,finalStack) =
+ move_final (zip vregs argReps)
+ allArgRegs allFPArgRegs
+ eXTRA_STK_ARGS_HERE
+ (toOL []) []
+
+ passArguments = concatOL argCodes
+ `appOL` move_sp_down
+ `appOL` moveFinalCode
+ in
+ case fn of
+ Left lbl ->
+ addImportNat lbl `thenNat` \ _ ->
+ returnNat (passArguments
+ `snocOL` BL (ImmLit $ ftext lbl)
+ usedRegs
+ `appOL` move_sp_up)
+ Right dyn ->
+ getRegister dyn `thenNat` \ dynReg ->
+ getNewRegNCG (registerRep dynReg) `thenNat` \ tmp ->
+ returnNat (registerCode dynReg tmp
+ `appOL` passArguments
+ `snocOL` MTCTR (registerName dynReg tmp)
+ `snocOL` BCTRL usedRegs
+ `appOL` move_sp_up)
+ where
+ prepArg arg
+ | is64BitRep (repOfStixExpr arg)
+ = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) ->
+ let r_lo = VirtualRegI vr_lo
+ r_hi = getHiVRegFromLo r_lo
+ in returnNat (repOfStixExpr arg, code, Right (r_hi,r_lo))
+ | otherwise
+ = getRegister arg `thenNat` \ register ->
+ getNewRegNCG (registerRep register) `thenNat` \ tmp ->
+ returnNat (registerRep register, registerCode register tmp, Left (registerName register tmp))
+ move_final [] _ _ stackOffset accumCode accumUsed = (accumCode, accumUsed, stackOffset)
+ move_final ((Left vr,rep):vregs) gprs fprs stackOffset accumCode accumUsed
+ | not (is64BitRep rep) =
+ case rep of
+ FloatRep ->
+ case fprs of
+ fpr : fprs' -> move_final vregs gprs fprs' stackOffset
+ (accumCode `snocOL` MR fpr vr)
+ (fpr : accumUsed)
+ [] -> move_final vregs gprs fprs (stackOffset+4)
+ (accumCode `snocOL`
+ ST F vr (AddrRegImm sp (ImmInt stackOffset)))
+ accumUsed
+ DoubleRep ->
+ case fprs of
+ fpr : fprs' -> move_final vregs gprs fprs' stackOffset
+ (accumCode `snocOL` MR fpr vr)
+ (fpr : accumUsed)
+ [] -> move_final vregs gprs fprs (stackOffset+8)
+ (accumCode `snocOL`
+ ST DF vr (AddrRegImm sp (ImmInt stackOffset)))
+ accumUsed
+ VoidRep -> panic "MachCode.genCCall(powerpc): void parameter"
+ _ ->
+ case gprs of
+ gpr : gprs' -> move_final vregs gprs' fprs stackOffset
+ (accumCode `snocOL` MR gpr vr)
+ (gpr : accumUsed)
+ [] -> move_final vregs gprs fprs (stackOffset+4)
+ (accumCode `snocOL`
+ ST W vr (AddrRegImm sp (ImmInt stackOffset)))
+ accumUsed
+
+ move_final ((Right (vr_hi,vr_lo),rep):vregs) gprs fprs stackOffset accumCode accumUsed
+ | is64BitRep rep =
+ case gprs of
+ hireg : loreg : regs | even (length gprs) ->
+ move_final vregs regs fprs stackOffset
+ (regCode hireg loreg) accumUsed
+ _skipped : hireg : loreg : regs ->
+ move_final vregs regs fprs stackOffset
+ (regCode hireg loreg) accumUsed
+ _ -> -- only one or no regs left
+ move_final vregs [] fprs (stackOffset+8)
+ stackCode accumUsed
+ where
+ stackCode =
+ accumCode
+ `snocOL` ST W vr_hi (AddrRegImm sp (ImmInt stackOffset))
+ `snocOL` ST W vr_lo (AddrRegImm sp (ImmInt (stackOffset+4)))
+ regCode hireg loreg =
+ accumCode
+ `snocOL` MR hireg vr_hi
+ `snocOL` MR loreg vr_lo
+
+#endif
+
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
#if alpha_TARGET_ARCH
condIntReg = panic "MachCode.condIntReg (not on Alpha)"
condFltReg = panic "MachCode.condFltReg (not on Alpha)"
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (Any IntRep code__2)
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (Any IntRep code__2)
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+condIntReg cond x y
+ = getNatLabelNCG `thenNat` \ lbl ->
+ condIntCode cond x y `thenNat` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
+ BCC cond lbl,
+ LI dst (ImmInt 0),
+ LABEL lbl]
+ in
+ returnNat (Any IntRep code__2)
+
+condFltReg cond x y
+ = getNatLabelNCG `thenNat` \ lbl ->
+ condFltCode cond x y `thenNat` \ condition ->
+ let
+ code = condCode condition
+ cond = condName condition
+ code__2 dst = (LI dst (ImmInt 1) `consOL` code) `appOL` toOL [
+ BCC cond lbl,
+ LI dst (ImmInt 0),
+ LABEL lbl]
+ in
+ returnNat (Any IntRep code__2)
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
,IF_ARCH_i386 ((Operand -> Operand -> Instr)
-> Maybe (Operand -> Operand -> Instr)
,IF_ARCH_sparc((Reg -> RI -> Reg -> Instr)
- ,)))
+ ,IF_ARCH_powerpc((Reg -> Reg -> RI -> Instr)
+ ,))))
-> StixExpr -> StixExpr -- the two arguments
-> NatM Register
-> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr)
,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr)
,IF_ARCH_i386 ((Size -> Reg -> Reg -> Reg -> Instr)
- ,)))
+ ,IF_ARCH_powerpc((Size -> Reg -> Reg -> Reg -> Instr)
+ ,))))
-> StixExpr -> StixExpr -- the two arguments
-> NatM Register
:: IF_ARCH_alpha((RI -> Reg -> Instr)
,IF_ARCH_i386 ((Operand -> Instr)
,IF_ARCH_sparc((RI -> Reg -> Instr)
- ,)))
+ ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
+ ,))))
-> StixExpr -- the one argument
-> NatM Register
-> IF_ARCH_alpha((Reg -> Reg -> Instr)
,IF_ARCH_i386 ((Reg -> Reg -> Instr)
,IF_ARCH_sparc((Reg -> Reg -> Instr)
- ,)))
+ ,IF_ARCH_powerpc((Reg -> Reg -> Instr)
+ ,))))
-> StixExpr -- the one argument
-> NatM Register
in
returnNat (Any DoubleRep code__2)
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (Any pk code__2)
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (Any pk code__2)
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+trivialCode instr x (StInt y)
+ | fits16Bits y
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src1 = registerName register tmp
+ src2 = ImmInt (fromInteger y)
+ code__2 dst = code `snocOL` instr dst src1 (RIImm src2)
+ in
+ returnNat (Any IntRep code__2)
+
+trivialCode instr x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+ code__2 dst = code1 `appOL` code2 `snocOL`
+ instr dst src1 (RIReg src2)
+ in
+ returnNat (Any IntRep code__2)
+
+trivialCode2 :: (Reg -> Reg -> Reg -> Instr)
+ -> StixExpr -> StixExpr -> NatM Register
+trivialCode2 instr x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+ code__2 dst = code1 `appOL` code2 `snocOL`
+ instr dst src1 src2
+ in
+ returnNat (Any IntRep code__2)
+
+trivialFCode pk instr x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG (registerRep register1)
+ `thenNat` \ tmp1 ->
+ getNewRegNCG (registerRep register2)
+ `thenNat` \ tmp2 ->
+ -- getNewRegNCG DoubleRep `thenNat` \ tmp ->
+ let
+ -- promote x = FxTOy F DF x tmp
+
+ pk1 = registerRep register1
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+
+ pk2 = registerRep register2
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+
+ dstRep = if pk1 == FloatRep && pk2 == FloatRep then FloatRep else DoubleRep
+
+ code__2 dst =
+ code1 `appOL` code2 `snocOL`
+ instr (primRepToSize dstRep) dst src1 src2
+ in
+ returnNat (Any dstRep code__2)
+
+trivialUCode instr x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code `snocOL` instr dst src
+ in
+ returnNat (Any IntRep code__2)
+trivialUFCode pk instr x
+ = getRegister x `thenNat` \ register ->
+ getNewRegNCG (registerRep register)
+ `thenNat` \ tmp ->
+ let
+ code = registerCode register tmp
+ src = registerName register tmp
+ code__2 dst = code `snocOL` instr dst src
+ in
+ returnNat (Any pk code__2)
+
+-- There is no "remainder" instruction on the PPC, so we have to do
+-- it the hard way.
+-- The "div" parameter is the division instruction to use (DIVW or DIVWU)
+
+remainderCode :: (Reg -> Reg -> Reg -> Instr)
+ -> StixExpr -> StixExpr -> NatM Register
+remainderCode div x y
+ = getRegister x `thenNat` \ register1 ->
+ getRegister y `thenNat` \ register2 ->
+ getNewRegNCG IntRep `thenNat` \ tmp1 ->
+ getNewRegNCG IntRep `thenNat` \ tmp2 ->
+ let
+ code1 = registerCode register1 tmp1
+ src1 = registerName register1 tmp1
+ code2 = registerCode register2 tmp2
+ src2 = registerName register2 tmp2
+ code__2 dst = code1 `appOL` code2 `appOL` toOL [
+ div dst src1 src2,
+ MULLW dst dst (RIReg src2),
+ SUBF dst dst src1
+ ]
+ in
+ returnNat (Any IntRep code__2)
+
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
in
returnNat (Any IntRep code__2)
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86"
coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86"
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
returnNat (Any DoubleRep
(\dst -> code `snocOL` FxTOy F DF src dst))
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
+
+#if powerpc_TARGET_ARCH
+coerceInt2FP pk x
+ = ASSERT(pk == DoubleRep)
+ getRegister x `thenNat` \ register ->
+ getNewRegNCG IntRep `thenNat` \ reg ->
+ getNatLabelNCG `thenNat` \ lbl ->
+ getNewRegNCG PtrRep `thenNat` \ itmp ->
+ getNewRegNCG DoubleRep `thenNat` \ ftmp ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+ code__2 dst = code `appOL` toOL [
+ SEGMENT RoDataSegment,
+ LABEL lbl,
+ DATA W [ImmInt 0x43300000, ImmInt 0x80000000],
+ SEGMENT TextSegment,
+ XORIS itmp src (ImmInt 0x8000),
+ ST W itmp (spRel (-1)),
+ LIS itmp (ImmInt 0x4330),
+ ST W itmp (spRel (-2)),
+ LD DF ftmp (spRel (-2)),
+ LIS itmp (HA (ImmCLbl lbl)),
+ LD DF dst (AddrRegImm itmp (LO (ImmCLbl lbl))),
+ FSUB DF dst ftmp dst
+ ]
+ in
+ returnNat (Any DoubleRep code__2)
+
+coerceFP2Int fprep x
+ = ASSERT(fprep == DoubleRep || fprep == FloatRep)
+ getRegister x `thenNat` \ register ->
+ getNewRegNCG fprep `thenNat` \ reg ->
+ getNewRegNCG DoubleRep `thenNat` \ tmp ->
+ let
+ code = registerCode register reg
+ src = registerName register reg
+ code__2 dst = code `appOL` toOL [
+ -- convert to int in FP reg
+ FCTIWZ tmp src,
+ -- store value (64bit) from FP to stack
+ ST DF tmp (spRel (-2)),
+ -- read low word of value (high word is undefined)
+ LD W dst (spRel (-1))]
+ in
+ returnNat (Any IntRep code__2)
+coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt"
+coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl"
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
projects / ghc-hetmet.git / blobdiff