module SPARC.CodeGen.CCall (
genCCall
)
where
import SPARC.CodeGen.Gen64
import SPARC.CodeGen.Gen32
import SPARC.CodeGen.Base
import SPARC.Stack
import SPARC.Instr
import SPARC.Imm
import SPARC.Regs
import SPARC.Base
import NCGMonad
import PIC
import Instruction
import Size
import Reg
import Cmm
import CLabel
import BasicTypes
import OrdList
import FastString
import Outputable
genCCall
:: CmmCallTarget
-> HintedCmmFormals
-> HintedCmmActuals
-> NatM InstrBlock
genCCall (CmmPrim (MO_WriteBarrier)) _ _
= do return nilOL
genCCall target dest_regs argsAndHints
= do
let args :: [CmmExpr]
args = map hintlessCmm argsAndHints
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
callinsns <- case target of
CmmCallee (CmmLit (CmmLabel lbl)) _ ->
return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
CmmCallee expr _
-> 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
in if nn <= 0
then (nilOL, nilOL)
else (unitOL (moveSp (1*nn)), unitOL (moveSp (1*nn)))
let transfer_code
= toOL (move_final vregs allArgRegs extraStackArgsHere)
return
$ argcode `appOL`
move_sp_down `appOL`
transfer_code `appOL`
callinsns `appOL`
unitOL NOP `appOL`
move_sp_up `appOL`
assign_code dest_regs
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
let pk = cmmExprType arg
case cmmTypeSize pk of
FF64 -> do
v1 <- getNewRegNat II32
v2 <- getNewRegNat II32
let code2 =
code `snocOL`
FMOV FF64 src f0 `snocOL`
ST FF32 f0 (spRel 16) `snocOL`
LD II32 (spRel 16) v1 `snocOL`
ST FF32 f1 (spRel 16) `snocOL`
LD II32 (spRel 16) v2
return (code2, [v1,v2])
FF32 -> do
v1 <- getNewRegNat II32
let code2 =
code `snocOL`
ST FF32 src (spRel 16) `snocOL`
LD II32 (spRel 16) v1
return (code2, [v1])
_ -> do
v1 <- getNewRegNat II32
let code2 =
code `snocOL`
OR False g0 (RIReg src) v1
return (code2, [v1])
move_final :: [Reg] -> [Reg] -> Int -> [Instr]
move_final [] _ _
= []
move_final (v:vs) [] offset
= ST II32 v (spRel offset)
: move_final vs [] (offset+1)
move_final (v:vs) (a:az) offset
= OR False g0 (RIReg v) a
: move_final vs az offset
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 (regSingle $ fReg 0) r_dest
| isFloatType rep
, W64 <- width
= unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest
| not $ isFloatType rep
, W32 <- width
= unitOL $ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest
| not $ isFloatType rep
, W64 <- width
, r_dest_hi <- getHiVRegFromLo r_dest
= toOL [ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest_hi
, mkRegRegMoveInstr (regSingle $ oReg 1) r_dest]
| otherwise
= panic "SPARC.CodeGen.GenCCall: no match"
in result
assign_code _
= panic "SPARC.CodeGen.GenCCall: no match"
outOfLineFloatOp
:: CallishMachOp
-> NatM (Either CLabel CmmExpr)
outOfLineFloatOp mop
= do let functionName
= outOfLineFloatOp_table mop
dflags <- getDynFlagsNat
mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference
$ mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction
let mopLabelOrExpr
= case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
_ -> Right mopExpr
return mopLabelOrExpr
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_Asin -> fsLit "asinf"
MO_F32_Acos -> fsLit "acosf"
MO_F32_Atan -> fsLit "atanf"
MO_F32_Sinh -> fsLit "sinhf"
MO_F32_Cosh -> fsLit "coshf"
MO_F32_Tanh -> fsLit "tanhf"
MO_F64_Exp -> fsLit "exp"
MO_F64_Log -> fsLit "log"
MO_F64_Sqrt -> fsLit "sqrt"
MO_F64_Pwr -> fsLit "pow"
MO_F64_Sin -> fsLit "sin"
MO_F64_Cos -> fsLit "cos"
MO_F64_Tan -> fsLit "tan"
MO_F64_Asin -> fsLit "asin"
MO_F64_Acos -> fsLit "acos"
MO_F64_Atan -> fsLit "atan"
MO_F64_Sinh -> fsLit "sinh"
MO_F64_Cosh -> fsLit "cosh"
MO_F64_Tanh -> fsLit "tanh"
_ -> pprPanic "outOfLineFloatOp(sparc): Unknown callish mach op "
(pprCallishMachOp mop)