LlvmCmmTop, LlvmBasicBlock,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
+ LlvmVersion, defaultLlvmVersion,
+
LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
- funLookup, funInsert,
+ funLookup, funInsert, getLlvmVer, setLlvmVer,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits :: Int
llvmPtrBits = widthInBits $ typeWidth gcWord
+-- ----------------------------------------------------------------------------
+-- * Llvm Version
+--
+
+-- | LLVM Version Number
+type LlvmVersion = Int
+
+-- | The LLVM Version we assume if we don't know
+defaultLlvmVersion :: LlvmVersion
+defaultLlvmVersion = 28
-- ----------------------------------------------------------------------------
-- * Environment Handling
--
-type LlvmEnvMap = UniqFM LlvmType
-- two maps, one for functions and one for local vars.
-type LlvmEnv = (LlvmEnvMap, LlvmEnvMap)
+newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion)
+type LlvmEnvMap = UniqFM LlvmType
-- | Get initial Llvm environment.
initLlvmEnv :: LlvmEnv
-initLlvmEnv = (emptyUFM, emptyUFM)
+initLlvmEnv = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion)
-- | Clear variables from the environment.
clearVars :: LlvmEnv -> LlvmEnv
-clearVars (e1, _) = (e1, emptyUFM)
+clearVars (LlvmEnv (e1, _, n)) = LlvmEnv (e1, emptyUFM, n)
-- | Insert functions into the environment.
varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
-varInsert s t (e1, e2) = (e1, addToUFM e2 s t)
-funInsert s t (e1, e2) = (addToUFM e1 s t, e2)
+varInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (e1, addToUFM e2 s t, n)
+funInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (addToUFM e1 s t, e2, n)
-- | Lookup functions in the environment.
varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
-varLookup s (_, e2) = lookupUFM e2 s
-funLookup s (e1, _) = lookupUFM e1 s
+varLookup s (LlvmEnv (_, e2, _)) = lookupUFM e2 s
+funLookup s (LlvmEnv (e1, _, _)) = lookupUFM e1 s
+
+-- | Get the LLVM version we are generating code for
+getLlvmVer :: LlvmEnv -> LlvmVersion
+getLlvmVer (LlvmEnv (_, _, n)) = n
+-- | Set the LLVM version we are generating code for
+setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
+setLlvmVer n (LlvmEnv (e1, e2, _)) = LlvmEnv (e1, e2, n)
-- ----------------------------------------------------------------------------
-- * Label handling
+{-# OPTIONS -fno-warn-type-defaults #-}
-- ----------------------------------------------------------------------------
-- | Handle conversion of CmmProc to LLVM code.
--
import qualified OldPprCmm as PprCmm
import OrdList
-import BasicTypes
import FastString
import ForeignCall
import Outputable hiding ( panic, pprPanic )
where
lmTrue :: LlvmVar
- lmTrue = LMLitVar $ LMIntLit (-1) i1
+ lmTrue = mkIntLit i1 (-1)
#endif
+-- Handle memcpy function specifically since llvm's intrinsic version takes
+-- some extra parameters.
+genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
+ op == MO_Memset ||
+ op == MO_Memmove = do
+ let (isVolTy, isVolVal) = if getLlvmVer env >= 28
+ then ([i1], [mkIntLit i1 0]) else ([], [])
+ argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy
+ | otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy
+ funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+ CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
+
+ (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+ (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
+ (argVars', stmts3) <- castVars $ zip argVars argTy
+
+ let arguments = argVars' ++ isVolVal
+ call = Expr $ Call StdCall fptr arguments []
+ stmts = stmts1 `appOL` stmts2 `appOL` stmts3
+ `appOL` trashStmts `snocOL` call
+ return (env2, stmts, top1 ++ top2)
+
-- Handle all other foreign calls and prim ops.
genCall env target res args ret = do
let ccTy = StdCall -- tail calls should be done through CmmJump
let retTy = ret_type res
let argTy = tysToParams $ map arg_type args
- let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
- lmconv retTy FixedArgs argTy llvmFunAlign
+ let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+ lmconv retTy FixedArgs argTy llvmFunAlign
- -- get parameter values
- (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
- -- get the return register
- let ret_reg ([CmmHinted reg hint]) = (reg, hint)
- ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
- ++ " 1, given " ++ show (length t) ++ "."
-
- -- deal with call types
- let getFunPtr :: CmmCallTarget -> UniqSM ExprData
- getFunPtr targ = case targ of
- CmmCallee (CmmLit (CmmLabel lbl)) _ -> do
- let name = strCLabel_llvm lbl
- case funLookup name env1 of
- Just ty'@(LMFunction sig) -> do
- -- Function in module in right form
- let fun = LMGlobalVar name ty' (funcLinkage sig)
- Nothing Nothing False
- return (env1, fun, nilOL, [])
-
- Just ty' -> do
- -- label in module but not function pointer, convert
- let fty@(LMFunction sig) = funTy name
- let fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
- Nothing Nothing False
- (v1, s1) <- doExpr (pLift fty)
- $ Cast LM_Bitcast fun (pLift fty)
- return (env1, v1, unitOL s1, [])
-
- Nothing -> do
- -- label not in module, create external reference
- let fty@(LMFunction sig) = funTy name
- let fun = LMGlobalVar name fty (funcLinkage sig)
- Nothing Nothing False
- let top = CmmData Data [([],[fty])]
- let env' = funInsert name fty env1
- return (env', fun, nilOL, [top])
-
- CmmCallee expr _ -> do
- (env', v1, stmts, top) <- exprToVar env1 expr
- let fty = funTy $ fsLit "dynamic"
- let cast = case getVarType v1 of
- ty | isPointer ty -> LM_Bitcast
- ty | isInt ty -> LM_Inttoptr
-
- ty -> panic $ "genCall: Expr is of bad type for function"
- ++ " call! (" ++ show (ty) ++ ")"
-
- (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
- return (env', v2, stmts `snocOL` s1, top)
-
- CmmPrim mop -> do
- let name = cmmPrimOpFunctions mop
- let lbl = mkForeignLabel name Nothing
- ForeignLabelInExternalPackage IsFunction
- getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
-
- (env2, fptr, stmts2, top2) <- getFunPtr target
+ (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+ (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target
let retStmt | ccTy == TailCall = unitOL $ Return Nothing
| ret == CmmNeverReturns = unitOL $ Unreachable
| otherwise = nilOL
- {- In LLVM we pass the STG registers around everywhere in function calls.
- So this means LLVM considers them live across the entire function, when
- in reality they usually aren't. For Caller save registers across C calls
- the saving and restoring of them is done by the Cmm code generator,
- using Cmm local vars. So to stop LLVM saving them as well (and saving
- all of them since it thinks they're always live, we trash them just
- before the call by assigning the 'undef' value to them. The ones we
- need are restored from the Cmm local var and the ones we don't need
- are fine to be trashed.
- -}
- let trashStmts = concatOL $ map trashReg activeStgRegs
- where trashReg r =
- let reg = lmGlobalRegVar r
- ty = (pLower . getVarType) reg
- trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
- in case callerSaves r of
- True -> trash
- False -> nilOL
-
let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts
-- make the actual call
_ -> do
(v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
+ -- get the return register
+ let ret_reg ([CmmHinted reg hint]) = (reg, hint)
+ ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
+ ++ " 1, given " ++ show (length t) ++ "."
let (creg, _) = ret_reg res
let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
let allStmts = stmts `snocOL` s1 `appOL` stmts3
`appOL` retStmt, top1 ++ top2 ++ top3)
+-- | Create a function pointer from a target.
+getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget
+ -> UniqSM ExprData
+getFunPtr env funTy targ = case targ of
+ CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm lbl
+
+ CmmCallee expr _ -> do
+ (env', v1, stmts, top) <- exprToVar env expr
+ let fty = funTy $ fsLit "dynamic"
+ cast = case getVarType v1 of
+ ty | isPointer ty -> LM_Bitcast
+ ty | isInt ty -> LM_Inttoptr
+
+ ty -> panic $ "genCall: Expr is of bad type for function"
+ ++ " call! (" ++ show (ty) ++ ")"
+
+ (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
+ return (env', v2, stmts `snocOL` s1, top)
+
+ CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop
+
+ where
+ litCase name = do
+ case funLookup name env of
+ Just ty'@(LMFunction sig) -> do
+ -- Function in module in right form
+ let fun = LMGlobalVar name ty' (funcLinkage sig)
+ Nothing Nothing False
+ return (env, fun, nilOL, [])
+
+ Just ty' -> do
+ -- label in module but not function pointer, convert
+ let fty@(LMFunction sig) = funTy name
+ fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
+ Nothing Nothing False
+ (v1, s1) <- doExpr (pLift fty)
+ $ Cast LM_Bitcast fun (pLift fty)
+ return (env, v1, unitOL s1, [])
+
+ Nothing -> do
+ -- label not in module, create external reference
+ let fty@(LMFunction sig) = funTy name
+ fun = LMGlobalVar name fty (funcLinkage sig)
+ Nothing Nothing False
+ top = [CmmData Data [([],[fty])]]
+ env' = funInsert name fty env
+ return (env', fun, nilOL, top)
+
+
-- | Conversion of call arguments.
arg_vars :: LlvmEnv
-> HintedCmmActuals
= do (env', v1, stmts', top') <- exprToVar env e
arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
+
+-- | Cast a collection of LLVM variables to specific types.
+castVars :: [(LlvmVar, LlvmType)]
+ -> UniqSM ([LlvmVar], LlvmStatements)
+castVars vars = do
+ done <- mapM (uncurry castVar) vars
+ let (vars', stmts) = unzip done
+ return (vars', toOL stmts)
+
+-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
+castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement)
+castVar v t | getVarType v == t
+ = return (v, Nop)
+
+ | otherwise
+ = let op = case (getVarType v, t) of
+ (LMInt n, LMInt m)
+ -> if n < m then LM_Sext else LM_Trunc
+ (vt, _) | isFloat vt && isFloat t
+ -> if llvmWidthInBits vt < llvmWidthInBits t
+ then LM_Fpext else LM_Fptrunc
+ (vt, _) | isInt vt && isFloat t -> LM_Sitofp
+ (vt, _) | isFloat vt && isInt t -> LM_Fptosi
+ (vt, _) | isInt vt && isPointer t -> LM_Inttoptr
+ (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint
+ (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
+
+ (vt, _) -> panic $ "castVars: Can't cast this type ("
+ ++ show vt ++ ") to (" ++ show t ++ ")"
+ in doExpr t $ Cast op v t
+
+
-- | Decide what C function to use to implement a CallishMachOp
-cmmPrimOpFunctions :: CallishMachOp -> FastString
-cmmPrimOpFunctions mop
+cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString
+cmmPrimOpFunctions env mop
= case mop of
MO_F32_Exp -> fsLit "expf"
MO_F32_Log -> fsLit "logf"
MO_F64_Cosh -> fsLit "cosh"
MO_F64_Tanh -> fsLit "tanh"
+ MO_Memcpy -> fsLit $ "llvm.memcpy." ++ intrinTy1
+ MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
+ MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
+
a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
+ where
+ intrinTy1 = (if getLlvmVer env >= 28
+ then "p0i8.p0i8." else "") ++ show llvmWord
+ intrinTy2 = (if getLlvmVer env >= 28
+ then "p0i8." else "") ++ show llvmWord
+
-- | Tail function calls
genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData
(env', vc, stmts, top) <- exprToVar env cond
let ty = getVarType vc
- let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ]
+ let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs
-- out of range is undefied, so lets just branch to first label
let (_, defLbl) = head labels
genMachOp env _ op [x] = case op of
MO_Not w ->
- let all1 = mkIntLit (widthToLlvmInt w) (-1::Int)
+ let all1 = mkIntLit (widthToLlvmInt w) (-1)
in negate (widthToLlvmInt w) all1 LM_MO_Xor
MO_S_Neg w ->
- let all0 = mkIntLit (widthToLlvmInt w) (0::Int)
+ let all0 = mkIntLit (widthToLlvmInt w) 0
in negate (widthToLlvmInt w) all0 LM_MO_Sub
MO_F_Neg w ->
return (vars, concatOL stmts)
+-- | A serries of statements to trash all the STG registers.
+--
+-- In LLVM we pass the STG registers around everywhere in function calls.
+-- So this means LLVM considers them live across the entire function, when
+-- in reality they usually aren't. For Caller save registers across C calls
+-- the saving and restoring of them is done by the Cmm code generator,
+-- using Cmm local vars. So to stop LLVM saving them as well (and saving
+-- all of them since it thinks they're always live, we trash them just
+-- before the call by assigning the 'undef' value to them. The ones we
+-- need are restored from the Cmm local var and the ones we don't need
+-- are fine to be trashed.
+trashStmts :: LlvmStatements
+trashStmts = concatOL $ map trashReg activeStgRegs
+ where trashReg r =
+ let reg = lmGlobalRegVar r
+ ty = (pLower . getVarType) reg
+ trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
+ in case callerSaves r of
+ True -> trash
+ False -> nilOL
+
+
-- | Get a function pointer to the CLabel specified.
--
-- This is for Haskell functions, function type is assumed, so doesn't work
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"
-- -----------------------------------------------------------------------------