X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCode.lhs;h=09fc504894c88162e65a3e0f28cf1beabb5b91e6;hb=b08b5149482e9d88b3a0f5098e7b118e6f00e115;hp=ff2800e24d9df183d403302e5ef54afb827682b8;hpb=7dee9e10796acdc3af04f222ef06808ad3d1b611;p=ghc-hetmet.git diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index ff2800e..09fc504 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, @@ -38,6 +41,7 @@ import Stix ( getNatLabelNCG, StixStmt(..), StixExpr(..), NatM, thenNat, returnNat, mapNat, mapAndUnzipNat, mapAccumLNat, getDeltaNat, setDeltaNat, getUniqueNat, + IF_OS_darwin(addImportNat COMMA,) ncgPrimopMoan, ncg_target_is_32bit ) @@ -47,8 +51,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} @@ -62,6 +70,11 @@ order. type InstrBlock = OrdList Instr x `bind` f = f x + +isLeft (Left _) = True +isLeft (Right _) = False + +unLeft (Left x) = x \end{code} Code extractor for an entire stix tree---stix statement level. @@ -124,12 +137,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) @@ -155,7 +168,8 @@ derefDLL tree StIndex pk base offset -> StIndex pk (qq base) (qq offset) StMachOp mop args -> StMachOp mop (map qq args) StInd pk addr -> StInd pk (qq addr) - StCall who cc pk args -> StCall who cc pk (map qq args) + StCall (Left nm) cc pk args -> StCall (Left nm) cc pk (map qq args) + StCall (Right f) cc pk args -> StCall (Right (qq f)) cc pk (map qq args) StInt _ -> t StFloat _ -> t StDouble _ -> t @@ -177,7 +191,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 [ @@ -188,7 +202,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 @@ -203,7 +217,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)) @@ -425,6 +439,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 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 -} -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -525,8 +627,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 -> @@ -536,7 +638,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) @@ -548,6 +650,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) @@ -593,30 +699,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" @@ -700,8 +806,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 @@ -831,6 +937,7 @@ getRegister (StMachOp mop [x]) -- unary MachOps = case mop of MO_NatS_Neg -> trivialUCode (NEGI L) x MO_Nat_Not -> trivialUCode (NOT L) x + MO_32U_to_8U -> trivialUCode (AND L (OpImm (ImmInt 255))) x MO_Flt_Neg -> trivialUFCode FloatRep (GNEG F) x MO_Dbl_Neg -> trivialUFCode DoubleRep (GNEG DF) x @@ -853,8 +960,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 @@ -871,18 +980,19 @@ getRegister (StMachOp mop [x]) -- unary MachOps 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_op -> getRegister ( (if is_float_op then demote else id) - (StCall fn CCallConv DoubleRep - [(if is_float_op then promote else id) x]) + (StCall (Left fn) CCallConv DoubleRep + [(if is_float_op then promote else id) x]) ) where integerExtend signed nBits x = getRegister ( StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) - [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]] + [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits] ) conversionNop new_rep expr @@ -893,27 +1003,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) @@ -988,11 +1098,11 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps MO_Nat_Sar -> shift_code (SAR L) x y {-False-} MO_Flt_Pwr -> getRegister (demote - (StCall SLIT("pow") CCallConv DoubleRep - [promote x, promote y]) + (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [promote x, promote y]) ) - MO_Dbl_Pwr -> getRegister (StCall SLIT("pow") CCallConv DoubleRep - [x, y]) + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [x, y]) other -> pprPanic "getRegister(x86) - binary StMachOp (1)" (pprMachOp mop) where promote x = StMachOp MO_Flt_to_Dbl [x] @@ -1011,7 +1121,8 @@ getRegister (StMachOp mop [x, y]) -- dyadic MachOps code2 = registerCode reg2 t2 src1 = registerName reg1 t1 src2 = registerName reg2 t2 - code dst = toOL [ + code dst = code1 `appOL` code2 `appOL` + toOL [ MOV L (OpReg src1) (OpReg res_hi), MOV L (OpReg src2) (OpReg res_lo), IMUL64 res_hi res_lo, -- result in res_hi:res_lo @@ -1079,7 +1190,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, @@ -1108,7 +1219,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) @@ -1231,6 +1342,7 @@ getRegister (StMachOp mop [x]) -- unary PrimOps = case mop of MO_NatS_Neg -> trivialUCode (SUB False False g0) x MO_Nat_Not -> trivialUCode (XNOR False g0) x + MO_32U_to_8U -> trivialCode (AND False) x (StInt 255) MO_Flt_Neg -> trivialUFCode FloatRep (FNEG F) x MO_Dbl_Neg -> trivialUFCode DoubleRep (FNEG DF) x @@ -1245,7 +1357,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 @@ -1255,6 +1369,7 @@ getRegister (StMachOp mop [x]) -- unary PrimOps MO_NatP_to_NatS -> conversionNop IntRep x -- sign-extending widenings + MO_8U_to_32U -> integerExtend False 24 x MO_8U_to_NatU -> integerExtend False 24 x MO_8S_to_NatS -> integerExtend True 24 x MO_16U_to_NatU -> integerExtend False 16 x @@ -1265,12 +1380,12 @@ getRegister (StMachOp mop [x]) -- unary PrimOps then StMachOp MO_Flt_to_Dbl [x] else x in - getRegister (StCall fn CCallConv DoubleRep [fixed_x]) + getRegister (StCall (Left fn) CCallConv DoubleRep [fixed_x]) where integerExtend signed nBits x = getRegister ( StMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) - [StInt nBits, StMachOp MO_Nat_Shl [StInt nBits, x]] + [StMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits] ) conversionNop new_rep expr = getRegister expr `thenNat` \ e_code -> @@ -1278,37 +1393,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) @@ -1353,14 +1468,15 @@ getRegister (StMachOp mop [x, y]) -- dyadic PrimOps MO_Nat_Add -> trivialCode (ADD False False) x y MO_Nat_Sub -> trivialCode (SUB False False) x y - -- ToDo: teach about V8+ SPARC mul/div instructions - MO_NatS_Quot -> imul_div SLIT(".div") x y - MO_NatS_Rem -> imul_div SLIT(".rem") x y - MO_NatU_Quot -> imul_div SLIT(".udiv") x y - MO_NatU_Rem -> imul_div SLIT(".urem") x y + MO_NatS_Mul -> trivialCode (SMUL False) x y + MO_NatU_Mul -> trivialCode (UMUL False) x y + MO_NatS_MulMayOflo -> imulMayOflo x y - MO_NatS_Mul -> imul_div SLIT(".umul") x y - MO_NatU_Mul -> imul_div SLIT(".umul") x y + -- 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 @@ -1380,15 +1496,38 @@ 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 SLIT("pow") CCallConv DoubleRep - [promote x, promote 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 SLIT("pow") CCallConv DoubleRep - [x, y]) + MO_Dbl_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv DoubleRep + [x, y]) other -> pprPanic "getRegister(sparc) - binary StMachOp (1)" (pprMachOp mop) where - imul_div fn x y = getRegister (StCall fn CCallConv IntRep [x, y]) + idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y]) + + -------------------- + imulMayOflo :: StixExpr -> StixExpr -> NatM Register + imulMayOflo a1 a2 + = getNewRegNCG IntRep `thenNat` \ t1 -> + getNewRegNCG IntRep `thenNat` \ t2 -> + getNewRegNCG IntRep `thenNat` \ res_lo -> + getNewRegNCG IntRep `thenNat` \ res_hi -> + getRegister a1 `thenNat` \ reg1 -> + getRegister a2 `thenNat` \ reg2 -> + let code1 = registerCode reg1 t1 + code2 = registerCode reg2 t2 + src1 = registerName reg1 t1 + src2 = registerName reg2 t2 + code dst = code1 `appOL` code2 `appOL` + toOL [ + SMUL False src1 (RIReg src2) res_lo, + RDY res_hi, + SRA res_lo (RIImm (ImmInt 31)) res_lo, + SUB False False res_lo (RIReg res_hi) dst + ] + in + returnNat (Any IntRep code) getRegister (StInd pk mem) = getAmode mem `thenNat` \ amode -> @@ -1424,6 +1563,232 @@ 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 + + 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 -} + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} @@ -1637,6 +2002,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} @@ -1650,9 +2061,9 @@ Condition codes passed up the tree. \begin{code} data CondCode = CondCode Bool Cond InstrBlock -condName (CondCode _ cond _) = cond +condName (CondCode _ cond _) = cond condFloat (CondCode is_float _ _) = is_float -condCode (CondCode _ _ code) = code +condCode (CondCode _ _ code) = code \end{code} Set up a condition code for a conditional branch. @@ -1668,7 +2079,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]) @@ -1707,11 +2118,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} @@ -1843,7 +2255,8 @@ condIntCode cond x y ----------- condFltCode cond x y - = getRegister x `thenNat` \ register1 -> + = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) + getRegister x `thenNat` \ register1 -> getRegister y `thenNat` \ register2 -> getNewRegNCG (registerRep register1) `thenNat` \ tmp1 -> @@ -1851,7 +2264,6 @@ condFltCode cond x y `thenNat` \ tmp2 -> getNewRegNCG DoubleRep `thenNat` \ tmp -> let - pk1 = registerRep register1 code1 = registerCode register1 tmp1 src1 = registerName register1 tmp1 @@ -1861,26 +2273,17 @@ condFltCode cond x y code__2 | isAny register1 = code1 `appOL` -- result in tmp1 code2 `snocOL` - GCMP (primRepToSize pk1) tmp1 src2 + GCMP cond tmp1 src2 | otherwise = code1 `snocOL` GMOV src1 tmp1 `appOL` code2 `snocOL` - GCMP (primRepToSize pk1) tmp1 src2 - - {- On the 486, the flags set by FP compare are the unsigned ones! - (This looks like a HACK to me. WDP 96/03) - -} - fix_FP_cond :: Cond -> Cond - - fix_FP_cond GE = GEU - fix_FP_cond GTT = GU - fix_FP_cond LTT = LU - fix_FP_cond LE = LEU - fix_FP_cond any = any + GCMP cond tmp1 src2 in - returnNat (CondCode True (fix_FP_cond cond) code__2) + -- The GCMP insn does the test and sets the zero flag if comparable + -- and true. Hence we always supply EQQ as the condition to test. + returnNat (CondCode True EQQ code__2) #endif {- i386_TARGET_ARCH -} @@ -1946,9 +2349,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} @@ -2087,7 +2540,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 @@ -2116,8 +2569,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 @@ -2128,6 +2582,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} @@ -2268,6 +2753,44 @@ 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 + + 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} @@ -2350,7 +2873,7 @@ genJump dsts tree genJump dsts (StCLbl lbl) | hasDestInfo dsts = panic "genJump(sparc): CLbl and dsts" | isAsmTemp lbl = returnNat (toOL [BI ALWAYS False target, NOP]) - | otherwise = returnNat (toOL [CALL target 0 True, NOP]) + | otherwise = returnNat (toOL [CALL (Left target) 0 True, NOP]) where target = ImmCLbl lbl @@ -2365,6 +2888,23 @@ genJump dsts tree #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} @@ -2580,6 +3120,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} @@ -2598,7 +3154,7 @@ register allocator. \begin{code} genCCall - :: FAST_STRING -- function to call + :: (Either FastString StixExpr) -- function to call -> CCallConv -> PrimRep -- type of the result -> [StixExpr] -- arguments (of mixed type) @@ -2678,46 +3234,43 @@ genCCall fn cconv kind args #if i386_TARGET_ARCH -genCCall fn cconv ret_rep [StInt i] - | fn == SLIT ("PerformGC_wrapper") - = let call = toOL [ - MOV L (OpImm (ImmInt (fromInteger i))) (OpReg eax), - CALL (ImmLit (ptext (if underscorePrefix - then (SLIT ("_PerformGC_wrapper")) - else (SLIT ("PerformGC_wrapper"))))) - ] - in - returnNat call - - genCCall fn cconv ret_rep args = mapNat push_arg - (reverse args) `thenNat` \ sizes_n_codes -> - getDeltaNat `thenNat` \ delta -> - let (sizes, codes) = unzip sizes_n_codes - tot_arg_size = sum sizes - code2 = concatOL codes - call = toOL ( - [CALL (fn__2 tot_arg_size)] - ++ + (reverse args) `thenNat` \ sizes_n_codes -> + getDeltaNat `thenNat` \ delta -> + let (sizes, push_codes) = unzip sizes_n_codes + tot_arg_size = sum sizes + in + -- deal with static vs dynamic call targets + (case fn of + Left t_static + -> returnNat (unitOL (CALL (Left (fn__2 tot_arg_size)))) + Right dyn + -> get_op dyn `thenNat` \ (dyn_c, dyn_r, dyn_rep) -> + ASSERT(case dyn_rep of { L -> True; _ -> False}) + returnNat (dyn_c `snocOL` CALL (Right dyn_r)) + ) + `thenNat` \ callinsns -> + let push_code = concatOL push_codes + call = callinsns `appOL` + toOL ( -- Deallocate parameters after call for ccall; -- but not for stdcall (callee does it) (if cconv == StdCallConv then [] else [ADD L (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) ++ - [DELTA (delta + tot_arg_size)] ) in setDeltaNat (delta + tot_arg_size) `thenNat` \ _ -> - returnNat (code2 `appOL` call) + returnNat (push_code `appOL` call) where -- function names that begin with '.' are assumed to be special -- internally generated names like '.mul,' which don't get an -- underscore prefix -- ToDo:needed (WDP 96/03) ??? - fn_u = _UNPK_ fn + fn_u = unpackFS (unLeft fn) fn__2 tot_arg_size | head fn_u == '.' = ImmLit (text (fn_u ++ stdcallsize tot_arg_size)) @@ -2824,26 +3377,36 @@ genCCall fn cconv ret_rep args genCCall fn cconv kind args = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs -> - let (argcodes, vregss) = unzip argcode_and_vregs - argcode = concatOL argcodes - vregs = concat vregss + let + (argcodes, vregss) = unzip argcode_and_vregs n_argRegs = length allArgRegs n_argRegs_used = min (length vregs) n_argRegs + vregs = concat vregss + in + -- deal with static vs dynamic call targets + (case fn of + Left t_static + -> returnNat (unitOL (CALL (Left fn__2) n_argRegs_used False)) + Right dyn + -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) -> + returnNat (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + ) + `thenNat` \ callinsns -> + 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))) transfer_code = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE) - call - = unitOL (CALL fn__2 n_argRegs_used False) in returnNat (argcode `appOL` move_sp_down `appOL` transfer_code `appOL` - call `appOL` + callinsns `appOL` unitOL NOP `appOL` move_sp_up) where @@ -2851,9 +3414,10 @@ genCCall fn cconv kind args -- internally generated names like '.mul,' which don't get an -- underscore prefix -- ToDo:needed (WDP 96/03) ??? - fn__2 = case (_HEAD_ fn) of - '.' -> ImmLit (ptext fn) - _ -> ImmLab False (ptext fn) + fn_static = unLeft fn + 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. @@ -2919,6 +3483,117 @@ 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 -> + 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) +#endif {- powerpc_TARGET_ARCH -} + -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \end{code} @@ -3085,6 +3760,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} @@ -3109,7 +3812,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 @@ -3118,7 +3822,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 @@ -3126,7 +3831,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 @@ -3135,7 +3841,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 @@ -3480,6 +4187,124 @@ 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 + + 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} @@ -3633,5 +4458,54 @@ coerceFlt2Dbl x #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}