#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,
StixReg(..), pprStixReg, StixVReg(..), CodeSegment(..),
DestInfo, hasDestInfo,
pprStixExpr, repOfStixExpr,
- liftStrings,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
- getDeltaNat, setDeltaNat, getUniqueNat,
- IF_OS_darwin(addImportNat COMMA,)
+ 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 Outputable ( assertPanic )
import FastString
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
iselExpr64 expr
= pprPanic "iselExpr64(powerpc)" (pprStixExpr expr)
-#endif {- powerpc_TARGET_ARCH -}
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
-#endif {- i386_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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
MO_16S_to_NatS -> integerExtend True 16 x
MO_8U_to_32U -> integerExtend False 24 x
- other -> pprPanic "getRegister(powerpc) - unary StMachOp"
- (pprMachOp mop)
+ 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 (
= 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_Dbl_Le -> condFltReg LE x y
MO_Nat_Add -> trivialCode ADD x y
- MO_Nat_Sub -> trivialCode SUBF y x
+ 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_NatS_Mul -> trivialCode (SMUL False) x y
- MO_NatU_Mul -> trivialCode (UMUL False) x y
- MO_NatS_MulMayOflo -> imulMayOflo x y
- imulMayOflo
- -- ToDo: teach about V8+ SPARC div instructions
- MO_NatS_Quot -> idiv FSLIT(".div") x y
- MO_NatS_Rem -> idiv FSLIT(".rem") x y
- MO_NatU_Quot -> idiv FSLIT(".udiv") x y
- MO_NatU_Rem -> idiv FSLIT(".urem") 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_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
- [promote x, promote y])
- where promote x = StMachOp MO_Flt_to_Dbl [x]
+ [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)
where
imm = maybeImm leaf
imm__2 = case imm of Just x -> x
-#endif {- powerpc_TARGET_ARCH -}
+#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])
off = ImmInt 0
in
returnNat (Amode (AddrRegImm reg off) code)
-#endif {- powerpc_TARGET_ARCH -}
+#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 */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
getCondCode other = pprPanic "getCondCode(2)(x86,sparc,powerpc)" (pprStixExpr other)
-#endif {- i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH -}
+#endif /* i386_TARGET_ARCH || sparc_TARGET_ARCH || powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
#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 */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat (CondCode True cond code__2)
-#endif {- sparc_TARGET_ARCH -}
+#endif /* sparc_TARGET_ARCH */
#if powerpc_TARGET_ARCH
in
returnNat (CondCode False cond code__2)
-#endif {- powerpc_TARGET_ARCH -}
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
returnNat code__2
-#endif {- alpha_TARGET_ARCH -}
+#endif /* alpha_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
in
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
in
returnNat code__2
-#endif {- powerpc_TARGET_ARCH -}
+#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
src__2 = registerName register tmp1
pk__2 = registerRep register
- sz__2 = primRepToSize pk__2
- code__2 = if pk__2 == DoubleRep || pk == pk__2
- then code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
- else panic "###PPC MachCode.assignMem_FltCode: FloatRep"
- {- code__2 = code1 `appOL` code2 `appOL`
- if pk == pk__2
- then unitOL (ST sz src__2 dst__2)
- else toOL [FxTOy sz__2 sz src__2 tmp1, ST sz tmp1 dst__2] -}
+ code__2 = code1 `appOL` code2 `snocOL` ST sz src__2 dst__2
in
returnNat code__2
else c_src
in
returnNat code
-#endif {- powerpc_TARGET_ARCH -}
+#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)
- = returnNat (toOL [BCC ALWAYS lbl])
+ | hasDestInfo dsts = panic "genJump(powerpc): CLbl and dsts"
+ | otherwise = returnNat (toOL [BCC ALWAYS lbl])
genJump dsts tree
= getRegister tree `thenNat` \ register ->
code = registerCode register tmp
target = registerName register tmp
in
- returnNat (code `snocOL` MTCTR target `snocOL` BCTR)
-#endif {- sparc_TARGET_ARCH -}
+ returnNat (code `snocOL` MTCTR target `snocOL` BCTR dsts)
+#endif /* sparc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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
returnNat (
code `snocOL` BCC cond lbl )
-#endif {- powerpc_TARGET_ARCH -}
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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 (at least for Darwin/Mac OS X)
+ 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
`snocOL` storeWord vr_hi gprs stackOffset
`snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
((take 2 gprs) ++ accumUsed)
-#endif {- powerpc_TARGET_ARCH -}
+#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
LABEL lbl]
in
returnNat (Any IntRep code__2)
-#endif {- powerpc_TARGET_ARCH -}
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
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)
code2 = registerCode register2 tmp2
src2 = registerName register2 tmp2
+ dstRep = if pk1 == FloatRep && pk2 == FloatRep then FloatRep else DoubleRep
+
code__2 dst =
- if pk1 == pk2 then
code1 `appOL` code2 `snocOL`
- instr (primRepToSize pk) dst src1 src2
- else panic "###PPC MachCode.trivialFCode: type mismatch"
+ instr (primRepToSize dstRep) dst src1 src2
in
- returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) code__2)
+ returnNat (Any dstRep code__2)
trivialUCode instr x
= getRegister x `thenNat` \ register ->
code__2 dst = code `snocOL` instr dst src
in
returnNat (Any IntRep code__2)
-trivialUFCode pk instr x = panic "###PPC MachCode.trivialUFCode"
-#endif {- powerpc_TARGET_ARCH -}
+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 = panic "###PPC MachCode.coerceInt2FP"
-coerceFP2Int fprep x = panic "###PPC MachCode.coerceFP2Int"
+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 -}
+#endif /* powerpc_TARGET_ARCH */
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
\end{code}
projects / ghc-hetmet.git / blobdiff