#include "MachDeps.h"
-- NCG stuff:
-import MachInstrs
-import MachRegs
+import Instrs
+import Regs
import NCGMonad
import PositionIndependentCode
import RegAllocInfo ( mkBranchInstr, mkRegRegMoveInstr )
-import MachRegs
import PprMach
-- Our intermediate code:
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
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)
(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
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
-
- | not $ isFloatType rep
- , W32 <- width
- = unitOL $ mkRegRegMoveInstr (RealReg $ oReg 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))
- | not $ isFloatType rep
- , W64 <- width
- = unitOL $ mkRegRegMoveInstr (RealReg $ oReg 0) r_dest
+ 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
+
+ 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_Pwr -> fsLit "powf"
+
+ MO_F32_Sin -> fsLit "sinf"
+ MO_F32_Cos -> fsLit "cosf"
+ MO_F32_Tan -> fsLit "tanf"
- MO_F32_Sin -> (True, fsLit "sin")
- MO_F32_Cos -> (True, fsLit "cos")
- MO_F32_Tan -> (True, fsLit "tan")
+ MO_F32_Asin -> fsLit "asinf"
+ MO_F32_Acos -> fsLit "acosf"
+ MO_F32_Atan -> fsLit "atanf"
- MO_F32_Asin -> (True, fsLit "asin")
- MO_F32_Acos -> (True, fsLit "acos")
- MO_F32_Atan -> (True, fsLit "atan")
+ MO_F32_Sinh -> fsLit "sinhf"
+ MO_F32_Cosh -> fsLit "coshf"
+ MO_F32_Tanh -> fsLit "tanhf"
- MO_F32_Sinh -> (True, fsLit "sinh")
- MO_F32_Cosh -> (True, fsLit "cosh")
- MO_F32_Tanh -> (True, fsLit "tanh")
+ MO_F64_Exp -> fsLit "exp"
+ MO_F64_Log -> fsLit "log"
+ MO_F64_Sqrt -> fsLit "sqrt"
+ MO_F64_Pwr -> fsLit "pow"
- MO_F64_Exp -> (False, fsLit "exp")
- MO_F64_Log -> (False, fsLit "log")
- MO_F64_Sqrt -> (False, fsLit "sqrt")
+ MO_F64_Sin -> fsLit "sin"
+ MO_F64_Cos -> fsLit "cos"
+ MO_F64_Tan -> fsLit "tan"
- MO_F64_Sin -> (False, fsLit "sin")
- MO_F64_Cos -> (False, fsLit "cos")
- MO_F64_Tan -> (False, fsLit "tan")
+ MO_F64_Asin -> fsLit "asin"
+ MO_F64_Acos -> fsLit "acos"
+ MO_F64_Atan -> fsLit "atan"
- MO_F64_Asin -> (False, fsLit "asin")
- MO_F64_Acos -> (False, fsLit "acos")
- MO_F64_Atan -> (False, fsLit "atan")
+ MO_F64_Sinh -> fsLit "sinh"
+ MO_F64_Cosh -> fsLit "cosh"
+ MO_F64_Tanh -> fsLit "tanh"
- MO_F64_Sinh -> (False, fsLit "sinh")
- MO_F64_Cosh -> (False, fsLit "cosh")
- MO_F64_Tanh -> (False, fsLit "tanh")
+ other -> pprPanic "outOfLineFloatOp(sparc): Unknown callish mach op "
+ (pprCallishMachOp mop)
- other -> pprPanic "outOfLineFloatOp(sparc) "
- (pprCallishMachOp mop)
#endif /* sparc_TARGET_ARCH */
return code
#elif sparc_TARGET_ARCH
genSwitch expr ids
- | opt_PIC
- = error "MachCodeGen: sparc genSwitch PIC not finished\n"
+ | opt_PIC
+ = error "MachCodeGen: sparc genSwitch PIC not finished\n"
- | otherwise
- = error "MachCodeGen: sparc genSwitch non-PIC not finished\n"
+ | otherwise
+ = do (e_reg, e_code) <- getSomeReg expr
+
+ base_reg <- getNewRegNat II32
+ offset_reg <- getNewRegNat II32
+ dst <- getNewRegNat II32
+
+ label <- getNewLabelNat
+ let jumpTable = map jumpTableEntry ids
+
+ return $ e_code `appOL`
+ toOL
+ -- the jump table
+ [ LDATA ReadOnlyData (CmmDataLabel label : jumpTable)
+
+ -- load base of jump table
+ , SETHI (HI (ImmCLbl label)) base_reg
+ , OR False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
+
+ -- the addrs in the table are 32 bits wide..
+ , SLL e_reg (RIImm $ ImmInt 2) offset_reg
+
+ -- load and jump to the destination
+ , LD II32 (AddrRegReg base_reg offset_reg) dst
+ , JMP_TBL (AddrRegImm dst (ImmInt 0)) [i | Just i <- ids]
+ , NOP ]
+
#else
#error "ToDo: genSwitch"
#endif
+
+-- | Convert a BlockId to some CmmStatic data
+jumpTableEntry :: Maybe BlockId -> CmmStatic
jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
where blockLabel = mkAsmTempLabel id
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
-- We (allegedly) put the first six C-call arguments in registers;
-- where do we start putting the rest of them?
--- Moved from MachInstrs (SDM):
+-- Moved from Instrs (SDM):
#if alpha_TARGET_ARCH || sparc_TARGET_ARCH
eXTRA_STK_ARGS_HERE :: Int
projects / ghc-hetmet.git / blobdiff