import Debug.Trace ( trace )
import Control.Monad ( mapAndUnzipM )
-import Data.Maybe ( fromJust )
+import Data.Maybe ( fromJust, catMaybes )
import Data.Bits
import Data.Word
import Data.Int
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
+-- void return type prim op
+genCCall (CmmPrim op) [] args =
+ outOfLineCmmOp op Nothing args
+
-- we only cope with a single result for foreign calls
-genCCall (CmmPrim op) [CmmHinted r _] args = do
+genCCall (CmmPrim op) [r_hinted@(CmmHinted r _)] args = do
l1 <- getNewLabelNat
l2 <- getNewLabelNat
sse2 <- sse2Enabled
if sse2
then
- outOfLineFloatOp op r args
+ outOfLineCmmOp op (Just r_hinted) args
else case op of
MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args
MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args
MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args
MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args
- other_op -> outOfLineFloatOp op r args
+ other_op -> outOfLineCmmOp op (Just r_hinted) args
where
actuallyInlineFloatOp instr size [CmmHinted x _]
-- deal with static vs dynamic call targets
(callinsns,cconv) <-
case target of
- -- CmmPrim -> ...
CmmCallee (CmmLit (CmmLabel lbl)) conv
-> -- ToDo: stdcall arg sizes
return (unitOL (CALL (Left fn_imm) []), conv)
-> do { (dyn_r, dyn_c) <- getSomeReg expr
; ASSERT( isWord32 (cmmExprType expr) )
return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
+ CmmPrim _
+ -> panic $ "genCCall: Can't handle CmmPrim call type here, error "
+ ++ "probably because too many return values."
let push_code
#if darwin_TARGET_OS
roundTo a x | x `mod` a == 0 = x
| otherwise = x + a - (x `mod` a)
-
push_arg :: Bool -> HintedCmmActual {-current argument-}
-> NatM InstrBlock -- code
-- write barrier compiles to no code on x86/x86-64;
-- we keep it this long in order to prevent earlier optimisations.
+-- void return type prim op
+genCCall (CmmPrim op) [] args =
+ outOfLineCmmOp op Nothing args
-genCCall (CmmPrim op) [CmmHinted r _] args =
- outOfLineFloatOp op r args
+-- we only cope with a single result for foreign calls
+genCCall (CmmPrim op) [res] args =
+ outOfLineCmmOp op (Just res) args
genCCall target dest_regs args = do
-- deal with static vs dynamic call targets
(callinsns,cconv) <-
case target of
- -- CmmPrim -> ...
CmmCallee (CmmLit (CmmLabel lbl)) conv
-> -- ToDo: stdcall arg sizes
return (unitOL (CALL (Left fn_imm) arg_regs), conv)
CmmCallee expr conv
-> do (dyn_r, dyn_c) <- getSomeReg expr
return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
+ CmmPrim _
+ -> panic $ "genCCall: Can't handle CmmPrim call type here, error "
+ ++ "probably because too many return values."
let
-- The x86_64 ABI requires us to set %al to the number of SSE2
#endif /* x86_64_TARGET_ARCH */
-
-
-outOfLineFloatOp :: CallishMachOp -> CmmFormal -> HintedCmmActuals -> NatM InstrBlock
-outOfLineFloatOp mop res args
+outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> HintedCmmActuals -> NatM InstrBlock
+outOfLineCmmOp mop res args
= do
dflags <- getDynFlagsNat
targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl
let target = CmmCallee targetExpr CCallConv
- stmtToInstrs (CmmCall target [CmmHinted res NoHint] args CmmUnsafe CmmMayReturn)
+ stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmUnsafe CmmMayReturn)
where
-- Assume we can call these functions directly, and that they're not in a dynamic library.
-- TODO: Why is this ok? Under linux this code will be in libm.so
-- Is is because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31
lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction
+ args' = case mop of
+ MO_Memcpy -> init args
+ MO_Memset -> init args
+ MO_Memmove -> init args
+ _ -> args
+
fn = case mop of
MO_F32_Sqrt -> fsLit "sqrtf"
MO_F32_Sin -> fsLit "sinf"
MO_F64_Tanh -> fsLit "tanh"
MO_F64_Pwr -> fsLit "pow"
-
-
+ MO_Memcpy -> fsLit "memcpy"
+ MO_Memset -> fsLit "memset"
+ MO_Memmove -> fsLit "memmove"
-- -----------------------------------------------------------------------------