X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FMachCodeGen.hs;h=6d16da866b458e46ba66f9396e2441b703a4d97d;hb=bca11b6352ea379329a645df1d706e2b28378629;hp=af8408af362f5fc24232a53586a68a8a9b653bd8;hpb=598d761c769316dc4550028285f6508538b8a99c;p=ghc-hetmet.git diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index af8408a..6d16da8 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 @@ -1393,24 +1396,38 @@ reg2reg size src dst #if sparc_TARGET_ARCH +-- getRegister :: CmmExpr -> NatM Register + +-- Load a literal float into a float register. +-- The actual literal is stored in a new data area, and we load it +-- at runtime. getRegister (CmmLit (CmmFloat f W32)) = do + + -- a label for the new data area lbl <- getNewLabelNat + tmp <- getNewRegNat II32 + let code dst = toOL [ + -- the data area LDATA ReadOnlyData [CmmDataLabel lbl, CmmStaticLit (CmmFloat f W32)], - SETHI (HI (ImmCLbl lbl)) dst, - LD FF32 (AddrRegImm dst (LO (ImmCLbl lbl))) dst] + + -- load the literal + SETHI (HI (ImmCLbl lbl)) tmp, + LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] + return (Any FF32 code) getRegister (CmmLit (CmmFloat d W64)) = do lbl <- getNewLabelNat + tmp <- getNewRegNat II32 let code dst = toOL [ LDATA ReadOnlyData [CmmDataLabel lbl, CmmStaticLit (CmmFloat d W64)], - SETHI (HI (ImmCLbl lbl)) dst, - LD FF64 (AddrRegImm dst (LO (ImmCLbl lbl))) dst] + SETHI (HI (ImmCLbl lbl)) tmp, + LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF64 code) getRegister (CmmMachOp mop [x]) -- unary MachOps @@ -2475,7 +2492,7 @@ 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 + Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst where dst = getRegisterReg reg @@ -2577,15 +2594,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 */ @@ -2907,14 +2922,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] ) ) @@ -3467,14 +3482,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. @@ -3506,7 +3547,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 @@ -3516,7 +3558,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] @@ -4135,32 +4177,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 */ @@ -4748,7 +4790,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) ------------