X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FMachCodeGen.hs;h=da2b0eab82de7593ce47c98c7f3c2088cfdab165;hb=abaa832f4b580fabaee9c887bb01da379c7e6482;hp=4228c6c4a19a9b46f4ccfaa7940e5ec9fd1d64df;hpb=246253ea5e7dabcf730b0cebe2db880b87437297;p=ghc-hetmet.git diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs index 4228c6c..da2b0ea 100644 --- a/compiler/nativeGen/MachCodeGen.hs +++ b/compiler/nativeGen/MachCodeGen.hs @@ -371,6 +371,26 @@ iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) r_dst_lo +-- Addition of II64 +iselExpr64 (CmmMachOp (MO_Add width) [e1, e2]) + = do ChildCode64 code1 r1_lo <- iselExpr64 e1 + let r1_hi = getHiVRegFromLo r1_lo + + ChildCode64 code2 r2_lo <- iselExpr64 e2 + let r2_hi = getHiVRegFromLo r2_lo + + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + let code = code1 + `appOL` code2 + `appOL` toOL + [ ADD False False r1_lo (RIReg r2_lo) r_dst_lo + , ADD True False r1_hi (RIReg r2_hi) r_dst_hi ] + + return $ ChildCode64 code r_dst_lo + + iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) | isWord64 ty = do r_dst_lo <- getNewRegNat II32 let r_dst_hi = getHiVRegFromLo r_dst_lo @@ -383,6 +403,23 @@ iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty))) | isWord64 ty = do ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo ) +-- Convert something into II64 +iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) + = do + r_dst_lo <- getNewRegNat II32 + let r_dst_hi = getHiVRegFromLo r_dst_lo + + -- compute expr and load it into r_dst_lo + (a_reg, a_code) <- getSomeReg expr + + let code = a_code + `appOL` toOL + [ mkRegRegMoveInstr g0 r_dst_hi -- clear high 32 bits + , mkRegRegMoveInstr a_reg r_dst_lo ] + + return $ ChildCode64 code r_dst_lo + + iselExpr64 expr = pprPanic "iselExpr64(sparc)" (ppr expr) @@ -3567,8 +3604,9 @@ genCCall target dest_regs args = do (arg_op, arg_code) <- getOperand arg delta <- getDeltaNat setDeltaNat (delta-arg_size) - let code' = code `appOL` toOL [PUSH II64 arg_op, - DELTA (delta-arg_size)] + let code' = code `appOL` arg_code `appOL` toOL [ + PUSH II64 arg_op, + DELTA (delta-arg_size)] push_args rest code' where arg_rep = cmmExprType arg @@ -3606,191 +3644,257 @@ genCCall target dest_regs args = do in preparation for the outer call. Upshot: we need to calculate the args into temporary regs, and move those to arg regs or onto the stack only immediately prior to the call proper. Sigh. + +genCCall + :: CmmCallTarget -- function to call + -> HintedCmmFormals -- where to put the result + -> HintedCmmActuals -- arguments (of mixed type) + -> NatM InstrBlock + -} -genCCall target dest_regs argsAndHints = do - let - args = map hintlessCmm 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 - -- deal with static vs dynamic call targets - callinsns <- (case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv -> do - return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) - CmmCallee 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) - = 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) +-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream +-- are guaranteed to take place before writes afterwards (unlike on PowerPC). +-- Ref: Section 8.4 of the SPARC V9 Architecture manual. +-- +-- In the SPARC case we don't need a barrier. +-- +genCCall (CmmPrim (MO_WriteBarrier)) _ _ + = do return nilOL - -- 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 +genCCall target dest_regs argsAndHints + = do + -- strip hints from the arg regs + let args :: [CmmExpr] + args = map hintlessCmm argsAndHints + + + -- work out the arguments, and assign them to integer regs + argcode_and_vregs <- mapM arg_to_int_vregs args + let (argcodes, vregss) = unzip argcode_and_vregs + let vregs = concat vregss + + let n_argRegs = length allArgRegs + let n_argRegs_used = min (length vregs) n_argRegs + + + -- deal with static vs dynamic call targets + callinsns <- case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv -> + return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) + + CmmCallee 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 <- 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) + + return lblOrMopExpr + + let argcode = concatOL argcodes + + let (move_sp_down, move_sp_up) + = 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))) + + let transfer_code + = toOL (move_final vregs allArgRegs eXTRA_STK_ARGS_HERE) + + return + $ argcode `appOL` + move_sp_down `appOL` + transfer_code `appOL` + callinsns `appOL` + unitOL NOP `appOL` + move_sp_up `appOL` + assign_code dest_regs + + +-- | Generate code to calculate an argument, and move it into one +-- or two integer vregs. +arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) +arg_to_int_vregs arg + + -- If the expr produces a 64 bit int, then we can just use iselExpr64 + | isWord64 (cmmExprType arg) + = do (ChildCode64 code r_lo) <- iselExpr64 arg + let r_hi = getHiVRegFromLo r_lo + return (code, [r_hi, r_lo]) + + | otherwise + = do (src, code) <- getSomeReg arg + tmp <- getNewRegNat (cmmTypeSize $ cmmExprType arg) + let pk = cmmExprType arg + + case cmmTypeSize pk of + + -- Load a 64 bit float return value into two integer regs. + FF64 -> do + v1 <- getNewRegNat II32 + v2 <- getNewRegNat II32 + + let Just f0_high = fPair f0 - | not $ isFloatType rep - , W32 <- width - = unitOL $ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest - - | not $ isFloatType rep - , W64 <- width - , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest_hi - , mkRegRegMoveInstr (RealReg $ oReg 1) r_dest] + let code2 = + code `snocOL` + FMOV FF64 src f0 `snocOL` + ST FF32 f0 (spRel 16) `snocOL` + LD II32 (spRel 16) v1 `snocOL` + ST FF32 f0_high (spRel 16) `snocOL` + LD II32 (spRel 16) v2 + + return (code2, [v1,v2]) + + -- Load a 32 bit float return value into an integer reg + FF32 -> do + v1 <- getNewRegNat II32 - in result + let code2 = + code `snocOL` + ST FF32 src (spRel 16) `snocOL` + LD II32 (spRel 16) v1 - return (argcode `appOL` - move_sp_down `appOL` - transfer_code `appOL` - callinsns `appOL` - unitOL NOP `appOL` - 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. - move_final :: [Reg] -> [Reg] -> Int -> [Instr] - - move_final [] _ offset -- all args done - = [] - - move_final (v:vs) [] offset -- out of aregs; move to stack - = ST II32 v (spRel offset) - : move_final vs [] (offset+1) - - move_final (v:vs) (a:az) offset -- move into an arg (%o[0..5]) reg - = OR False g0 (RIReg v) a - : move_final vs az offset - - -- generate code to calculate an argument, and move it into one - -- or two integer vregs. - arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg]) - arg_to_int_vregs arg - | isWord64 (cmmExprType arg) - = do - (ChildCode64 code r_lo) <- iselExpr64 arg - let - r_hi = getHiVRegFromLo r_lo - return (code, [r_hi, r_lo]) - | otherwise - = do - (src, code) <- getSomeReg arg - tmp <- getNewRegNat (cmmTypeSize $ cmmExprType arg) - let - pk = cmmExprType arg - Just f0_high = fPair f0 - case cmmTypeSize pk of - FF64 -> do - v1 <- getNewRegNat II32 - v2 <- getNewRegNat II32 - return ( - code `snocOL` - FMOV FF64 src f0 `snocOL` - ST FF32 f0 (spRel 16) `snocOL` - LD II32 (spRel 16) v1 `snocOL` - ST FF32 f0_high (spRel 16) `snocOL` - LD II32 (spRel 16) v2 - , - [v1,v2] - ) - FF32 -> do - v1 <- getNewRegNat II32 - return ( - code `snocOL` - ST FF32 src (spRel 16) `snocOL` - LD II32 (spRel 16) v1 - , - [v1] - ) - other -> do - v1 <- getNewRegNat II32 - return ( - code `snocOL` OR False g0 (RIReg src) v1 - , - [v1] - ) -outOfLineFloatOp mop = - do - dflags <- getDynFlagsNat - mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ - 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") + return (code2, [v1]) + + -- Move an integer return value into its destination reg. + other -> do + v1 <- getNewRegNat II32 + + let code2 = + code `snocOL` + OR False g0 (RIReg src) v1 + + return (code2, [v1]) + + +-- | 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] + +-- all args done +move_final [] _ offset + = [] + +-- out of aregs; move to stack +move_final (v:vs) [] offset + = ST II32 v (spRel offset) + : move_final vs [] (offset+1) + +-- move into an arg (%o[0..5]) reg +move_final (v:vs) (a:az) offset + = OR False g0 (RIReg v) a + : move_final vs az offset + + +-- | Assign results returned from the call into their +-- desination regs. +-- +assign_code :: [CmmHinted LocalReg] -> OrdList Instr +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 + + | not $ isFloatType rep + , W64 <- width + , r_dest_hi <- getHiVRegFromLo r_dest + = toOL [ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest_hi + , mkRegRegMoveInstr (RealReg $ oReg 1) r_dest] + in result + + +-- | Generate a call to implement an out-of-line floating point operation +outOfLineFloatOp + :: CallishMachOp + -> NatM (Either CLabel CmmExpr) + +outOfLineFloatOp mop + = do let functionName + = outOfLineFloatOp_table mop + + dflags <- getDynFlagsNat + mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference + $ mkForeignLabel functionName Nothing True + + let mopLabelOrExpr + = case mopExpr of + CmmLit (CmmLabel lbl) -> Left lbl + _ -> Right mopExpr + + return mopLabelOrExpr + + +-- | Decide what C function to use to implement a CallishMachOp +-- +outOfLineFloatOp_table + :: CallishMachOp + -> FastString + +outOfLineFloatOp_table mop + = case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Sin -> (True, fsLit "sin") - MO_F32_Cos -> (True, fsLit "cos") - MO_F32_Tan -> (True, fsLit "tan") + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" - MO_F32_Asin -> (True, fsLit "asin") - MO_F32_Acos -> (True, fsLit "acos") - MO_F32_Atan -> (True, fsLit "atan") + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" - MO_F32_Sinh -> (True, fsLit "sinh") - MO_F32_Cosh -> (True, fsLit "cosh") - MO_F32_Tanh -> (True, fsLit "tanh") + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" - MO_F64_Exp -> (False, fsLit "exp") - MO_F64_Log -> (False, fsLit "log") - MO_F64_Sqrt -> (False, fsLit "sqrt") + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Sin -> (False, fsLit "sin") - MO_F64_Cos -> (False, fsLit "cos") - MO_F64_Tan -> (False, fsLit "tan") + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" - MO_F64_Asin -> (False, fsLit "asin") - MO_F64_Acos -> (False, fsLit "acos") - MO_F64_Atan -> (False, fsLit "atan") + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" - MO_F64_Sinh -> (False, fsLit "sinh") - MO_F64_Cosh -> (False, fsLit "cosh") - MO_F64_Tanh -> (False, fsLit "tanh") + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + other -> pprPanic "outOfLineFloatOp(sparc): Unknown callish mach op " + (pprCallishMachOp mop) - other -> pprPanic "outOfLineFloatOp(sparc) " - (pprCallishMachOp mop) #endif /* sparc_TARGET_ARCH */ @@ -4206,7 +4310,8 @@ genSwitch expr ids -- load and jump to the destination , LD II32 (AddrRegReg base_reg offset_reg) dst - , JMP (AddrRegImm dst (ImmInt 0)) ] + , JMP (AddrRegImm dst (ImmInt 0)) + , NOP ] #else #error "ToDo: genSwitch" @@ -4987,21 +5092,33 @@ coerceInt2FP width1 width2 x = do FxTOy (intSize width1) (floatSize width2) dst dst] return (Any (floatSize $ width2) code__2) ------------- -coerceFP2Int width1 width2 x = do - let pk = intSize width1 - fprep = floatSize width2 - (src, code) <- getSomeReg x - reg <- getNewRegNat fprep - tmp <- getNewRegNat pk - let - code__2 dst = ASSERT(fprep == FF64 || fprep == FF32) - code `appOL` toOL [ - FxTOy fprep pk src tmp, - ST pk tmp (spRel (-2)), - LD pk (spRel (-2)) dst] - return (Any pk code__2) +-- | Coerce a floating point value to integer +-- +-- NOTE: On sparc v9 there are no instructions to move a value from an +-- FP register directly to an int register, so we have to use a load/store. +-- +coerceFP2Int width1 width2 x + = do let fsize1 = floatSize width1 + fsize2 = floatSize width2 + + isize2 = intSize width2 + + (fsrc, code) <- getSomeReg x + fdst <- getNewRegNat fsize2 + + let code2 dst + = code + `appOL` toOL + -- convert float to int format, leaving it in a float reg. + [ FxTOy fsize1 isize2 fsrc fdst + + -- store the int into mem, then load it back to move + -- it into an actual int reg. + , ST fsize2 fdst (spRel (-2)) + , LD isize2 (spRel (-2)) dst] + + return (Any isize2 code2) ------------ coerceDbl2Flt x = do