X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FMachCodeGen.hs;h=93f31fb429a335dccacd44fcd1ced46531c4a7cd;hb=0df5099f0c2088e2ccbb5b8974a7eae4d77eaa1c;hp=e62a477ae2f11bc8f88aaf926c4105ea05cf20f3;hpb=8480018a7f5f1cd961f3bd8ae758cc01910d5e6a;p=ghc-hetmet.git diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index e62a477..93f31fb 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -29,7 +29,9 @@ import MachInstrs import MachRegs import NCGMonad import PositionIndependentCode -import RegAllocInfo ( mkBranchInstr ) +import RegAllocInfo ( mkBranchInstr, mkRegRegMoveInstr ) +import MachRegs +import PprMach -- Our intermediate code: import BlockId @@ -57,6 +59,7 @@ import Data.Bits import Data.Word import Data.Int + -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector @@ -1448,23 +1451,46 @@ getRegister (CmmMachOp mop [x]) -- unary MachOps MO_UU_Conv W32 to -> conversionNop (intSize to) x MO_SS_Conv W32 to -> conversionNop (intSize to) x - -- widenings - MO_UU_Conv W8 W32 -> integerExtend False W8 W32 x - MO_UU_Conv W16 W32 -> integerExtend False W16 W32 x - MO_UU_Conv W8 W16 -> integerExtend False W8 W16 x - MO_SS_Conv W16 W32 -> integerExtend True W16 W32 x + MO_UU_Conv W8 to@W32 -> conversionNop (intSize to) x + MO_UU_Conv W16 to@W32 -> conversionNop (intSize to) x + MO_UU_Conv W8 to@W16 -> conversionNop (intSize to) x - other_op -> panic "Unknown unary mach op" + -- sign extension + MO_SS_Conv W8 W32 -> integerExtend W8 W32 x + MO_SS_Conv W16 W32 -> integerExtend W16 W32 x + MO_SS_Conv W8 W16 -> integerExtend W8 W16 x + + other_op -> panic ("Unknown unary mach op: " ++ show mop) 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 (intSize to) code) + + -- | sign extend and widen + integerExtend + :: Width -- ^ width of source expression + -> Width -- ^ width of result + -> CmmExpr -- ^ source expression + -> NatM Register + + integerExtend from to expr + = do -- load the expr into some register + (reg, e_code) <- getSomeReg expr + tmp <- getNewRegNat II32 + let bitCount + = case (from, to) of + (W8, W32) -> 24 + (W16, W32) -> 16 + (W8, W16) -> 24 + let code dst + = e_code + + -- local shift word left to load the sign bit + `snocOL` SLL reg (RIImm (ImmInt bitCount)) tmp + + -- arithmetic shift right to sign extend + `snocOL` SRA tmp (RIImm (ImmInt bitCount)) dst + + return (Any (intSize to) code) + + conversionNop new_rep expr = do e_code <- getRegister expr return (swizzleRegisterRep e_code new_rep) @@ -1493,14 +1519,13 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps MO_Sub W32 -> trivialCode W32 (SUB False False) x y MO_S_MulMayOflo rep -> imulMayOflo rep x y -{- - -- ToDo: teach about V8+ SPARC div instructions - MO_S_Quot W32 -> idiv FSLIT(".div") x y - MO_S_Rem W32 -> idiv FSLIT(".rem") x y - MO_U_Quot W32 -> idiv FSLIT(".udiv") x y - MO_U_Rem W32 -> idiv FSLIT(".urem") x y --} + MO_S_Quot W32 -> idiv True False x y + MO_U_Quot W32 -> idiv False False x y + + MO_S_Rem W32 -> irem True x y + MO_U_Rem W32 -> irem False x y + MO_F_Eq w -> condFltReg EQQ x y MO_F_Ne w -> condFltReg NE x y @@ -1533,9 +1558,115 @@ getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps -} other -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) where - --idiv fn x y = getRegister (StCall (Left fn) CCallConv II32 [x, y]) + -- idiv fn x y = getRegister (StCall (Left fn) CCallConv II32 [x, y]) + + + -- | Generate an integer division instruction. + idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register + + -- For unsigned division with a 32 bit numerator, + -- we can just clear the Y register. + idiv False cc x y = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) + + + -- For _signed_ division with a 32 bit numerator, + -- we have to sign extend the numerator into the Y register. + idiv True cc x y = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp -- sign extend + , SRA tmp (RIImm (ImmInt 16)) tmp + + , WRY tmp g0 + , SDIV cc a_reg (RIReg b_reg) dst] + + return (Any II32 code) + + + -- | Do an integer remainder. + -- + -- NOTE: The SPARC v8 architecture manual says that integer division + -- instructions _may_ generate a remainder, depending on the implementation. + -- If so it is _recommended_ that the remainder is placed in the Y register. + -- + -- The UltraSparc 2007 manual says Y is _undefined_ after division. + -- + -- The SPARC T2 doesn't store the remainder, not sure about the others. + -- It's probably best not to worry about it, and just generate our own + -- remainders. + -- + irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register + + -- For unsigned operands: + -- Division is between a 64 bit numerator and a 32 bit denominator, + -- so we still have to clear the Y register. + irem False x y = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp_reg <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ WRY g0 g0 + , UDIV False a_reg (RIReg b_reg) tmp_reg + , UMUL False tmp_reg (RIReg b_reg) tmp_reg + , SUB False False a_reg (RIReg tmp_reg) dst] + + return (Any II32 code) + + + -- For signed operands: + -- Make sure to sign extend into the Y register, or the remainder + -- will have the wrong sign when the numerator is negative. + -- + -- TODO: When sign extending, GCC only shifts the a_reg right by 17 bits, + -- not the full 32. Not sure why this is, something to do with overflow? + -- If anyone cares enough about the speed of signed remainder they + -- can work it out themselves (then tell me). -- BL 2009/01/20 + + irem True x y = do + (a_reg, a_code) <- getSomeReg x + (b_reg, b_code) <- getSomeReg y + + tmp1_reg <- getNewRegNat II32 + tmp2_reg <- getNewRegNat II32 + + let code dst + = a_code + `appOL` b_code + `appOL` toOL + [ SRA a_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , SRA tmp1_reg (RIImm (ImmInt 16)) tmp1_reg -- sign extend + , WRY tmp1_reg g0 + + , SDIV False a_reg (RIReg b_reg) tmp2_reg + , SMUL False tmp2_reg (RIReg b_reg) tmp2_reg + , SUB False False a_reg (RIReg tmp2_reg) dst] + + return (Any II32 code) + - -------------------- imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register imulMayOflo rep a b = do (a_reg, a_code) <- getSomeReg a @@ -2591,15 +2722,13 @@ assignMem_FltCode pk addr src = do return code__2 -- Floating point assignment to a register/temporary --- 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 +assignReg_FltCode pk dstCmmReg srcCmmExpr = do + srcRegister <- getRegister srcCmmExpr + let dstReg = getRegisterReg dstCmmReg + + return $ case srcRegister of + Any _ code -> code dstReg + Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg #endif /* sparc_TARGET_ARCH */ @@ -2921,14 +3050,14 @@ genCondJump id bool = do #if sparc_TARGET_ARCH -genCondJump (BlockId id) bool = do +genCondJump bid bool = do CondCode is_float cond code <- getCondCode bool return ( code `appOL` toOL ( if is_float - then [NOP, BF cond False (ImmCLbl (mkAsmTempLabel id)), NOP] - else [BI cond False (ImmCLbl (mkAsmTempLabel id)), NOP] + then [NOP, BF cond False bid, NOP] + else [BI cond False bid, NOP] ) ) @@ -3481,14 +3610,40 @@ genCCall target dest_regs argsAndHints = do 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) + + -- assign the results, if necessary + assign_code [] = nilOL + + assign_code [CmmHinted dest _hint] + = let rep = localRegType dest + width = typeWidth rep + r_dest = getRegisterReg (CmmLocal dest) + + result + | isFloatType rep + , W32 <- width + = unitOL $ FMOV FF32 (RealReg $ fReg 0) r_dest + + | isFloatType rep + , W64 <- width + = unitOL $ FMOV FF64 (RealReg $ fReg 0) r_dest + + | not $ isFloatType rep + , W32 <- width + = unitOL $ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest + + in result + return (argcode `appOL` move_sp_down `appOL` transfer_code `appOL` callinsns `appOL` unitOL NOP `appOL` - move_sp_up) + move_sp_up `appOL` + assign_code dest_regs) where -- move args from the integer vregs into which they have been -- marshalled, into %o0 .. %o5, and the rest onto the stack. @@ -3520,7 +3675,8 @@ genCCall target dest_regs argsAndHints = do (src, code) <- getSomeReg arg tmp <- getNewRegNat (cmmTypeSize $ cmmExprType arg) let - pk = cmmExprType arg + pk = cmmExprType arg + Just f0_high = fPair f0 case cmmTypeSize pk of FF64 -> do v1 <- getNewRegNat II32 @@ -3530,7 +3686,7 @@ genCCall target dest_regs argsAndHints = do FMOV FF64 src f0 `snocOL` ST FF32 f0 (spRel 16) `snocOL` LD II32 (spRel 16) v1 `snocOL` - ST FF32 (fPair f0) (spRel 16) `snocOL` + ST FF32 f0_high (spRel 16) `snocOL` LD II32 (spRel 16) v2 , [v1,v2] @@ -4149,32 +4305,32 @@ condIntReg NE x y = do return (Any II32 code__2) condIntReg cond x y = do - BlockId lbl1 <- getBlockIdNat - BlockId lbl2 <- getBlockIdNat + bid1@(BlockId lbl1) <- getBlockIdNat + bid2@(BlockId lbl2) <- getBlockIdNat CondCode _ cond cond_code <- condIntCode cond x y let code__2 dst = cond_code `appOL` toOL [ - BI cond False (ImmCLbl (mkAsmTempLabel lbl1)), NOP, + BI cond False bid1, NOP, OR False g0 (RIImm (ImmInt 0)) dst, - BI ALWAYS False (ImmCLbl (mkAsmTempLabel lbl2)), NOP, - NEWBLOCK (BlockId lbl1), + BI ALWAYS False bid2, NOP, + NEWBLOCK bid1, OR False g0 (RIImm (ImmInt 1)) dst, - NEWBLOCK (BlockId lbl2)] + NEWBLOCK bid2] return (Any II32 code__2) condFltReg cond x y = do - BlockId lbl1 <- getBlockIdNat - BlockId lbl2 <- getBlockIdNat + bid1@(BlockId lbl1) <- getBlockIdNat + bid2@(BlockId lbl2) <- getBlockIdNat CondCode _ cond cond_code <- condFltCode cond x y let code__2 dst = cond_code `appOL` toOL [ NOP, - BF cond False (ImmCLbl (mkAsmTempLabel lbl1)), NOP, + BF cond False bid1, NOP, OR False g0 (RIImm (ImmInt 0)) dst, - BI ALWAYS False (ImmCLbl (mkAsmTempLabel lbl2)), NOP, - NEWBLOCK (BlockId lbl1), + BI ALWAYS False bid2, NOP, + NEWBLOCK bid1, OR False g0 (RIImm (ImmInt 1)) dst, - NEWBLOCK (BlockId lbl2)] + NEWBLOCK bid2] return (Any II32 code__2) #endif /* sparc_TARGET_ARCH */ @@ -4762,7 +4918,7 @@ coerceInt2FP width1 width2 x = do code__2 dst = code `appOL` toOL [ ST (intSize width1) src (spRel (-2)), LD (intSize width1) (spRel (-2)) dst, - FxTOy (intSize width1) (floatSize width1) dst dst] + FxTOy (intSize width1) (floatSize width2) dst dst] return (Any (floatSize $ width2) code__2) ------------