X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=2876efd36184a9d222bbc9f7279c2dad947682fb;hb=553e90d9a32ee1b1809430f260c401cc4169c6c7;hp=fe8bc6776be3b8f10a8258ad059e824653698548;hpb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index fe8bc67..2876efd 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -14,7 +14,6 @@ module MachCode ( stmtsToInstrs, InstrBlock ) where #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, @@ -29,15 +28,18 @@ import CLabel ( isAsmTemp ) #endif import Maybes ( maybeToBool ) import PrimRep ( isFloatingRep, is64BitRep, PrimRep(..), - getPrimRepArrayElemSize ) +#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 ) @@ -47,10 +49,12 @@ import qualified Outputable 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} @@ -131,7 +135,7 @@ stmtToInstrs stmt = case stmt of -- the linker can handle simple arithmetic... getData (StIndex rep (StCLbl lbl) (StInt off)) = returnNat (nilOL, - ImmIndex lbl (fromInteger off * getPrimRepArrayElemSize rep)) + ImmIndex lbl (fromInteger off * getPrimRepSizeInBytes rep)) -- Top-level lifted-out string. The segment will already have been set -- (see Stix.liftStrings). @@ -185,7 +189,7 @@ mangleIndexTree :: StixExpr -> StixExpr mangleIndexTree (StIndex pk base (StInt i)) = StMachOp MO_Nat_Add [base, off] where - off = StInt (i * toInteger (getPrimRepArrayElemSize pk)) + off = StInt (i * toInteger (getPrimRepSizeInBytes pk)) mangleIndexTree (StIndex pk base off) = StMachOp MO_Nat_Add [ @@ -196,7 +200,7 @@ mangleIndexTree (StIndex pk base off) ] where shift :: PrimRep -> Int - shift rep = case getPrimRepArrayElemSize rep of + shift rep = case getPrimRepSizeInBytes rep of 1 -> 0 2 -> 1 4 -> 2 @@ -211,7 +215,7 @@ maybeImm :: StixExpr -> Maybe Imm maybeImm (StCLbl l) = Just (ImmCLbl l) maybeImm (StIndex rep (StCLbl l) (StInt off)) - = Just (ImmIndex l (fromInteger off * getPrimRepArrayElemSize rep)) + = Just (ImmIndex l (fromInteger off * getPrimRepSizeInBytes rep)) maybeImm (StInt i) | i >= toInteger (minBound::Int) && i <= toInteger (maxBound::Int) = Just (ImmInt (fromInteger i)) @@ -340,7 +344,7 @@ iselExpr64 (StCall fn cconv kind args) iselExpr64 expr = pprPanic "iselExpr64(i386)" (pprStixExpr expr) -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -432,7 +436,95 @@ iselExpr64 (StCall fn cconv kind args) 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 */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -533,8 +625,8 @@ getRegister (StCall fn cconv kind args) 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 -> @@ -556,6 +648,10 @@ getRegister (StString s) 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) @@ -793,7 +889,7 @@ getRegister leaf imm = maybeImm leaf imm__2 = case imm of Just x -> x -#endif {- alpha_TARGET_ARCH -} +#endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -862,8 +958,10 @@ getRegister (StMachOp mop [x]) -- unary MachOps 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 MO_NatS_to_NatU -> conversionNop WordRep x @@ -1205,7 +1303,7 @@ getRegister leaf imm = maybeImm leaf imm__2 = case imm of Just x -> x -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1257,7 +1355,9 @@ getRegister (StMachOp mop [x]) -- unary PrimOps -- 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 MO_NatU_to_NatS -> conversionNop IntRep x MO_NatS_to_NatU -> conversionNop WordRep x @@ -1459,7 +1559,233 @@ getRegister leaf 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 */ + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1540,7 +1866,7 @@ getAmode other in returnNat (Amode (AddrReg reg) code) -#endif {- alpha_TARGET_ARCH -} +#endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1608,7 +1934,7 @@ getAmode other in returnNat (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1672,7 +1998,53 @@ getAmode other 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} @@ -1701,11 +2073,11 @@ getCondCode :: StixExpr -> NatM CondCode #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]) @@ -1744,11 +2116,12 @@ 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} @@ -1764,7 +2137,7 @@ condIntCode, condFltCode :: Cond -> StixExpr -> StixExpr -> NatM CondCode #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 @@ -1910,7 +2283,7 @@ condFltCode cond x y -- 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 */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1974,9 +2347,59 @@ condFltCode cond x y 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} @@ -2033,7 +2456,7 @@ assignIntCode pk dst src in returnNat code__2 -#endif {- alpha_TARGET_ARCH -} +#endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2115,13 +2538,13 @@ assignReg_IntCode pk reg src 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 */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2144,8 +2567,9 @@ assignMem_IntCode pk addr src 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 @@ -2154,7 +2578,38 @@ assignReg_IntCode pk reg src 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} @@ -2194,7 +2649,7 @@ assignFltCode pk dst src in returnNat code__2 -#endif {- alpha_TARGET_ARCH -} +#endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2239,7 +2694,7 @@ assignReg_FltCode pk reg src returnNat code -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2294,7 +2749,45 @@ assignReg_FltCode pk reg src 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} @@ -2339,7 +2832,7 @@ genJump tree else returnNat (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) -#endif {- alpha_TARGET_ARCH -} +#endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2369,7 +2862,7 @@ genJump dsts tree imm = maybeImm tree target = case imm of Just x -> x -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2391,7 +2884,24 @@ genJump dsts tree 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} @@ -2570,7 +3080,7 @@ genCondJump lbl (StPrim op [x, y]) AddrLtOp -> (CMP ULT, NE) AddrLeOp -> (CMP ULE, NE) -#endif {- alpha_TARGET_ARCH -} +#endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2584,7 +3094,7 @@ genCondJump lbl bool in returnNat (code `snocOL` JXX cond lbl) -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2606,7 +3116,23 @@ genCondJump lbl bool ) ) -#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} @@ -2700,7 +3226,7 @@ genCCall fn cconv kind args in returnNat (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) -#endif {- alpha_TARGET_ARCH -} +#endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2812,7 +3338,7 @@ genCCall fn cconv ret_rep args in returnNat (code, reg, sz) -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2867,8 +3393,8 @@ genCCall fn cconv kind args let argcode = concatOL argcodes (move_sp_down, move_sp_up) - = let nn = length vregs - n_argRegs - + 1 -- (for the road) + = let diff = length vregs - n_argRegs + nn = if odd diff then diff + 1 else diff -- keep 8-byte alignment in if nn <= 0 then (nilOL, nilOL) else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) @@ -2888,8 +3414,8 @@ genCCall fn cconv kind args -- ToDo:needed (WDP 96/03) ??? fn_static = unLeft fn fn__2 = case (headFS fn_static) of - '.' -> ImmLit (ptext fn_static) - _ -> ImmLab False (ptext fn_static) + '.' -> ImmLit (ftext fn_static) + _ -> ImmLab False (ftext fn_static) -- move args from the integer vregs into which they have been -- marshalled, into %o0 .. %o5, and the rest onto the stack. @@ -2953,7 +3479,237 @@ genCCall fn cconv kind args , [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} @@ -2984,7 +3740,7 @@ condIntReg, condFltReg :: Cond -> StixExpr -> StixExpr -> NatM Register #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 */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3020,7 +3776,7 @@ condFltReg cond x y in returnNat (Any IntRep code__2) -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3119,7 +3875,35 @@ condFltReg cond x y 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} @@ -3145,7 +3929,8 @@ trivialCode ,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 @@ -3154,7 +3939,8 @@ trivialFCode -> 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 @@ -3162,7 +3948,8 @@ trivialUCode :: 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 @@ -3171,7 +3958,8 @@ trivialUFCode -> 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 @@ -3245,7 +4033,7 @@ trivialUFCode _ instr x in returnNat (Any DoubleRep code__2) -#endif {- alpha_TARGET_ARCH -} +#endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3426,7 +4214,7 @@ trivialUFCode pk instr x in returnNat (Any pk code__2) -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3514,7 +4302,125 @@ trivialUFCode pk instr x 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} @@ -3576,7 +4482,7 @@ coerceFP2Int x in returnNat (Any IntRep code__2) -#endif {- alpha_TARGET_ARCH -} +#endif /* alpha_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3611,7 +4517,7 @@ coerceFP2Int fprep x coerceDbl2Flt x = panic "MachCode.coerceDbl2Flt: unused on x86" coerceFlt2Dbl x = panic "MachCode.coerceFlt2Dbl: unused on x86" -#endif {- i386_TARGET_ARCH -} +#endif /* i386_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3667,7 +4573,56 @@ coerceFlt2Dbl x 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}