X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FnativeGen%2FMachCodeGen.hs;h=32dad130b4de57300b235ebc10b3917c2ab2d698;hp=f782577e1ff77b35480c03e6f5bf942b633a8cd2;hb=3034a6c8cfb50e2b5af4ef57c419986039b53a94;hpb=4ddd2cf7a0bb81ae4d19f74139ae9df548961a39 diff --git a/ghc/compiler/nativeGen/MachCodeGen.hs b/ghc/compiler/nativeGen/MachCodeGen.hs index f782577..32dad13 100644 --- a/ghc/compiler/nativeGen/MachCodeGen.hs +++ b/ghc/compiler/nativeGen/MachCodeGen.hs @@ -35,7 +35,6 @@ import ForeignCall ( CCallConv(..) ) import OrdList import Pretty import Outputable -import qualified Outputable import FastString import FastTypes ( isFastTrue ) import Constants ( wORD_SIZE ) @@ -273,88 +272,61 @@ iselExpr64 expr #if sparc_TARGET_ARCH -assignMem_I64Code addrTree valueTree - = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vrlo) -> - getRegister addrTree `thenNat` \ register_addr -> - getNewRegNat IntRep `thenNat` \ t_addr -> - let rlo = VirtualRegI vrlo +assignMem_I64Code addrTree valueTree = do + Amode addr addr_code <- getAmode addrTree + ChildCode64 vcode rlo <- iselExpr64 valueTree + (src, code) <- getSomeReg addrTree + let 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 - return (vcode `appOL` code_addr `snocOL` mov_hi `snocOL` mov_lo) + mov_hi = ST I32 rhi (AddrRegImm src (ImmInt 0)) + mov_lo = ST I32 rlo (AddrRegImm src (ImmInt 4)) + return (vcode `appOL` code `snocOL` mov_hi `snocOL` mov_lo) - -assignReg_I64Code (StixTemp (StixVReg u_dst pk)) valueTree - = iselExpr64 valueTree `thenNat` \ (ChildCode64 vcode vr_src_lo) -> +assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do + ChildCode64 vcode r_src_lo <- iselExpr64 valueTree let - r_dst_lo = mkVReg u_dst IntRep - r_src_lo = VirtualRegI vr_src_lo + r_dst_lo = mkVReg u_dst pk r_dst_hi = getHiVRegFromLo r_dst_lo r_src_hi = getHiVRegFromLo r_src_lo mov_lo = mkMOV r_src_lo r_dst_lo mov_hi = mkMOV r_src_hi r_dst_hi mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - in - return ( - vcode `snocOL` mov_hi `snocOL` mov_lo - ) + return (vcode `snocOL` mov_hi `snocOL` mov_lo) assignReg_I64Code lvalue valueTree - = pprPanic "assignReg_I64Code(sparc): invalid lvalue" - (pprStixReg lvalue) + = panic "assignReg_I64Code(sparc): invalid lvalue" -- Don't delete this -- it's very handy for debugging. --iselExpr64 expr --- | trace ("iselExpr64: " ++ showSDoc (pprCmmExpr expr)) False +-- | trace ("iselExpr64: " ++ showSDoc (ppr expr)) False -- = panic "iselExpr64(???)" -iselExpr64 (CmmLoad I64 addrTree) - = getRegister addrTree `thenNat` \ register_addr -> - getNewRegNat IntRep `thenNat` \ t_addr -> - getNewRegNat IntRep `thenNat` \ rlo -> +iselExpr64 (CmmLoad addrTree I64) = do + Amode (AddrRegReg r1 r2) addr_code <- getAmode addrTree + rlo <- getNewRegNat I32 let rhi = getHiVRegFromLo rlo - code_addr = registerCode register_addr t_addr - reg_addr = registerName register_addr t_addr - mov_hi = LD W (AddrRegImm reg_addr (ImmInt 0)) rhi - mov_lo = LD W (AddrRegImm reg_addr (ImmInt 4)) rlo - in - return ( - ChildCode64 (code_addr `snocOL` mov_hi `snocOL` mov_lo) - (getVRegUnique rlo) - ) + mov_hi = LD I32 (AddrRegImm r1 (ImmInt 0)) rhi + mov_lo = LD I32 (AddrRegImm r1 (ImmInt 4)) rlo + return ( + ChildCode64 (addr_code `snocOL` mov_hi `snocOL` mov_lo) + rlo + ) -iselExpr64 (CmmReg (CmmLocal (LocalReg uq I64))) - = getNewRegNat IntRep `thenNat` \ r_dst_lo -> +iselExpr64 (CmmReg (CmmLocal (LocalReg uq I64))) = do + r_dst_lo <- getNewRegNat I32 let r_dst_hi = getHiVRegFromLo r_dst_lo - r_src_lo = mkVReg vu IntRep + r_src_lo = mkVReg uq I32 r_src_hi = getHiVRegFromLo r_src_lo mov_lo = mkMOV r_src_lo r_dst_lo mov_hi = mkMOV r_src_hi r_dst_hi mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - in - return ( - ChildCode64 (toOL [mov_hi, mov_lo]) (getVRegUnique r_dst_lo) + return ( + ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo ) -iselExpr64 (StCall fn cconv I64 args) - = genCCall fn cconv kind args `thenNat` \ call -> - getNewRegNat IntRep `thenNat` \ r_dst_lo -> - let r_dst_hi = getHiVRegFromLo r_dst_lo - mov_lo = mkMOV o0 r_dst_lo - mov_hi = mkMOV o1 r_dst_hi - mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg - in - return ( - ChildCode64 (call `snocOL` mov_hi `snocOL` mov_lo) - (getVRegUnique r_dst_lo) - ) - iselExpr64 expr - = pprPanic "iselExpr64(sparc)" (pprCmmExpr expr) + = pprPanic "iselExpr64(sparc)" (ppr expr) #endif /* sparc_TARGET_ARCH */ @@ -513,17 +485,17 @@ getRegisterReg (CmmGlobal mid) getRegister :: CmmExpr -> NatM Register +getRegister (CmmReg (CmmGlobal PicBaseReg)) + = do + reg <- getPicBaseNat wordRep + return (Fixed wordRep reg nilOL) + getRegister (CmmReg reg) = return (Fixed (cmmRegRep reg) (getRegisterReg reg) nilOL) getRegister tree@(CmmRegOff _ _) = getRegister (mangleIndexTree tree) -getRegister CmmPicBaseReg - = do - reg <- getPicBaseNat wordRep - return (Fixed wordRep reg nilOL) - -- end of machine-"independent" bit; here we go on the rest... #if alpha_TARGET_ARCH @@ -763,12 +735,14 @@ getRegister leaf getRegister (CmmLit (CmmFloat f F32)) = do lbl <- getNewLabelNat - let code dst = toOL [ + dynRef <- cmmMakeDynamicReference addImportNat False lbl + Amode addr addr_code <- getAmode dynRef + let code dst = LDATA ReadOnlyData [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f F32)], - GLD F32 (ImmAddr (ImmCLbl lbl) 0) dst - ] + CmmStaticLit (CmmFloat f F32)] + `consOL` (addr_code `snocOL` + GLD F32 addr dst) -- in return (Any F32 code) @@ -784,12 +758,14 @@ getRegister (CmmLit (CmmFloat d F64)) | otherwise = do lbl <- getNewLabelNat - let code dst = toOL [ + dynRef <- cmmMakeDynamicReference addImportNat False lbl + Amode addr addr_code <- getAmode dynRef + let code dst = LDATA ReadOnlyData [CmmDataLabel lbl, - CmmStaticLit (CmmFloat d F64)], - GLD F64 (ImmAddr (ImmCLbl lbl) 0) dst - ] + CmmStaticLit (CmmFloat d F64)] + `consOL` (addr_code `snocOL` + GLD F64 addr dst) -- in return (Any F64 code) @@ -809,8 +785,7 @@ getRegister (CmmLit (CmmFloat f rep)) = do LDATA ReadOnlyData [CmmDataLabel lbl, CmmStaticLit (CmmFloat f rep)], - MOV rep (OpAddr (ImmAddr (ImmCLbl lbl) 0)) (OpReg dst) - -- ToDo: should use %rip-relative + MOV rep (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst) ] -- in return (Any rep code) @@ -882,7 +857,7 @@ getRegister (CmmMachOp (MO_S_Neg F32) [x]) = do CmmStaticLit (CmmInt 0 I32), CmmStaticLit (CmmInt 0 I32) ], - XOR F32 (OpAddr (ImmAddr (ImmCLbl lbl) 0)) (OpReg dst) + XOR F32 (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst) -- xorps, so we need the 128-bit constant -- ToDo: rip-relative ] @@ -902,9 +877,8 @@ getRegister (CmmMachOp (MO_S_Neg F64) [x]) = do CmmStaticLit (CmmInt 0 I64) ], -- gcc puts an unpck here. Wonder if we need it. - XOR F64 (OpAddr (ImmAddr (ImmCLbl lbl) 0)) (OpReg dst) + XOR F64 (OpAddr (ripRel (ImmCLbl lbl))) (OpReg dst) -- xorpd, so we need the 128-bit constant - -- ToDo: rip-relative ] -- return (Any F64 code) @@ -1139,12 +1113,14 @@ getRegister e@(CmmMachOp mop [x, y]) -- dyadic MachOps -------------------- add_code :: MachRep -> CmmExpr -> CmmExpr -> NatM Register - add_code rep x (CmmLit (CmmInt y _)) = add_int rep x y + add_code rep x (CmmLit (CmmInt y _)) + | not (is64BitInteger y) = add_int rep x y add_code rep x y = trivialCode rep (ADD rep) (Just (ADD rep)) x y -------------------- sub_code :: MachRep -> CmmExpr -> CmmExpr -> NatM Register - sub_code rep x (CmmLit (CmmInt y _)) = add_int rep x (-y) + sub_code rep x (CmmLit (CmmInt y _)) + | not (is64BitInteger (-y)) = add_int rep x (-y) sub_code rep x y = trivialCode rep (SUB rep) Nothing x y -- our three-operand add instruction: @@ -1155,7 +1131,7 @@ getRegister e@(CmmMachOp mop [x, y]) -- dyadic MachOps code dst = x_code `snocOL` LEA rep - (OpAddr (AddrBaseIndex (Just x_reg) Nothing imm)) + (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) (OpReg dst) -- return (Any rep code) @@ -1329,253 +1305,191 @@ reg2reg rep src dst #if sparc_TARGET_ARCH -getRegister (StFloat d) - = getBlockIdNat `thenNat` \ lbl -> - getNewRegNat PtrRep `thenNat` \ tmp -> +getRegister (CmmLit (CmmFloat f F32)) = do + lbl <- getNewLabelNat let code dst = toOL [ - SEGMENT DataSegment, - NEWBLOCK lbl, - DATA F [ImmFloat d], - SEGMENT TextSegment, - SETHI (HI (ImmCLbl lbl)) tmp, - LD F (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - in - return (Any F32 code) + LDATA ReadOnlyData + [CmmDataLabel lbl, + CmmStaticLit (CmmFloat f F32)], + SETHI (HI (ImmCLbl lbl)) dst, + LD F32 (AddrRegImm dst (LO (ImmCLbl lbl))) dst] + return (Any F32 code) -getRegister (StDouble d) - = getBlockIdNat `thenNat` \ lbl -> - getNewRegNat PtrRep `thenNat` \ tmp -> +getRegister (CmmLit (CmmFloat d F64)) = do + lbl <- getNewLabelNat let code dst = toOL [ - SEGMENT DataSegment, - NEWBLOCK lbl, - DATA DF [ImmDouble d], - SEGMENT TextSegment, - SETHI (HI (ImmCLbl lbl)) tmp, - LD DF (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] - in - return (Any F64 code) - + LDATA ReadOnlyData + [CmmDataLabel lbl, + CmmStaticLit (CmmFloat d F64)], + SETHI (HI (ImmCLbl lbl)) dst, + LD F64 (AddrRegImm dst (LO (ImmCLbl lbl))) dst] + return (Any F64 code) -getRegister (CmmMachOp mop [x]) -- unary PrimOps +getRegister (CmmMachOp mop [x]) -- unary MachOps = 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_S_Neg F32 -> trivialUFCode F32 (FNEG F32) x + MO_S_Neg F64 -> trivialUFCode F64 (FNEG F64) x - MO_F32_Neg -> trivialUFCode F32 (FNEG F) x - MO_F64_Neg -> trivialUFCode F64 (FNEG DF) x + MO_S_Neg rep -> trivialUCode rep (SUB False False g0) x + MO_Not rep -> trivialUCode rep (XNOR False g0) x - MO_F64_to_Flt -> coerceDbl2Flt x - MO_F32_to_Dbl -> coerceFlt2Dbl x + MO_U_Conv I32 I8 -> trivialCode I8 (AND False) x (CmmLit (CmmInt 255 I8)) - MO_F32_to_NatS -> coerceFP2Int F32 x - MO_NatS_to_Flt -> coerceInt2FP F32 x - MO_F64_to_NatS -> coerceFP2Int F64 x - MO_NatS_to_Dbl -> coerceInt2FP F64 x + MO_U_Conv F64 F32-> coerceDbl2Flt x + MO_U_Conv F32 F64-> coerceFlt2Dbl x - -- 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 - 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 - - -- 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 - MO_16S_to_NatS -> integerExtend True 16 x - - other_op -> - let fixed_x = if is_float_op -- promote to double - then CmmMachOp MO_F32_to_Dbl [x] - else x - in - getRegister (StCall (Left fn) CCallConv F64 [fixed_x]) - where - integerExtend signed nBits x - = getRegister ( - CmmMachOp (if signed then MO_Nat_Sar else MO_Nat_Shr) - [CmmMachOp MO_Nat_Shl [x, StInt nBits], StInt nBits] - ) - conversionNop new_rep expr - = getRegister expr `thenNat` \ e_code -> - return (swizzleRegisterRep e_code new_rep) + MO_S_Conv F32 I32-> coerceFP2Int F32 I32 x + MO_S_Conv I32 F32-> coerceInt2FP I32 F32 x + MO_S_Conv F64 I32-> coerceFP2Int F64 I32 x + MO_S_Conv I32 F64-> coerceInt2FP I32 F64 x - (is_float_op, fn) - = case mop of - MO_F32_Exp -> (True, FSLIT("exp")) - MO_F32_Log -> (True, FSLIT("log")) - MO_F32_Sqrt -> (True, FSLIT("sqrt")) + -- Conversions which are a nop on sparc + MO_U_Conv from to + | from == to -> conversionNop to x + MO_U_Conv I32 to -> conversionNop to x + MO_S_Conv I32 to -> conversionNop to x - MO_F32_Sin -> (True, FSLIT("sin")) - MO_F32_Cos -> (True, FSLIT("cos")) - MO_F32_Tan -> (True, FSLIT("tan")) + -- widenings + MO_U_Conv I8 I32 -> integerExtend False I8 I32 x + MO_U_Conv I16 I32 -> integerExtend False I16 I32 x + MO_U_Conv I8 I16 -> integerExtend False I8 I16 x + MO_S_Conv I16 I32 -> integerExtend True I16 I32 x - MO_F32_Asin -> (True, FSLIT("asin")) - MO_F32_Acos -> (True, FSLIT("acos")) - MO_F32_Atan -> (True, FSLIT("atan")) + other_op -> panic "Unknown unary mach op" + where + -- XXX SLL/SRL? + integerExtend signed from to expr = do + (reg, e_code) <- getSomeReg expr + let + code dst = + e_code `snocOL` + ((if signed then SRA else SRL) + reg (RIImm (ImmInt 0)) dst) + return (Any to code) + conversionNop new_rep expr + = do e_code <- getRegister expr + return (swizzleRegisterRep e_code new_rep) - MO_F32_Sinh -> (True, FSLIT("sinh")) - MO_F32_Cosh -> (True, FSLIT("cosh")) - MO_F32_Tanh -> (True, FSLIT("tanh")) +getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps + = case mop of + MO_Eq F32 -> condFltReg EQQ x y + MO_Ne F32 -> condFltReg NE x y - MO_F64_Exp -> (False, FSLIT("exp")) - MO_F64_Log -> (False, FSLIT("log")) - MO_F64_Sqrt -> (False, FSLIT("sqrt")) + MO_S_Gt F32 -> condFltReg GTT x y + MO_S_Ge F32 -> condFltReg GE x y + MO_S_Lt F32 -> condFltReg LTT x y + MO_S_Le F32 -> condFltReg LE x y - MO_F64_Sin -> (False, FSLIT("sin")) - MO_F64_Cos -> (False, FSLIT("cos")) - MO_F64_Tan -> (False, FSLIT("tan")) + MO_Eq F64 -> condFltReg EQQ x y + MO_Ne F64 -> condFltReg NE x y - MO_F64_Asin -> (False, FSLIT("asin")) - MO_F64_Acos -> (False, FSLIT("acos")) - MO_F64_Atan -> (False, FSLIT("atan")) + MO_S_Gt F64 -> condFltReg GTT x y + MO_S_Ge F64 -> condFltReg GE x y + MO_S_Lt F64 -> condFltReg LTT x y + MO_S_Le F64 -> condFltReg LE x y - MO_F64_Sinh -> (False, FSLIT("sinh")) - MO_F64_Cosh -> (False, FSLIT("cosh")) - MO_F64_Tanh -> (False, FSLIT("tanh")) + MO_Eq rep -> condIntReg EQQ x y + MO_Ne rep -> condIntReg NE x y - other -> pprPanic "getRegister(sparc) - binary CmmMachOp (2)" - (pprMachOp mop) + MO_S_Gt rep -> condIntReg GTT x y + MO_S_Ge rep -> condIntReg GE x y + MO_S_Lt rep -> condIntReg LTT x y + MO_S_Le rep -> condIntReg LE x y + + MO_U_Gt I32 -> condIntReg GTT x y + MO_U_Ge I32 -> condIntReg GE x y + MO_U_Lt I32 -> condIntReg LTT x y + MO_U_Le I32 -> condIntReg LE x y + MO_U_Gt I16 -> condIntReg GU x y + MO_U_Ge I16 -> condIntReg GEU x y + MO_U_Lt I16 -> condIntReg LU x y + MO_U_Le I16 -> condIntReg LEU x y -getRegister (CmmMachOp 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_F32_Gt -> condFltReg GTT x y - MO_F32_Ge -> condFltReg GE x y - MO_F32_Eq -> condFltReg EQQ x y - MO_F32_Ne -> condFltReg NE x y - MO_F32_Lt -> condFltReg LTT x y - MO_F32_Le -> condFltReg LE x y - - MO_F64_Gt -> condFltReg GTT x y - MO_F64_Ge -> condFltReg GE x y - MO_F64_Eq -> condFltReg EQQ x y - MO_F64_Ne -> condFltReg NE x y - MO_F64_Lt -> condFltReg LTT x y - MO_F64_Le -> condFltReg LE x y - - MO_Nat_Add -> trivialCode (ADD False False) x y - MO_Nat_Sub -> trivialCode (SUB False False) 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_Add I32 -> trivialCode I32 (ADD False False) x y + MO_Sub I32 -> trivialCode I32 (SUB False False) x y + MO_S_MulMayOflo rep -> imulMayOflo rep 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_S_Quot I32 -> idiv FSLIT(".div") x y + MO_S_Rem I32 -> idiv FSLIT(".rem") x y + MO_U_Quot I32 -> idiv FSLIT(".udiv") x y + MO_U_Rem I32 -> idiv FSLIT(".urem") x y +-} + MO_Add F32 -> trivialFCode F32 FADD x y + MO_Sub F32 -> trivialFCode F32 FSUB x y + MO_Mul F32 -> trivialFCode F32 FMUL x y + MO_S_Quot F32 -> trivialFCode F32 FDIV x y - MO_F32_Add -> trivialFCode F32 FADD x y - MO_F32_Sub -> trivialFCode F32 FSUB x y - MO_F32_Mul -> trivialFCode F32 FMUL x y - MO_F32_Div -> trivialFCode F32 FDIV x y + MO_Add F64 -> trivialFCode F64 FADD x y + MO_Sub F64 -> trivialFCode F64 FSUB x y + MO_Mul F64 -> trivialFCode F64 FMUL x y + MO_S_Quot F64 -> trivialFCode F64 FDIV x y - MO_F64_Add -> trivialFCode F64 FADD x y - MO_F64_Sub -> trivialFCode F64 FSUB x y - MO_F64_Mul -> trivialFCode F64 FMUL x y - MO_F64_Div -> trivialFCode F64 FDIV x y + MO_And rep -> trivialCode rep (AND False) x y + MO_Or rep -> trivialCode rep (OR False) x y + MO_Xor rep -> trivialCode rep (XOR False) x y - MO_Nat_And -> trivialCode (AND False) x y - MO_Nat_Or -> trivialCode (OR False) x y - MO_Nat_Xor -> trivialCode (XOR False) x y + MO_Mul rep -> trivialCode rep (SMUL False) x y - MO_Nat_Shl -> trivialCode SLL x y - MO_Nat_Shr -> trivialCode SRL x y - MO_Nat_Sar -> trivialCode SRA x y + MO_Shl rep -> trivialCode rep SLL x y + MO_U_Shr rep -> trivialCode rep SRL x y + MO_S_Shr rep -> trivialCode rep SRA x y +{- MO_F32_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv F64 [promote x, promote y]) where promote x = CmmMachOp MO_F32_to_Dbl [x] MO_F64_Pwr -> getRegister (StCall (Left FSLIT("pow")) CCallConv F64 [x, y]) - +-} other -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) where - idiv fn x y = getRegister (StCall (Left fn) CCallConv IntRep [x, y]) + --idiv fn x y = getRegister (StCall (Left fn) CCallConv I32 [x, y]) -------------------- - imulMayOflo :: CmmExpr -> CmmExpr -> NatM Register - imulMayOflo a1 a2 - = getNewRegNat IntRep `thenNat` \ t1 -> - getNewRegNat IntRep `thenNat` \ t2 -> - getNewRegNat IntRep `thenNat` \ res_lo -> - getNewRegNat 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, + imulMayOflo :: MachRep -> CmmExpr -> CmmExpr -> NatM Register + imulMayOflo rep a b = do + (a_reg, a_code) <- getSomeReg a + (b_reg, b_code) <- getSomeReg b + res_lo <- getNewRegNat I32 + res_hi <- getNewRegNat I32 + let + shift_amt = case rep of + I32 -> 31 + I64 -> 63 + _ -> panic "shift_amt" + code dst = a_code `appOL` b_code `appOL` + toOL [ + SMUL False a_reg (RIReg b_reg) res_lo, RDY res_hi, - SRA res_lo (RIImm (ImmInt 31)) res_lo, + SRA res_lo (RIImm (ImmInt shift_amt)) res_lo, SUB False False res_lo (RIReg res_hi) dst ] - in - return (Any IntRep code) + return (Any I32 code) -getRegister (CmmLoad pk mem) = do +getRegister (CmmLoad mem pk) = do Amode src code <- getAmode mem let - size = primRepToSize pk - code__2 dst = code `snocOL` LD size src dst - -- + code__2 dst = code `snocOL` LD pk src dst return (Any pk code__2) -getRegister (StInt i) +getRegister (CmmLit (CmmInt i _)) | fits13Bits i = let src = ImmInt (fromInteger i) code dst = unitOL (OR False g0 (RIImm src) dst) in - return (Any IntRep code) + return (Any I32 code) -getRegister leaf - | isJust imm - = let +getRegister (CmmLit lit) + = let rep = cmmLitRep lit + imm = litToImm lit code dst = toOL [ - SETHI (HI imm__2) dst, - OR False dst (RIImm (LO imm__2)) dst] - in - return (Any PtrRep code) - | otherwise - = ncgPrimopMoan "getRegister(sparc)" (pprCmmExpr leaf) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x + SETHI (HI imm) dst, + OR False dst (RIImm (LO imm)) dst] + in return (Any I32 code) #endif /* sparc_TARGET_ARCH */ @@ -1841,14 +1755,14 @@ getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit lit@(CmmInt i _)]) -- ASSERT(rep == I32)??? = do (x_reg, x_code) <- getSomeReg x let off = ImmInt (-(fromInteger i)) - return (Amode (AddrBaseIndex (Just x_reg) Nothing off) x_code) + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) getAmode (CmmMachOp (MO_Add rep) [x, CmmLit lit@(CmmInt i _)]) | not (is64BitLit lit) -- ASSERT(rep == I32)??? = do (x_reg, x_code) <- getSomeReg x let off = ImmInt (fromInteger i) - return (Amode (AddrBaseIndex (Just x_reg) Nothing off) x_code) + return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) -- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be -- recognised by the next rule. @@ -1866,7 +1780,7 @@ getAmode (CmmMachOp (MO_Add rep) [x, CmmMachOp (MO_Shl _) let code = x_code `appOL` y_code base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8 - return (Amode (AddrBaseIndex (Just x_reg) (Just (y_reg,base)) (ImmInt 0)) + return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt 0)) code) getAmode (CmmLit lit) | not (is64BitLit lit) @@ -1874,7 +1788,7 @@ getAmode (CmmLit lit) | not (is64BitLit lit) getAmode expr = do (reg,code) <- getSomeReg expr - return (Amode (AddrBaseIndex (Just reg) Nothing (ImmInt 0)) code) + return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */ @@ -1882,63 +1796,47 @@ getAmode expr = do #if sparc_TARGET_ARCH -getAmode (CmmMachOp MO_Nat_Sub [x, StInt i]) +getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit (CmmInt i _)]) | fits13Bits (-i) - = getNewRegNat PtrRep `thenNat` \ tmp -> - getRegister x `thenNat` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (-(fromInteger i)) - in - return (Amode (AddrRegImm reg off) code) + = do + (reg, code) <- getSomeReg x + let + off = ImmInt (-(fromInteger i)) + return (Amode (AddrRegImm reg off) code) -getAmode (CmmMachOp MO_Nat_Add [x, StInt i]) +getAmode (CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt i _)]) | fits13Bits i - = getNewRegNat PtrRep `thenNat` \ tmp -> - getRegister x `thenNat` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (fromInteger i) - in - return (Amode (AddrRegImm reg off) code) + = do + (reg, code) <- getSomeReg x + let + off = ImmInt (fromInteger i) + return (Amode (AddrRegImm reg off) code) -getAmode (CmmMachOp MO_Nat_Add [x, y]) - = getNewRegNat PtrRep `thenNat` \ tmp1 -> - getNewRegNat IntRep `thenNat` \ tmp2 -> - getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> +getAmode (CmmMachOp (MO_Add rep) [x, y]) + = do + (regX, codeX) <- getSomeReg x + (regY, codeY) <- getSomeReg y let - code1 = registerCode register1 tmp1 - reg1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 - reg2 = registerName register2 tmp2 - code__2 = code1 `appOL` code2 - in - return (Amode (AddrRegReg reg1 reg2) code__2) + code = codeX `appOL` codeY + return (Amode (AddrRegReg regX regY) code) -getAmode leaf - | isJust imm - = getNewRegNat PtrRep `thenNat` \ tmp -> - let +-- XXX Is this same as "leaf" in Stix? +getAmode (CmmLit lit) + = do + tmp <- getNewRegNat I32 + let code = unitOL (SETHI (HI imm__2) tmp) - in - return (Amode (AddrRegImm tmp (LO imm__2)) code) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x + return (Amode (AddrRegImm tmp (LO imm__2)) code) + where + imm__2 = litToImm lit getAmode other - = getNewRegNat PtrRep `thenNat` \ tmp -> - getRegister other `thenNat` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt 0 - in - return (Amode (AddrRegImm reg off) code) + = do + (reg, code) <- getSomeReg other + let + off = ImmInt 0 + return (Amode (AddrRegImm reg off) code) #endif /* sparc_TARGET_ARCH */ @@ -1998,6 +1896,14 @@ getAmode other #if i386_TARGET_ARCH || x86_64_TARGET_ARCH getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock) +#if x86_64_TARGET_ARCH +getNonClobberedOperand (CmmLit lit) + | isSuitableFloatingPointLit lit = do + lbl <- getNewLabelNat + let code = unitOL (LDATA ReadOnlyData [CmmDataLabel lbl, + CmmStaticLit lit]) + return (OpAddr (ripRel (ImmCLbl lbl)), code) +#endif getNonClobberedOperand (CmmLit lit) | not (is64BitLit lit) && not (isFloatingRep (cmmLitRep lit)) = return (OpImm (litToImm lit), nilOL) @@ -2008,7 +1914,7 @@ getNonClobberedOperand (CmmLoad mem pk) if (amodeCouldBeClobbered src) then do tmp <- getNewRegNat wordRep - return (AddrBaseIndex (Just tmp) Nothing (ImmInt 0), + return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), unitOL (LEA I32 (OpAddr src) (OpReg tmp))) else return (src, nilOL) @@ -2026,23 +1932,38 @@ regClobbered _ = False -- getOperand: the operand is not required to remain valid across the -- computation of an arbitrary expression. getOperand :: CmmExpr -> NatM (Operand, InstrBlock) +#if x86_64_TARGET_ARCH getOperand (CmmLit lit) - | not (is64BitLit lit) && not (isFloatingRep (cmmLitRep lit)) = + | isSuitableFloatingPointLit lit = do + lbl <- getNewLabelNat + let code = unitOL (LDATA ReadOnlyData [CmmDataLabel lbl, + CmmStaticLit lit]) + return (OpAddr (ripRel (ImmCLbl lbl)), code) +#endif +getOperand (CmmLit lit) + | not (is64BitLit lit) && not (isFloatingRep (cmmLitRep lit)) = do return (OpImm (litToImm lit), nilOL) getOperand (CmmLoad mem pk) | IF_ARCH_i386(not (isFloatingRep pk) && pk /= I64, True) = do Amode src mem_code <- getAmode mem return (OpAddr src, mem_code) getOperand e = do - (reg, code) <- getNonClobberedReg e + (reg, code) <- getSomeReg e return (OpReg reg, code) isOperand :: CmmExpr -> Bool isOperand (CmmLoad _ _) = True -isOperand (CmmLit lit) = not (is64BitLit lit) && - not (isFloatingRep (cmmLitRep lit)) +isOperand (CmmLit lit) = not (is64BitLit lit) + || isSuitableFloatingPointLit lit isOperand _ = False +-- if we want a floating-point literal as an operand, we can +-- use it directly from memory. However, if the literal is +-- zero, we're better off generating it into a register using +-- xor. +isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0 +isSuitableFloatingPointLit _ = False + getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock) getRegOrMem (CmmLoad mem pk) | IF_ARCH_i386(not (isFloatingRep pk) && pk /= I64, True) = do @@ -2053,13 +1974,16 @@ getRegOrMem e = do return (OpReg reg, code) #if x86_64_TARGET_ARCH -is64BitLit (CmmInt i I64) = i > 0x7fffffff || i < -0x80000000 +is64BitLit (CmmInt i I64) = is64BitInteger i -- assume that labels are in the range 0-2^31-1: this assumes the -- small memory model (see gcc docs, -mcmodel=small). #endif is64BitLit x = False #endif +is64BitInteger :: Integer -> Bool +is64BitInteger i = i > 0x7fffffff || i < -0x80000000 + -- ----------------------------------------------------------------------------- -- The 'CondCode' type: Condition codes passed up the tree. @@ -2238,74 +2162,54 @@ condFltCode cond x y = do code = x_code `appOL` y_code `snocOL` CMP (cmmExprRep x) y_op (OpReg x_reg) - -- in - return (CondCode False (condToUnsigned cond) code) - -- we need to use the unsigned comparison operators on the + -- NB(1): we need to use the unsigned comparison operators on the -- result of this comparison. + -- in + return (CondCode True (condToUnsigned cond) code) #endif -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH -condIntCode cond x (StInt y) +condIntCode cond x (CmmLit (CmmInt y rep)) | fits13Bits y - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - src1 = registerName register tmp - src2 = ImmInt (fromInteger y) - code__2 = code `snocOL` SUB False True src1 (RIImm src2) g0 - in - return (CondCode False cond code__2) + = do + (src1, code) <- getSomeReg x + let + src2 = ImmInt (fromInteger y) + code' = code `snocOL` SUB False True src1 (RIImm src2) g0 + return (CondCode False cond code') -condIntCode cond x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat IntRep `thenNat` \ tmp1 -> - getNewRegNat IntRep `thenNat` \ tmp2 -> +condIntCode cond x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y let - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 - src2 = registerName register2 tmp2 code__2 = code1 `appOL` code2 `snocOL` SUB False True src1 (RIReg src2) g0 - in return (CondCode False cond code__2) ----------- -condFltCode cond x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat (registerRep register1) - `thenNat` \ tmp1 -> - getNewRegNat (registerRep register2) - `thenNat` \ tmp2 -> - getNewRegNat F64 `thenNat` \ tmp -> +condFltCode cond x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + tmp <- getNewRegNat F64 let - promote x = FxTOy F DF x tmp + promote x = FxTOy F32 F64 x tmp - pk1 = registerRep register1 - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - pk2 = registerRep register2 - code2 = registerCode register2 tmp2 - src2 = registerName register2 tmp2 + pk1 = cmmExprRep x + pk2 = cmmExprRep y code__2 = if pk1 == pk2 then code1 `appOL` code2 `snocOL` - FCMP True (primRepToSize pk1) src1 src2 + FCMP True pk1 src1 src2 else if pk1 == F32 then code1 `snocOL` promote src1 `appOL` code2 `snocOL` - FCMP True DF tmp src2 + FCMP True F64 tmp src2 else code1 `appOL` code2 `snocOL` promote src2 `snocOL` - FCMP True DF src1 tmp - in + FCMP True F64 src1 tmp return (CondCode True cond code__2) #endif /* sparc_TARGET_ARCH */ @@ -2438,33 +2342,19 @@ assignReg_IntCode pk reg src = do #if sparc_TARGET_ARCH -assignMem_IntCode pk addr src - = getNewRegNat 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 - return code__2 +assignMem_IntCode pk addr src = do + (srcReg, code) <- getSomeReg src + Amode dstAddr addr_code <- getAmode addr + return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr + +assignReg_IntCode pk reg src = do + r <- getRegister src + return $ case r of + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg dst) freg + where + dst = getRegisterReg reg -assignReg_IntCode pk reg src - = getRegister src `thenNat` \ register2 -> - getRegisterReg reg `thenNat` \ register1 -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - dst__2 = registerName register1 tmp - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 - code__2 = if isFixed register2 - then code `snocOL` OR False g0 (RIReg src__2) dst__2 - else code - in - return code__2 #endif /* sparc_TARGET_ARCH */ @@ -2549,53 +2439,28 @@ assignReg_FltCode pk reg src = do #if sparc_TARGET_ARCH -- Floating point assignment to memory -assignMem_FltCode pk addr src - = getNewRegNat pk `thenNat` \ tmp1 -> - getAmode addr `thenNat` \ amode -> - getRegister src `thenNat` \ register -> +assignMem_FltCode pk addr src = do + Amode dst__2 code1 <- getAmode addr + (src__2, code2) <- getSomeReg src + tmp1 <- getNewRegNat pk 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 - + pk__2 = cmmExprRep src 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 + then unitOL (ST pk src__2 dst__2) + else toOL [FxTOy pk__2 pk src__2 tmp1, ST pk tmp1 dst__2] return code__2 -- Floating point assignment to a register/temporary --- Why is this so bizarrely ugly? -assignReg_FltCode pk reg src - = getRegisterReg reg `thenNat` \ register1 -> - getRegister src `thenNat` \ register2 -> - let - pk__2 = registerRep register2 - sz__2 = primRepToSize pk__2 - in - getNewRegNat pk__2 `thenNat` \ tmp -> - let - sz = primRepToSize pk - dst__2 = registerName register1 g0 -- must be Fixed - reg__2 = if pk /= pk__2 then tmp else dst__2 - code = registerCode register2 reg__2 - src__2 = registerName register2 reg__2 - code__2 = - if pk /= pk__2 then - code `snocOL` FxTOy sz__2 sz src__2 dst__2 - else if isFixed register2 then - code `snocOL` FMOV sz src__2 dst__2 - else - code - in - return code__2 +-- ToDo: Verify correctness +assignReg_FltCode pk reg src = do + r <- getRegister src + v1 <- getNewRegNat pk + return $ case r of + Any _ code -> code dst + Fixed _ freg fcode -> fcode `snocOL` FMOV pk freg v1 + where + dst = getRegisterReg reg #endif /* sparc_TARGET_ARCH */ @@ -2662,19 +2527,15 @@ genJump expr = do #if sparc_TARGET_ARCH -genJump (CmmLabel lbl) +genJump (CmmLit (CmmLabel lbl)) = return (toOL [CALL (Left target) 0 True, NOP]) where target = ImmCLbl lbl genJump tree - = getRegister tree `thenNat` \ register -> - getNewRegNat PtrRep `thenNat` \ tmp -> - let - code = registerCode register tmp - target = registerName register tmp - in - return (code `snocOL` JMP dsts (AddrRegReg target g0) `snocOL` NOP) + = do + (target, code) <- getSomeReg tree + return (code `snocOL` JMP (AddrRegReg target g0) `snocOL` NOP) #endif /* sparc_TARGET_ARCH */ @@ -2703,7 +2564,7 @@ genBranch id = return (unitOL (JXX ALWAYS id)) #endif #if sparc_TARGET_ARCH -genBranch id = return (toOL [BI ALWAYS False id, NOP]) +genBranch (BlockId id) = return (toOL [BI ALWAYS False (ImmCLbl (mkAsmTempLabel id)), NOP]) #endif #if powerpc_TARGET_ARCH @@ -2888,25 +2749,62 @@ genCondJump lbl (StPrim op [x, y]) -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH || x86_64_TARGET_ARCH +#if i386_TARGET_ARCH genCondJump id bool = do CondCode _ cond code <- getCondCode bool return (code `snocOL` JXX cond id) -#endif /* i386_TARGET_ARCH */ +#endif +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if sparc_TARGET_ARCH +#if x86_64_TARGET_ARCH genCondJump id bool = do + CondCode is_float cond cond_code <- getCondCode bool + if not is_float + then + return (cond_code `snocOL` JXX cond id) + else do + lbl <- getBlockIdNat + + -- see comment with condFltReg + let code = case cond of + NE -> or_unordered + GU -> plain_test + GEU -> plain_test + _ -> and_ordered + + plain_test = unitOL ( + JXX cond id + ) + or_unordered = toOL [ + JXX cond id, + JXX PARITY id + ] + and_ordered = toOL [ + JXX PARITY lbl, + JXX cond id, + JXX ALWAYS lbl, + NEWBLOCK lbl + ] + return (cond_code `appOL` code) + +#endif + +-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + +#if sparc_TARGET_ARCH + +genCondJump (BlockId id) bool = do CondCode is_float cond code <- getCondCode bool return ( code `appOL` toOL ( if is_float - then [NOP, BF cond False id, NOP] - else [BI cond False id, NOP] + then [NOP, BF cond False (ImmCLbl (mkAsmTempLabel id)), NOP] + else [BI cond False (ImmCLbl (mkAsmTempLabel id)), NOP] ) ) @@ -3038,11 +2936,21 @@ genCCall (CmmPrim op) [(r,_)] args vols = do return (any (getRegisterReg r)) genCCall target dest_regs args vols = do - sizes_n_codes <- mapM push_arg (reverse args) - delta <- getDeltaNat - let - (sizes, push_codes) = unzip sizes_n_codes + let + sizes = map (arg_size . cmmExprRep . fst) (reverse args) +#if !darwin_TARGET_OS tot_arg_size = sum sizes +#else + raw_arg_size = sum sizes + tot_arg_size = roundTo 16 raw_arg_size + arg_pad_size = tot_arg_size - raw_arg_size + delta0 <- getDeltaNat + setDeltaNat (delta0 - arg_pad_size) +#endif + + push_codes <- mapM push_arg (reverse args) + delta <- getDeltaNat + -- in -- deal with static vs dynamic call targets (callinsns,cconv) <- @@ -3050,14 +2958,22 @@ genCCall target dest_regs args vols = do -- CmmPrim -> ... CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm)), conv) + return (unitOL (CALL (Left fn_imm) []), conv) where fn_imm = ImmCLbl lbl CmmForeignCall expr conv -> do (dyn_c, dyn_r, dyn_rep) <- get_op expr ASSERT(dyn_rep == I32) - return (dyn_c `snocOL` CALL (Right dyn_r), conv) + return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) - let push_code = concatOL push_codes + let push_code +#if darwin_TARGET_OS + | arg_pad_size /= 0 + = toOL [SUB I32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), + DELTA (delta0 - arg_pad_size)] + `appOL` concatOL push_codes + | otherwise +#endif + = concatOL push_codes call = callinsns `appOL` toOL ( -- Deallocate parameters after call for ccall; @@ -3093,10 +3009,15 @@ genCCall target dest_regs args vols = do where arg_size F64 = 8 arg_size F32 = 4 + arg_size I64 = 8 arg_size _ = 4 + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) + + push_arg :: (CmmExpr,MachHint){-current argument-} - -> NatM (Int, InstrBlock) -- argsz, code + -> NatM InstrBlock -- code push_arg (arg,_hint) -- we don't need the hints on x86 | arg_rep == I64 = do @@ -3106,7 +3027,7 @@ genCCall target dest_regs args vols = do let r_hi = getHiVRegFromLo r_lo -- in - return (8, code `appOL` + return ( code `appOL` toOL [PUSH I32 (OpReg r_hi), DELTA (delta - 4), PUSH I32 (OpReg r_lo), DELTA (delta - 8), DELTA (delta-8)] @@ -3118,16 +3039,14 @@ genCCall target dest_regs args vols = do let size = arg_size sz setDeltaNat (delta-size) if (case sz of F64 -> True; F32 -> True; _ -> False) - then return (size, - code `appOL` + then return (code `appOL` toOL [SUB I32 (OpImm (ImmInt size)) (OpReg esp), DELTA (delta-size), - GST sz reg (AddrBaseIndex (Just esp) - Nothing + GST sz reg (AddrBaseIndex (EABaseReg esp) + EAIndexNone (ImmInt 0))] ) - else return (size, - code `snocOL` + else return (code `snocOL` PUSH I32 (OpReg reg) `snocOL` DELTA (delta-size) ) @@ -3147,40 +3066,49 @@ genCCall target dest_regs args vols = do outOfLineFloatOp :: CallishMachOp -> CmmReg -> [(CmmExpr,MachHint)] -> Maybe [GlobalReg] -> NatM InstrBlock outOfLineFloatOp mop res args vols - | cmmRegRep res == F64 - = stmtToInstrs (CmmCall target [(res,FloatHint)] args vols) - - | otherwise - = do uq <- getUniqueNat - let - tmp = CmmLocal (LocalReg uq F64) - -- in - code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] (map promote args) vols) - code2 <- stmtToInstrs (CmmAssign res (demote (CmmReg tmp))) - return (code1 `appOL` code2) + = do + targetExpr <- cmmMakeDynamicReference addImportNat True lbl + let target = CmmForeignCall targetExpr CCallConv + + if cmmRegRep res == F64 + then + stmtToInstrs (CmmCall target [(res,FloatHint)] args vols) + else do + uq <- getUniqueNat + let + tmp = CmmLocal (LocalReg uq F64) + -- in + code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] + (map promote args) vols) + code2 <- stmtToInstrs (CmmAssign res (demote (CmmReg tmp))) + return (code1 `appOL` code2) where +#if i386_TARGET_ARCH promote (x,hint) = (CmmMachOp (MO_S_Conv F32 F64) [x], hint) demote x = CmmMachOp (MO_S_Conv F64 F32) [x] +#else + promote (x,hint) = (x,hint) + demote x = x +#endif - target = CmmForeignCall (CmmLit lbl) CCallConv - lbl = CmmLabel (mkForeignLabel fn Nothing False) + lbl = mkForeignLabel fn Nothing True fn = case mop of - MO_F32_Sqrt -> FSLIT("sqrt") - MO_F32_Sin -> FSLIT("sin") - MO_F32_Cos -> FSLIT("cos") - MO_F32_Tan -> FSLIT("tan") - MO_F32_Exp -> FSLIT("exp") - MO_F32_Log -> FSLIT("log") - - MO_F32_Asin -> FSLIT("asin") - MO_F32_Acos -> FSLIT("acos") - MO_F32_Atan -> FSLIT("atan") - - MO_F32_Sinh -> FSLIT("sinh") - MO_F32_Cosh -> FSLIT("cosh") - MO_F32_Tanh -> FSLIT("tanh") - MO_F32_Pwr -> FSLIT("pow") + MO_F32_Sqrt -> FSLIT("sqrtf") + MO_F32_Sin -> FSLIT("sinf") + MO_F32_Cos -> FSLIT("cosf") + MO_F32_Tan -> FSLIT("tanf") + MO_F32_Exp -> FSLIT("expf") + MO_F32_Log -> FSLIT("logf") + + MO_F32_Asin -> FSLIT("asinf") + MO_F32_Acos -> FSLIT("acosf") + MO_F32_Atan -> FSLIT("atanf") + + MO_F32_Sinh -> FSLIT("sinhf") + MO_F32_Cosh -> FSLIT("coshf") + MO_F32_Tanh -> FSLIT("tanhf") + MO_F32_Pwr -> FSLIT("powf") MO_F64_Sqrt -> FSLIT("sqrt") MO_F64_Sin -> FSLIT("sin") @@ -3198,8 +3126,6 @@ outOfLineFloatOp mop res args vols MO_F64_Tanh -> FSLIT("tanh") MO_F64_Pwr -> FSLIT("pow") - other -> pprPanic "outOfLineFloatOp" (pprCallishMachOp mop) - #endif /* i386_TARGET_ARCH || x86_64_TARGET_ARCH */ -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -3212,10 +3138,17 @@ genCCall (CmmPrim op) [(r,_)] args vols = genCCall target dest_regs args vols = do -- load up the register arguments - (stack_args, sse_regs, load_args_code) - <- load_args args allArgRegs allFPArgRegs 0 nilOL + (stack_args, aregs, fregs, load_args_code) + <- load_args args allArgRegs allFPArgRegs nilOL let + fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) + int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) + arg_regs = int_regs_used ++ fp_regs_used + -- for annotating the call instruction with + + sse_regs = length fp_regs_used + tot_arg_size = arg_size * length stack_args -- On entry to the called function, %rsp should be aligned @@ -3247,11 +3180,11 @@ genCCall target dest_regs args vols = do -- CmmPrim -> ... CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm)), conv) + return (unitOL (CALL (Left fn_imm) arg_regs), conv) where fn_imm = ImmCLbl lbl CmmForeignCall expr conv -> do (dyn_r, dyn_c) <- getSomeReg expr - return (dyn_c `snocOL` CALL (Right dyn_r), conv) + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) let -- The x86_64 ABI requires us to set %al to the number of SSE @@ -3302,31 +3235,31 @@ genCCall target dest_regs args vols = do load_args :: [(CmmExpr,MachHint)] -> [Reg] -- int regs avail for args -> [Reg] -- FP regs avail for args - -> Int -> InstrBlock - -> NatM ([(CmmExpr,MachHint)],Int,InstrBlock) - load_args args [] [] sse_regs code = return (args, sse_regs, code) + -> InstrBlock + -> NatM ([(CmmExpr,MachHint)],[Reg],[Reg],InstrBlock) + load_args args [] [] code = return (args, [], [], code) -- no more regs to use - load_args [] aregs fregs sse_regs code = return ([],sse_regs,code) + load_args [] aregs fregs code = return ([], aregs, fregs, code) -- no more args to push - load_args ((arg,hint) : rest) aregs fregs sse_regs code + load_args ((arg,hint) : rest) aregs fregs code | isFloatingRep arg_rep = case fregs of [] -> push_this_arg (r:rs) -> do arg_code <- getAnyReg arg - load_args rest aregs rs (sse_regs+1) (code `appOL` arg_code r) + load_args rest aregs rs (code `appOL` arg_code r) | otherwise = case aregs of [] -> push_this_arg (r:rs) -> do arg_code <- getAnyReg arg - load_args rest rs fregs sse_regs (code `appOL` arg_code r) + load_args rest rs fregs (code `appOL` arg_code r) where arg_rep = cmmExprRep arg push_this_arg = do - (args',sse',code') <- load_args rest aregs fregs sse_regs code - return ((arg,hint):args', sse', code') + (args',ars,frs,code') <- load_args rest aregs fregs code + return ((arg,hint):args', ars, frs, code') push_args [] code = return code push_args ((arg,hint):rest) code @@ -3388,23 +3321,33 @@ genCCall target dest_regs args vols = do stack only immediately prior to the call proper. Sigh. -} -genCCall fn cconv kind args - = mapNat arg_to_int_vregs args `thenNat` \ argcode_and_vregs -> +genCCall target dest_regs argsAndHints vols = do + let + args = map fst argsAndHints + argcode_and_vregs <- mapM arg_to_int_vregs args 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 - -> return (unitOL (CALL (Left fn__2) n_argRegs_used False)) - Right dyn - -> arg_to_int_vregs dyn `thenNat` \ (dyn_c, [dyn_r]) -> - return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) - ) - `thenNat` \ callinsns -> + callinsns <- (case target of + CmmForeignCall (CmmLit (CmmLabel lbl)) conv -> do + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + CmmForeignCall expr conv -> do + (dyn_c, [dyn_r]) <- arg_to_int_vregs expr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + CmmPrim mop -> do + (res, reduce) <- outOfLineFloatOp mop + lblOrMopExpr <- case res of + Left lbl -> do + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + Right mopExpr -> do + (dyn_c, [dyn_r]) <- arg_to_int_vregs mopExpr + return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) + if reduce then panic "genCCall(sparc): can not reduce" else return lblOrMopExpr + + ) let argcode = concatOL argcodes (move_sp_down, move_sp_up) @@ -3415,23 +3358,13 @@ genCCall fn cconv kind args else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn))) transfer_code = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE) - in - return (argcode `appOL` - move_sp_down `appOL` - transfer_code `appOL` - callinsns `appOL` - unitOL NOP `appOL` - move_sp_up) + return (argcode `appOL` + move_sp_down `appOL` + transfer_code `appOL` + callinsns `appOL` + unitOL NOP `appOL` + move_sp_up) 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_static = unLeft fn - fn__2 = case (headFS fn_static) of - '.' -> ImmLit (ftext fn_static) - _ -> ImmCLbl (mkForeignLabel fn_static False) - -- move args from the integer vregs into which they have been -- marshalled, into %o0 .. %o5, and the rest onto the stack. move_final :: [Reg] -> [Reg] -> Int -> [Instr] @@ -3440,7 +3373,7 @@ genCCall fn cconv kind args = [] move_final (v:vs) [] offset -- out of aregs; move to stack - = ST W v (spRel offset) + = ST I32 v (spRel offset) : move_final vs [] (offset+1) move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg @@ -3451,49 +3384,93 @@ genCCall fn cconv kind args -- or two integer vregs. arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) arg_to_int_vregs arg - | is64BitRep (repOfCmmExpr arg) - = iselExpr64 arg `thenNat` \ (ChildCode64 code vr_lo) -> - let r_lo = VirtualRegI vr_lo + | (cmmExprRep arg) == I64 + = do + (ChildCode64 code r_lo) <- iselExpr64 arg + let r_hi = getHiVRegFromLo r_lo - in return (code, [r_hi, r_lo]) + return (code, [r_hi, r_lo]) | otherwise - = getRegister arg `thenNat` \ register -> - getNewRegNat (registerRep register) `thenNat` \ tmp -> - let code = registerCode register tmp - src = registerName register tmp - pk = registerRep register - in - -- the value is in src. Get it into 1 or 2 int vregs. + = do + (src, code) <- getSomeReg arg + tmp <- getNewRegNat (cmmExprRep arg) + let + pk = cmmExprRep arg case pk of - F64 -> - getNewRegNat WordRep `thenNat` \ v1 -> - getNewRegNat WordRep `thenNat` \ v2 -> - return ( - code `snocOL` - FMOV DF src f0 `snocOL` - ST F f0 (spRel 16) `snocOL` - LD W (spRel 16) v1 `snocOL` - ST F (fPair f0) (spRel 16) `snocOL` - LD W (spRel 16) v2 - , - [v1,v2] - ) - F32 -> - getNewRegNat WordRep `thenNat` \ v1 -> - return ( - code `snocOL` - ST F src (spRel 16) `snocOL` - LD W (spRel 16) v1 - , - [v1] - ) - other -> - getNewRegNat WordRep `thenNat` \ v1 -> - return ( - code `snocOL` OR False g0 (RIReg src) v1 - , - [v1] - ) + F64 -> do + v1 <- getNewRegNat I32 + v2 <- getNewRegNat I32 + return ( + code `snocOL` + FMOV F64 src f0 `snocOL` + ST F32 f0 (spRel 16) `snocOL` + LD I32 (spRel 16) v1 `snocOL` + ST F32 (fPair f0) (spRel 16) `snocOL` + LD I32 (spRel 16) v2 + , + [v1,v2] + ) + F32 -> do + v1 <- getNewRegNat I32 + return ( + code `snocOL` + ST F32 src (spRel 16) `snocOL` + LD I32 (spRel 16) v1 + , + [v1] + ) + other -> do + v1 <- getNewRegNat I32 + return ( + code `snocOL` OR False g0 (RIReg src) v1 + , + [v1] + ) +outOfLineFloatOp mop = + do + mopExpr <- cmmMakeDynamicReference addImportNat True $ + mkForeignLabel functionName Nothing True + let mopLabelOrExpr = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + return (mopLabelOrExpr, reduce) + where + (reduce, functionName) = case mop of + MO_F32_Exp -> (True, FSLIT("exp")) + MO_F32_Log -> (True, FSLIT("log")) + MO_F32_Sqrt -> (True, FSLIT("sqrt")) + + MO_F32_Sin -> (True, FSLIT("sin")) + MO_F32_Cos -> (True, FSLIT("cos")) + MO_F32_Tan -> (True, FSLIT("tan")) + + MO_F32_Asin -> (True, FSLIT("asin")) + MO_F32_Acos -> (True, FSLIT("acos")) + MO_F32_Atan -> (True, FSLIT("atan")) + + MO_F32_Sinh -> (True, FSLIT("sinh")) + MO_F32_Cosh -> (True, FSLIT("cosh")) + MO_F32_Tanh -> (True, FSLIT("tanh")) + + MO_F64_Exp -> (False, FSLIT("exp")) + MO_F64_Log -> (False, FSLIT("log")) + MO_F64_Sqrt -> (False, FSLIT("sqrt")) + + MO_F64_Sin -> (False, FSLIT("sin")) + MO_F64_Cos -> (False, FSLIT("cos")) + MO_F64_Tan -> (False, FSLIT("tan")) + + MO_F64_Asin -> (False, FSLIT("asin")) + MO_F64_Acos -> (False, FSLIT("acos")) + MO_F64_Atan -> (False, FSLIT("atan")) + + MO_F64_Sinh -> (False, FSLIT("sinh")) + MO_F64_Cosh -> (False, FSLIT("cosh")) + MO_F64_Tanh -> (False, FSLIT("tanh")) + + other -> pprPanic "outOfLineFloatOp(sparc) " + (pprCallishMachOp mop) + #endif /* sparc_TARGET_ARCH */ #if powerpc_TARGET_ARCH @@ -3757,18 +3734,44 @@ genCCall target dest_regs argsAndHints vols genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -genSwitch expr ids = do - (reg,e_code) <- getSomeReg expr - lbl <- getNewLabelNat - let - jumpTable = map jumpTableEntry ids - op = OpAddr (AddrBaseIndex Nothing (Just (reg,wORD_SIZE)) (ImmCLbl lbl)) - code = e_code `appOL` toOL [ - LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), - JMP_TBL op [ id | Just id <- ids ] - ] - -- in - return code +genSwitch expr ids + | opt_PIC + = do + (reg,e_code) <- getSomeReg expr + lbl <- getNewLabelNat + dynRef <- cmmMakeDynamicReference addImportNat False lbl + (tableReg,t_code) <- getSomeReg $ dynRef + let + jumpTable = map jumpTableEntryRel ids + + jumpTableEntryRel Nothing + = CmmStaticLit (CmmInt 0 wordRep) + jumpTableEntryRel (Just (BlockId id)) + = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) + where blockLabel = mkAsmTempLabel id + + op = OpAddr (AddrBaseIndex (EABaseReg tableReg) + (EAIndex reg wORD_SIZE) (ImmInt 0)) + + code = e_code `appOL` t_code `appOL` toOL [ + LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + ADD wordRep op (OpReg tableReg), + JMP_TBL (OpReg tableReg) [ id | Just id <- ids ] + ] + return code + | otherwise + = do + (reg,e_code) <- getSomeReg expr + lbl <- getNewLabelNat + let + jumpTable = map jumpTableEntry ids + op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl)) + code = e_code `appOL` toOL [ + LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable), + JMP_TBL op [ id | Just id <- ids ] + ] + -- in + return code #elif powerpc_TARGET_ARCH genSwitch expr ids | opt_PIC @@ -3854,135 +3857,152 @@ condIntReg cond x y = do let code dst = cond_code `appOL` toOL [ SETCC cond (OpReg tmp), - MOV I32 (OpReg tmp) (OpReg dst), - AND I32 (OpImm (ImmInt 1)) (OpReg dst) + MOVZxL I8 (OpReg tmp) (OpReg dst) ] - -- NB. (1) Tha AND is needed here because the x86 only - -- sets the low byte in the SETCC instruction. - -- NB. (2) The extra temporary register is a hack to - -- work around the fact that the setcc instructions only - -- accept byte registers. dst might not be a byte-able reg, - -- but currently all free registers are byte-able, so we're - -- guaranteed that a new temporary is byte-able. -- in return (Any I32 code) +#endif + +#if i386_TARGET_ARCH condFltReg cond x y = do - lbl1 <- getBlockIdNat - lbl2 <- getBlockIdNat CondCode _ cond cond_code <- condFltCode cond x y - let - code dst = cond_code `appOL` toOL [ - JXX cond lbl1, - MOV I32 (OpImm (ImmInt 0)) (OpReg dst), - JXX ALWAYS lbl2, - NEWBLOCK lbl1, - MOV I32 (OpImm (ImmInt 1)) (OpReg dst), - JXX ALWAYS lbl2, - NEWBLOCK lbl2] - -- SIGH, have to split up this block somehow... + tmp <- getNewRegNat I8 + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL I8 (OpReg tmp) (OpReg dst) + ] -- in return (Any I32 code) -#endif /* i386_TARGET_ARCH */ +#endif + +#if x86_64_TARGET_ARCH + +condFltReg cond x y = do + CondCode _ cond cond_code <- condFltCode cond x y + tmp1 <- getNewRegNat wordRep + tmp2 <- getNewRegNat wordRep + let + -- We have to worry about unordered operands (eg. comparisons + -- against NaN). If the operands are unordered, the comparison + -- sets the parity flag, carry flag and zero flag. + -- All comparisons are supposed to return false for unordered + -- operands except for !=, which returns true. + -- + -- Optimisation: we don't have to test the parity flag if we + -- know the test has already excluded the unordered case: eg > + -- and >= test for a zero carry flag, which can only occur for + -- ordered operands. + -- + -- ToDo: by reversing comparisons we could avoid testing the + -- parity flag in more cases. + + code dst = + cond_code `appOL` + (case cond of + NE -> or_unordered dst + GU -> plain_test dst + GEU -> plain_test dst + _ -> and_ordered dst) + + plain_test dst = toOL [ + SETCC cond (OpReg tmp1), + MOVZxL I8 (OpReg tmp1) (OpReg dst) + ] + or_unordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC PARITY (OpReg tmp2), + OR I8 (OpReg tmp1) (OpReg tmp2), + MOVZxL I8 (OpReg tmp2) (OpReg dst) + ] + and_ordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC NOTPARITY (OpReg tmp2), + AND I8 (OpReg tmp1) (OpReg tmp2), + MOVZxL I8 (OpReg tmp2) (OpReg dst) + ] + -- in + return (Any I32 code) + +#endif -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #if sparc_TARGET_ARCH -condIntReg EQQ x (StInt 0) - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> +condIntReg EQQ x (CmmLit (CmmInt 0 d)) = do + (src, code) <- getSomeReg x + tmp <- getNewRegNat I32 let - code = registerCode register tmp - src = registerName register tmp code__2 dst = code `appOL` toOL [ SUB False True g0 (RIReg src) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] - in - return (Any IntRep code__2) + return (Any I32 code__2) -condIntReg EQQ x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat IntRep `thenNat` \ tmp1 -> - getNewRegNat IntRep `thenNat` \ tmp2 -> +condIntReg EQQ x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + tmp1 <- getNewRegNat I32 + tmp2 <- getNewRegNat I32 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 [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, SUB True False g0 (RIImm (ImmInt (-1))) dst] - in - return (Any IntRep code__2) + return (Any I32 code__2) -condIntReg NE x (StInt 0) - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> +condIntReg NE x (CmmLit (CmmInt 0 d)) = do + (src, code) <- getSomeReg x + tmp <- getNewRegNat I32 let - code = registerCode register tmp - src = registerName register tmp code__2 dst = code `appOL` toOL [ SUB False True g0 (RIReg src) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] - in - return (Any IntRep code__2) + return (Any I32 code__2) -condIntReg NE x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat IntRep `thenNat` \ tmp1 -> - getNewRegNat IntRep `thenNat` \ tmp2 -> +condIntReg NE x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + tmp1 <- getNewRegNat I32 + tmp2 <- getNewRegNat I32 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 [ XOR False src1 (RIReg src2) dst, SUB False True g0 (RIReg dst) g0, ADD True False g0 (RIImm (ImmInt 0)) dst] - in - return (Any IntRep code__2) + return (Any I32 code__2) -condIntReg cond x y - = getBlockIdNat `thenNat` \ lbl1 -> - getBlockIdNat `thenNat` \ lbl2 -> - condIntCode cond x y `thenNat` \ condition -> +condIntReg cond x y = do + BlockId lbl1 <- getBlockIdNat + BlockId lbl2 <- getBlockIdNat + CondCode _ cond cond_code <- condIntCode cond x y let - code = condCode condition - cond = condName condition - code__2 dst = code `appOL` toOL [ - BI cond False (ImmCLbl lbl1), NOP, + code__2 dst = cond_code `appOL` toOL [ + BI cond False (ImmCLbl (mkAsmTempLabel lbl1)), NOP, OR False g0 (RIImm (ImmInt 0)) dst, - BI ALWAYS False (ImmCLbl lbl2), NOP, - NEWBLOCK lbl1, + BI ALWAYS False (ImmCLbl (mkAsmTempLabel lbl2)), NOP, + NEWBLOCK (BlockId lbl1), OR False g0 (RIImm (ImmInt 1)) dst, - NEWBLOCK lbl2] - in - return (Any IntRep code__2) + NEWBLOCK (BlockId lbl2)] + return (Any I32 code__2) -condFltReg cond x y - = getBlockIdNat `thenNat` \ lbl1 -> - getBlockIdNat `thenNat` \ lbl2 -> - condFltCode cond x y `thenNat` \ condition -> +condFltReg cond x y = do + BlockId lbl1 <- getBlockIdNat + BlockId lbl2 <- getBlockIdNat + CondCode _ cond cond_code <- condFltCode cond x y let - code = condCode condition - cond = condName condition - code__2 dst = code `appOL` toOL [ + code__2 dst = cond_code `appOL` toOL [ NOP, - BF cond False (ImmCLbl lbl1), NOP, + BF cond False (ImmCLbl (mkAsmTempLabel lbl1)), NOP, OR False g0 (RIImm (ImmInt 0)) dst, - BI ALWAYS False (ImmCLbl lbl2), NOP, - NEWBLOCK lbl1, + BI ALWAYS False (ImmCLbl (mkAsmTempLabel lbl2)), NOP, + NEWBLOCK (BlockId lbl1), OR False g0 (RIImm (ImmInt 1)) dst, - NEWBLOCK lbl2] - in - return (Any IntRep code__2) + NEWBLOCK (BlockId lbl2)] + return (Any I32 code__2) #endif /* sparc_TARGET_ARCH */ @@ -4061,7 +4081,7 @@ trivialCode trivialFCode :: MachRep -> IF_ARCH_alpha((Reg -> Reg -> Reg -> Instr) - ,IF_ARCH_sparc((Size -> Reg -> Reg -> Reg -> Instr) + ,IF_ARCH_sparc((MachRep -> Reg -> Reg -> Reg -> Instr) ,IF_ARCH_i386 ((MachRep -> Reg -> Reg -> Reg -> Instr) ,IF_ARCH_x86_64 ((MachRep -> Operand -> Operand -> Instr) ,)))) @@ -4223,7 +4243,10 @@ trivialCode rep instr (Just revinstr) (CmmLit lit_a) b -- in return (Any rep code) -trivialCode rep instr maybe_revinstr a b = do +trivialCode rep instr maybe_revinstr a b = genTrivialCode rep instr a b + +-- This is re-used for floating pt instructions too. +genTrivialCode rep instr a b = do (b_op, b_code) <- getNonClobberedOperand b a_code <- getAnyReg a tmp <- getNewRegNat rep @@ -4235,7 +4258,7 @@ trivialCode rep instr maybe_revinstr a b = do -- as the destination reg. In this case, we have to save b in a -- new temporary across the computation of a. code dst - | dst `clashesWith` b_op = + | dst `regClashesWithOp` b_op = b_code `appOL` unitOL (MOV rep b_op (OpReg tmp)) `appOL` a_code dst `snocOL` @@ -4246,10 +4269,10 @@ trivialCode rep instr maybe_revinstr a b = do instr b_op (OpReg dst) -- in return (Any rep code) - where - reg `clashesWith` OpReg reg2 = reg == reg2 - reg `clashesWith` OpAddr amode = any (==reg) (addrModeRegs amode) - reg `clashesWith` _ = False + +reg `regClashesWithOp` OpReg reg2 = reg == reg2 +reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) +reg `regClashesWithOp` _ = False ----------- @@ -4281,19 +4304,7 @@ trivialFCode pk instr x y = do #if x86_64_TARGET_ARCH --- We use the 2-operand SSE2 floating pt instructions. ToDo: improve on --- this by using some of the special cases in trivialCode above. -trivialFCode pk instr x y = do - (y_reg, y_code) <- getNonClobberedReg y -- these work for float regs too - x_code <- getAnyReg x - let - code dst = - y_code `appOL` - x_code dst `snocOL` - instr pk (IF_ARCH_x86_64(OpReg,) y_reg) - (IF_ARCH_x86_64(OpReg,) dst) - -- in - return (Any pk code) +trivialFCode pk instr x y = genTrivialCode pk (instr pk) x y #endif @@ -4314,86 +4325,65 @@ trivialUFCode rep instr x = do #if sparc_TARGET_ARCH -trivialCode instr x (StInt y) +trivialCode pk instr x (CmmLit (CmmInt y d)) | fits13Bits y - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - src1 = registerName register tmp + = do + (src1, code) <- getSomeReg x + tmp <- getNewRegNat I32 + let src2 = ImmInt (fromInteger y) code__2 dst = code `snocOL` instr src1 (RIImm src2) dst - in - return (Any IntRep code__2) + return (Any I32 code__2) -trivialCode instr x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat IntRep `thenNat` \ tmp1 -> - getNewRegNat IntRep `thenNat` \ tmp2 -> +trivialCode pk instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + tmp1 <- getNewRegNat I32 + tmp2 <- getNewRegNat I32 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 src1 (RIReg src2) dst - in - return (Any IntRep code__2) + return (Any I32 code__2) ------------ -trivialFCode pk instr x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat (registerRep register1) - `thenNat` \ tmp1 -> - getNewRegNat (registerRep register2) - `thenNat` \ tmp2 -> - getNewRegNat F64 `thenNat` \ tmp -> +trivialFCode pk instr x y = do + (src1, code1) <- getSomeReg x + (src2, code2) <- getSomeReg y + tmp1 <- getNewRegNat (cmmExprRep x) + tmp2 <- getNewRegNat (cmmExprRep y) + tmp <- getNewRegNat F64 let - promote x = FxTOy F DF x tmp + promote x = FxTOy F32 F64 x tmp - pk1 = registerRep register1 - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - pk2 = registerRep register2 - code2 = registerCode register2 tmp2 - src2 = registerName register2 tmp2 + pk1 = cmmExprRep x + pk2 = cmmExprRep y code__2 dst = if pk1 == pk2 then code1 `appOL` code2 `snocOL` - instr (primRepToSize pk) src1 src2 dst + instr pk src1 src2 dst else if pk1 == F32 then code1 `snocOL` promote src1 `appOL` code2 `snocOL` - instr DF tmp src2 dst + instr F64 tmp src2 dst else code1 `appOL` code2 `snocOL` promote src2 `snocOL` - instr DF src1 tmp dst - in + instr F64 src1 tmp dst return (Any (if pk1 == pk2 then pk1 else F64) code__2) ------------ -trivialUCode instr x - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> +trivialUCode pk instr x = do + (src, code) <- getSomeReg x + tmp <- getNewRegNat pk let - code = registerCode register tmp - src = registerName register tmp code__2 dst = code `snocOL` instr (RIReg src) dst - in - return (Any IntRep code__2) + return (Any pk code__2) ------------- -trivialUFCode pk instr x - = getRegister x `thenNat` \ register -> - getNewRegNat pk `thenNat` \ tmp -> +trivialUFCode pk instr x = do + (src, code) <- getSomeReg x + tmp <- getNewRegNat pk let - code = registerCode register tmp - src = registerName register tmp code__2 dst = code `snocOL` instr src dst - in return (Any pk code__2) #endif /* sparc_TARGET_ARCH */ @@ -4588,55 +4578,37 @@ coerceFP2FP to x = do #if sparc_TARGET_ARCH -coerceInt2FP pk x - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ reg -> +coerceInt2FP pk1 pk2 x = do + (src, code) <- getSomeReg x let - code = registerCode register reg - src = registerName register reg - code__2 dst = code `appOL` toOL [ - ST W src (spRel (-2)), - LD W (spRel (-2)) dst, - FxTOy W (primRepToSize pk) dst dst] - in - return (Any pk code__2) + ST pk1 src (spRel (-2)), + LD pk1 (spRel (-2)) dst, + FxTOy pk1 pk2 dst dst] + return (Any pk2 code__2) ------------ -coerceFP2Int fprep x - = ASSERT(fprep == F64 || fprep == F32) - getRegister x `thenNat` \ register -> - getNewRegNat fprep `thenNat` \ reg -> - getNewRegNat F32 `thenNat` \ tmp -> +coerceFP2Int pk fprep x = do + (src, code) <- getSomeReg x + reg <- getNewRegNat fprep + tmp <- getNewRegNat pk let - code = registerCode register reg - src = registerName register reg - code__2 dst = code `appOL` toOL [ - FxTOy (primRepToSize fprep) W src tmp, - ST W tmp (spRel (-2)), - LD W (spRel (-2)) dst] - in - return (Any IntRep code__2) + code__2 dst = ASSERT(fprep == F64 || fprep == F32) + code `appOL` toOL [ + FxTOy fprep pk src tmp, + ST pk tmp (spRel (-2)), + LD pk (spRel (-2)) dst] + return (Any pk code__2) ------------ -coerceDbl2Flt x - = getRegister x `thenNat` \ register -> - getNewRegNat F64 `thenNat` \ tmp -> - let code = registerCode register tmp - src = registerName register tmp - in - return (Any F32 - (\dst -> code `snocOL` FxTOy DF F src dst)) +coerceDbl2Flt x = do + (src, code) <- getSomeReg x + return (Any F32 (\dst -> code `snocOL` FxTOy F64 F32 src dst)) ------------ -coerceFlt2Dbl x - = getRegister x `thenNat` \ register -> - getNewRegNat F32 `thenNat` \ tmp -> - let code = registerCode register tmp - src = registerName register tmp - in - return (Any F64 - (\dst -> code `snocOL` FxTOy F DF src dst)) +coerceFlt2Dbl x = do + (src, code) <- getSomeReg x + return (Any F64 (\dst -> code `snocOL` FxTOy F32 F64 src dst)) #endif /* sparc_TARGET_ARCH */