X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=ffb603efe2cb77dcc3b657ba6720b2f51708e4ef;hb=5da4371c03fe13a85d84b17f58ed33895ea473bd;hp=3c89799cbdb1dc114fb0341d78c121d5654a6420;hpb=c50d5acc8e9cd98bbb960d0149f104066d0c49b3;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 3c89799..ffb603e 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -29,7 +29,10 @@ 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, @@ -48,8 +51,9 @@ import CmdLineOpts ( opt_Static ) import Stix ( pprStixStmt ) -- DEBUGGING ONLY -import IOExts ( trace ) import Outputable ( assertPanic ) +import FastString +import TRACE ( trace ) infixr 3 `bind` \end{code} @@ -130,12 +134,12 @@ 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). StDataString str - -> returnNat (unitOL (ASCII True (_UNPK_ str))) + -> returnNat (unitOL (ASCII True (unpackFS str))) #ifdef DEBUG other -> pprPanic "stmtToInstrs" (pprStixStmt other) @@ -184,7 +188,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 [ @@ -195,7 +199,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 @@ -210,7 +214,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)) @@ -432,6 +436,94 @@ iselExpr64 expr = pprPanic "iselExpr64(sparc)" (pprStixExpr expr) #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 r3 + mov_hi = MR r_dst_hi r4 + 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 -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -532,8 +624,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 -> @@ -543,7 +635,7 @@ getRegister (StString s) code dst = toOL [ SEGMENT RoDataSegment, LABEL lbl, - ASCII True (_UNPK_ s), + ASCII True (unpackFS s), SEGMENT TextSegment, #if alpha_TARGET_ARCH LDA dst (AddrImm imm_lbl) @@ -555,6 +647,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) @@ -600,30 +696,30 @@ getRegister (StPrim primop [x]) -- unary PrimOps other_op -> getRegister (StCall fn CCallConv DoubleRep [x]) where fn = case other_op of - FloatExpOp -> SLIT("exp") - FloatLogOp -> SLIT("log") - FloatSqrtOp -> SLIT("sqrt") - FloatSinOp -> SLIT("sin") - FloatCosOp -> SLIT("cos") - FloatTanOp -> SLIT("tan") - FloatAsinOp -> SLIT("asin") - FloatAcosOp -> SLIT("acos") - FloatAtanOp -> SLIT("atan") - FloatSinhOp -> SLIT("sinh") - FloatCoshOp -> SLIT("cosh") - FloatTanhOp -> SLIT("tanh") - DoubleExpOp -> SLIT("exp") - DoubleLogOp -> SLIT("log") - DoubleSqrtOp -> SLIT("sqrt") - DoubleSinOp -> SLIT("sin") - DoubleCosOp -> SLIT("cos") - DoubleTanOp -> SLIT("tan") - DoubleAsinOp -> SLIT("asin") - DoubleAcosOp -> SLIT("acos") - DoubleAtanOp -> SLIT("atan") - DoubleSinhOp -> SLIT("sinh") - DoubleCoshOp -> SLIT("cosh") - DoubleTanhOp -> SLIT("tanh") + FloatExpOp -> FSLIT("exp") + FloatLogOp -> FSLIT("log") + FloatSqrtOp -> FSLIT("sqrt") + FloatSinOp -> FSLIT("sin") + FloatCosOp -> FSLIT("cos") + FloatTanOp -> FSLIT("tan") + FloatAsinOp -> FSLIT("asin") + FloatAcosOp -> FSLIT("acos") + FloatAtanOp -> FSLIT("atan") + FloatSinhOp -> FSLIT("sinh") + FloatCoshOp -> FSLIT("cosh") + FloatTanhOp -> FSLIT("tanh") + DoubleExpOp -> FSLIT("exp") + DoubleLogOp -> FSLIT("log") + DoubleSqrtOp -> FSLIT("sqrt") + DoubleSinOp -> FSLIT("sin") + DoubleCosOp -> FSLIT("cos") + DoubleTanOp -> FSLIT("tan") + DoubleAsinOp -> FSLIT("asin") + DoubleAcosOp -> FSLIT("acos") + DoubleAtanOp -> FSLIT("atan") + DoubleSinhOp -> FSLIT("sinh") + DoubleCoshOp -> FSLIT("cosh") + DoubleTanhOp -> FSLIT("tanh") where pr = panic "MachCode.getRegister: no primrep needed for Alpha" @@ -707,8 +803,8 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - FloatPowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y]) - DoublePowerOp -> getRegister (StCall SLIT("pow") CCallConv DoubleRep [x,y]) + FloatPowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) + DoublePowerOp -> getRegister (StCall FSLIT("pow") CCallConv DoubleRep [x,y]) where {- ------------------------------------------------------------ Some bizarre special code for getting condition codes into @@ -861,8 +957,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 @@ -902,27 +1000,27 @@ getRegister (StMachOp mop [x]) -- unary MachOps demote x = StMachOp MO_Dbl_to_Flt [x] (is_float_op, fn) = case mop of - MO_Flt_Exp -> (True, SLIT("exp")) - MO_Flt_Log -> (True, SLIT("log")) + MO_Flt_Exp -> (True, FSLIT("exp")) + MO_Flt_Log -> (True, FSLIT("log")) - MO_Flt_Asin -> (True, SLIT("asin")) - MO_Flt_Acos -> (True, SLIT("acos")) - MO_Flt_Atan -> (True, SLIT("atan")) + MO_Flt_Asin -> (True, FSLIT("asin")) + MO_Flt_Acos -> (True, FSLIT("acos")) + MO_Flt_Atan -> (True, FSLIT("atan")) - MO_Flt_Sinh -> (True, SLIT("sinh")) - MO_Flt_Cosh -> (True, SLIT("cosh")) - MO_Flt_Tanh -> (True, SLIT("tanh")) + MO_Flt_Sinh -> (True, FSLIT("sinh")) + MO_Flt_Cosh -> (True, FSLIT("cosh")) + MO_Flt_Tanh -> (True, FSLIT("tanh")) - MO_Dbl_Exp -> (False, SLIT("exp")) - MO_Dbl_Log -> (False, SLIT("log")) + MO_Dbl_Exp -> (False, FSLIT("exp")) + MO_Dbl_Log -> (False, FSLIT("log")) - MO_Dbl_Asin -> (False, SLIT("asin")) - MO_Dbl_Acos -> (False, SLIT("acos")) - MO_Dbl_Atan -> (False, SLIT("atan")) + MO_Dbl_Asin -> (False, FSLIT("asin")) + MO_Dbl_Acos -> (False, FSLIT("acos")) + MO_Dbl_Atan -> (False, FSLIT("atan")) - MO_Dbl_Sinh -> (False, SLIT("sinh")) - MO_Dbl_Cosh -> (False, SLIT("cosh")) - MO_Dbl_Tanh -> (False, SLIT("tanh")) + MO_Dbl_Sinh -> (False, FSLIT("sinh")) + MO_Dbl_Cosh -> (False, FSLIT("cosh")) + MO_Dbl_Tanh -> (False, FSLIT("tanh")) other -> pprPanic "getRegister(x86) - binary StMachOp (2)" (pprMachOp mop) @@ -997,10 +1095,10 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps MO_Nat_Sar -> shift_code (SAR L) x y {-False-} MO_Flt_Pwr -> getRegister (demote - (StCall (Left SLIT("pow")) CCallConv DoubleRep + (StCall (Left FSLIT("pow")) CCallConv DoubleRep [promote x, promote y]) ) - MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep [x, y]) other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop) where @@ -1089,7 +1187,7 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps code_val `snocOL` MOV L (OpReg src_val) r_dst `appOL` toOL [ - COMMENT (_PK_ "begin shift sequence"), + COMMENT (mkFastString "begin shift sequence"), MOV L (OpReg src_val) r_dst, MOV L (OpReg src_amt) r_tmp, @@ -1118,7 +1216,7 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps instr (ImmInt 1) r_dst, LABEL lbl_after, - COMMENT (_PK_ "end shift sequence") + COMMENT (mkFastString "end shift sequence") ] in returnNat (Any IntRep code__2) @@ -1256,7 +1354,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 @@ -1290,37 +1390,37 @@ getRegister (StMachOp mop [x]) -- unary PrimOps (is_float_op, fn) = case mop of - MO_Flt_Exp -> (True, SLIT("exp")) - MO_Flt_Log -> (True, SLIT("log")) - MO_Flt_Sqrt -> (True, SLIT("sqrt")) + MO_Flt_Exp -> (True, FSLIT("exp")) + MO_Flt_Log -> (True, FSLIT("log")) + MO_Flt_Sqrt -> (True, FSLIT("sqrt")) - MO_Flt_Sin -> (True, SLIT("sin")) - MO_Flt_Cos -> (True, SLIT("cos")) - MO_Flt_Tan -> (True, SLIT("tan")) + MO_Flt_Sin -> (True, FSLIT("sin")) + MO_Flt_Cos -> (True, FSLIT("cos")) + MO_Flt_Tan -> (True, FSLIT("tan")) - MO_Flt_Asin -> (True, SLIT("asin")) - MO_Flt_Acos -> (True, SLIT("acos")) - MO_Flt_Atan -> (True, SLIT("atan")) + MO_Flt_Asin -> (True, FSLIT("asin")) + MO_Flt_Acos -> (True, FSLIT("acos")) + MO_Flt_Atan -> (True, FSLIT("atan")) - MO_Flt_Sinh -> (True, SLIT("sinh")) - MO_Flt_Cosh -> (True, SLIT("cosh")) - MO_Flt_Tanh -> (True, SLIT("tanh")) + MO_Flt_Sinh -> (True, FSLIT("sinh")) + MO_Flt_Cosh -> (True, FSLIT("cosh")) + MO_Flt_Tanh -> (True, FSLIT("tanh")) - MO_Dbl_Exp -> (False, SLIT("exp")) - MO_Dbl_Log -> (False, SLIT("log")) - MO_Dbl_Sqrt -> (False, SLIT("sqrt")) + MO_Dbl_Exp -> (False, FSLIT("exp")) + MO_Dbl_Log -> (False, FSLIT("log")) + MO_Dbl_Sqrt -> (False, FSLIT("sqrt")) - MO_Dbl_Sin -> (False, SLIT("sin")) - MO_Dbl_Cos -> (False, SLIT("cos")) - MO_Dbl_Tan -> (False, SLIT("tan")) + MO_Dbl_Sin -> (False, FSLIT("sin")) + MO_Dbl_Cos -> (False, FSLIT("cos")) + MO_Dbl_Tan -> (False, FSLIT("tan")) - MO_Dbl_Asin -> (False, SLIT("asin")) - MO_Dbl_Acos -> (False, SLIT("acos")) - MO_Dbl_Atan -> (False, SLIT("atan")) + MO_Dbl_Asin -> (False, FSLIT("asin")) + MO_Dbl_Acos -> (False, FSLIT("acos")) + MO_Dbl_Atan -> (False, FSLIT("atan")) - MO_Dbl_Sinh -> (False, SLIT("sinh")) - MO_Dbl_Cosh -> (False, SLIT("cosh")) - MO_Dbl_Tanh -> (False, SLIT("tanh")) + MO_Dbl_Sinh -> (False, FSLIT("sinh")) + MO_Dbl_Cosh -> (False, FSLIT("cosh")) + MO_Dbl_Tanh -> (False, FSLIT("tanh")) other -> pprPanic "getRegister(sparc) - binary StMachOp (2)" (pprMachOp mop) @@ -1370,10 +1470,10 @@ getRegister (StMachOp mop [x, y]) -- dyadic PrimOps MO_NatS_MulMayOflo -> imulMayOflo x y -- ToDo: teach about V8+ SPARC div instructions - MO_NatS_Quot -> idiv SLIT(".div") x y - MO_NatS_Rem -> idiv SLIT(".rem") x y - MO_NatU_Quot -> idiv SLIT(".udiv") x y - MO_NatU_Rem -> idiv SLIT(".urem") x y + 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 @@ -1393,10 +1493,10 @@ getRegister (StMachOp mop [x, y]) -- dyadic PrimOps MO_Nat_Shr -> trivialCode SRL x y MO_Nat_Sar -> trivialCode SRA x y - MO_Flt_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep + MO_Flt_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep [promote x, promote y]) where promote x = StMachOp MO_Flt_to_Dbl [x] - MO_Dbl_Pwr -> getRegister (StCall (Left SLIT("pow")) CCallConv DoubleRep + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep [x, y]) other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop) @@ -1460,6 +1560,194 @@ getRegister leaf #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 + + other -> pprPanic "getRegister(powerpc) - unary StMachOp" + (pprMachOp mop) + 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) + +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 -> trivialCode SUBF y x + + MO_NatS_Mul -> trivialCode MULLW x y + MO_NatU_Mul -> trivialCode MULLW x y + + MO_NatS_Quot -> trivialCode2 DIVW x y + MO_NatU_Quot -> trivialCode2 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_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 + [promote x, promote y]) + where promote x = StMachOp MO_Flt_to_Dbl [x] + 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 -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} @@ -1673,6 +1961,52 @@ getAmode other #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} @@ -1704,7 +2038,7 @@ getCondCode = panic "MachCode.getCondCode: not on Alphas" -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#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]) @@ -1743,11 +2077,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} @@ -1977,6 +2312,56 @@ condFltCode cond x y #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 -} + + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} @@ -2114,7 +2499,7 @@ 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 @@ -2143,8 +2528,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 @@ -2155,6 +2541,37 @@ assignReg_IntCode pk reg src #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} @@ -2295,6 +2712,51 @@ assignReg_FltCode pk reg src #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 + 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] -} + 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} @@ -2392,6 +2854,22 @@ genJump dsts tree #endif {- sparc_TARGET_ARCH -} +#if powerpc_TARGET_ARCH +genJump dsts (StCLbl lbl) + = 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) +#endif {- sparc_TARGET_ARCH -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} @@ -2607,6 +3085,22 @@ genCondJump lbl bool #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} @@ -2625,7 +3119,7 @@ register allocator. \begin{code} genCCall - :: (Either FAST_STRING StixExpr) -- function to call + :: (Either FastString StixExpr) -- function to call -> CCallConv -> PrimRep -- type of the result -> [StixExpr] -- arguments (of mixed type) @@ -2741,7 +3235,7 @@ genCCall fn cconv ret_rep args -- internally generated names like '.mul,' which don't get an -- underscore prefix -- ToDo:needed (WDP 96/03) ??? - fn_u = _UNPK_ (unLeft fn) + fn_u = unpackFS (unLeft fn) fn__2 tot_arg_size | head fn_u == '.' = ImmLit (text (fn_u ++ stdcallsize tot_arg_size)) @@ -2752,10 +3246,6 @@ genCCall fn cconv ret_rep args | cconv == StdCallConv = '@':show tot_arg_size | otherwise = "" - -- floats are always promoted to doubles when passed to a ccall - promote_size F = DF - promote_size sz = sz - arg_size DF = 8 arg_size F = 4 arg_size _ = 4 @@ -2779,17 +3269,14 @@ genCCall fn cconv ret_rep args | otherwise = get_op arg `thenNat` \ (code, reg, sz) -> getDeltaNat `thenNat` \ delta -> - let - real_sz = promote_size sz - size = arg_size real_sz - in + arg_size sz `bind` \ size -> setDeltaNat (delta-size) `thenNat` \ _ -> - if (case real_sz of DF -> True; _ -> False) + if (case sz of DF -> True; F -> True; _ -> False) then returnNat (size, code `appOL` toOL [SUB L (OpImm (ImmInt size)) (OpReg esp), DELTA (delta-size), - GST DF reg (AddrBaseIndex (Just esp) + GST sz reg (AddrBaseIndex (Just esp) Nothing (ImmInt 0))] ) @@ -2873,8 +3360,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))) @@ -2893,9 +3380,9 @@ genCCall fn cconv kind args -- underscore prefix -- ToDo:needed (WDP 96/03) ??? fn_static = unLeft fn - fn__2 = case (_HEAD_ fn_static) of - '.' -> ImmLit (ptext fn_static) - _ -> ImmLab False (ptext fn_static) + fn__2 = case (headFS fn_static) of + '.' -> 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. @@ -2961,6 +3448,111 @@ genCCall fn cconv kind args ) #endif {- sparc_TARGET_ARCH -} +#if powerpc_TARGET_ARCH +{- + The PowerPC calling convention (at least 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 -> returnNat ( passArguments + `snocOL` BL (ImmLab False (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 [] _ _ _ 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) +#endif {- powerpc_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} @@ -3127,6 +3719,34 @@ condFltReg cond x y #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} @@ -3151,7 +3771,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 @@ -3160,7 +3781,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 @@ -3168,7 +3790,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 @@ -3177,7 +3800,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 @@ -3522,6 +4146,90 @@ trivialUFCode pk instr x #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 + + code__2 dst = + if pk1 == pk2 then + code1 `appOL` code2 `snocOL` + instr (primRepToSize pk) dst src1 src2 + else panic "###PPC MachCode.trivialFCode: type mismatch" + in + returnNat (Any (if pk1 == pk2 then pk1 else DoubleRep) 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 = panic "###PPC MachCode.trivialUFCode" +#endif {- powerpc_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} @@ -3675,5 +4383,12 @@ coerceFlt2Dbl x #endif {- sparc_TARGET_ARCH -} +#if powerpc_TARGET_ARCH +coerceInt2FP pk x = panic "###PPC MachCode.coerceInt2FP" +coerceFP2Int fprep x = panic "###PPC MachCode.coerceFP2Int" +coerceDbl2Flt x = panic "###PPC MachCode.coerceDbl2Flt" +coerceFlt2Dbl x = panic "###PPC MachCode.coerceFlt2Dbl" +#endif {- powerpc_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code}