+{-# OPTIONS -fno-warn-type-defaults #-}
-- ----------------------------------------------------------------------------
-- | Handle conversion of CmmProc to LLVM code.
--
import BlockId
import CgUtils ( activeStgRegs, callerSaves )
import CLabel
-import Cmm
-import qualified PprCmm
+import OldCmm
+import qualified OldPprCmm as PprCmm
import OrdList
-import BasicTypes
import FastString
import ForeignCall
import Outputable hiding ( panic, pprPanic )
import Unique
import Util
+import Data.List ( partition )
import Control.Monad ( liftM )
type LlvmStatements = OrdList LlvmStatement
+
-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM proc Code generator
--
genLlvmProc env (CmmData _ _)
= return (env, [])
-genLlvmProc env (CmmProc _ _ _ (ListGraph []))
+genLlvmProc env (CmmProc _ _ (ListGraph []))
= return (env, [])
-genLlvmProc env (CmmProc info lbl params (ListGraph blocks))
+genLlvmProc env (CmmProc info lbl (ListGraph blocks))
= do
(env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
- let proc = CmmProc info lbl params (ListGraph lmblocks)
+ let proc = CmmProc info lbl (ListGraph lmblocks)
let tops = lmdata ++ [proc]
return (env', tops)
basicBlocksCodeGen env ([]) (blocks, tops)
= do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
let allocs' = concat allocs
- let ((BasicBlock id fstmts):rblocks) = blocks'
+ let ((BasicBlock id fstmts):rblks) = blocks'
fplog <- funPrologue
- let fblocks = (BasicBlock id (fplog ++ allocs' ++ fstmts)):rblocks
+ let fblocks = (BasicBlock id (fplog ++ allocs' ++ fstmts)):rblks
return (env, fblocks, tops)
basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
basicBlocksCodeGen env' blocks (lblocks, ltops)
+-- | Allocations need to be extracted so they can be moved to the entry
+-- of a function to make sure they dominate all possible paths in the CFG.
+dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
+dominateAllocs (BasicBlock id stmts)
+ = let (allocs, stmts') = partition isAlloc stmts
+ isAlloc (Assignment _ (Alloca _ _)) = True
+ isAlloc _other = False
+ in (BasicBlock id stmts', allocs)
+
+
-- | Generate code for one block
basicBlockCodeGen :: LlvmEnv
-> CmmBasicBlock
return (env', [BasicBlock id (fromOL instrs)], top)
--- | Allocations need to be extracted so they can be moved to the entry
--- of a function to make sure they dominate all possible paths in the CFG.
-dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
-dominateAllocs (BasicBlock id stmts)
- = (BasicBlock id allstmts, allallocs)
- where
- (allstmts, allallocs) = foldl split ([],[]) stmts
- split (stmts', allocs) s@(Assignment _ (Alloca _ _))
- = (stmts', allocs ++ [s])
- split (stmts', allocs) other
- = (stmts' ++ [other], allocs)
-
-
-- -----------------------------------------------------------------------------
-- * CmmStmt code generation
--
-- | Foreign Calls
-genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals
+genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
-> CmmReturnInfo -> UniqSM StmtData
-- Write barrier needs to be handled specially as it is implemented as an LLVM
-- intrinsic function.
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH || sparc_TARGET_ARCH
+genCall env (CmmPrim MO_WriteBarrier) _ _ _ = return (env, nilOL, [])
+
+#else
genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
let fname = fsLit "llvm.memory.barrier"
let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
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
+ -> [HintedCmmActual]
-> ([LlvmVar], LlvmStatements, [LlvmCmmTop])
-> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop])
= 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