X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FMachCodeGen.hs;h=0c9aec67cdbaa37754a107649d622f9be833b132;hb=c6e9a86f03efb4fdef5ed10fcb93b64439fdec60;hp=e62a477ae2f11bc8f88aaf926c4105ea05cf20f3;hpb=8480018a7f5f1cd961f3bd8ae758cc01910d5e6a;p=ghc-hetmet.git diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index e62a477..0c9aec6 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) @@ -2591,15 +2617,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 +2945,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 +3505,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 +3570,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 +3581,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 +4200,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 +4813,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) ------------