import LlvmCodeGen.Regs
import BlockId
-import CgUtils ( activeStgRegs )
+import CgUtils ( activeStgRegs, callerSaves )
import CLabel
import Cmm
import qualified PprCmm
type LlvmStatements = OrdList LlvmStatement
-- -----------------------------------------------------------------------------
--- | Top-level of the llvm proc codegen
+-- | Top-level of the LLVM proc Code generator
--
genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop])
genLlvmProc env (CmmData _ _)
-- | Allocations need to be extracted so they can be moved to the entry
--- of a function to make sure they dominate all posible paths in the CFG.
+-- 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)
--
-- A statement conversion return data.
--- * LlvmEnv: The new enviornment
--- * LlvmStatements: The compiled llvm statements.
+-- * LlvmEnv: The new environment
+-- * LlvmStatements: The compiled LLVM statements.
-- * LlvmCmmTop: Any global data needed.
type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmTop])
-- CPS, only tail calls, no return's
-- Actually, there are a few return statements that occur because of hand
- -- written cmm code.
+ -- written Cmm code.
CmmReturn _
-> return (env, unitOL $ Return Nothing, [])
genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals
-> CmmReturnInfo -> UniqSM StmtData
--- Write barrier needs to be handled specially as it is implemented as an llvm
+-- Write barrier needs to be handled specially as it is implemented as an LLVM
-- intrinsic function.
genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
let fname = fsLit "llvm.memory.barrier"
-- Handle all other foreign calls and prim ops.
genCall env target res args ret = do
- -- paramater types
+ -- parameter types
let arg_type (CmmHinted _ AddrHint) = i8Ptr
-- cast pointers to i8*. Llvm equivalent of void*
arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType expr
ret_type t = panic $ "genCall: Too many return values! Can only handle"
++ " 0 or 1, given " ++ show (length t) ++ "."
- -- extract cmm call convention
+ -- extract Cmm call convention
let cconv = case target of
CmmCallee _ conv -> conv
CmmPrim _ -> PrimCallConv
- -- translate to llvm call convention
+ -- translate to LLVM call convention
let lmconv = case cconv of
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
StdCallConv -> CC_X86_Stdcc
let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
lmconv retTy FixedArgs argTy llvmFunAlign
- -- get paramter values
+ -- get parameter values
(env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
-- get the return register
| 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
case retTy of
LMVoid -> do
let s1 = Expr $ Call ccTy fptr argVars fnAttrs
- let allStmts = stmts1 `appOL` stmts2 `snocOL` s1 `appOL` retStmt
+ let allStmts = stmts `snocOL` s1 `appOL` retStmt
return (env2, allStmts, top1 ++ top2)
_ -> do
+ (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
let (creg, _) = ret_reg res
let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
- let allStmts = stmts1 `appOL` stmts2 `appOL` stmts3
- (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
+ let allStmts = stmts `snocOL` s1 `appOL` stmts3
if retTy == pLower (getVarType vreg)
then do
let s2 = Store v1 vreg
- return (env3, allStmts `snocOL` s1 `snocOL` s2
- `appOL` retStmt, top1 ++ top2 ++ top3)
+ return (env3, allStmts `snocOL` s2 `appOL` retStmt,
+ top1 ++ top2 ++ top3)
else do
let ty = pLower $ getVarType vreg
let op = case ty of
(v2, s2) <- doExpr ty $ Cast op v1 ty
let s3 = Store v2 vreg
- return (env3, allStmts `snocOL` s1 `snocOL` s2 `snocOL` s3
- `appOL` retStmt, top1 ++ top2 ++ top3)
+ return (env3, allStmts `snocOL` s2 `snocOL` s3
+ `appOL` retStmt, top1 ++ top2 ++ top3)
-- | Conversion of call arguments.
genStore_fast env addr r n val
= let gr = lmGlobalRegVar r
grt = (pLower . getVarType) gr
- ix = n `div` ((llvmWidthInBits . pLower) grt `div` 8)
- in case isPointer grt of
+ (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
+ in case isPointer grt && rem == 0 of
True -> do
(env', vval, stmts, top) <- exprToVar env val
(gv, s1) <- doExpr grt $ Load gr
- (ptr, s2) <- doExpr grt $ GetElemPtr gv [ix]
+ (ptr, s2) <- doExpr grt $ GetElemPtr True gv [ix]
-- We might need a different pointer type, so check
case pLower grt == getVarType vval of
-- were fine
-- | Switch branch
--
--- N.B. we remove Nothing's from the list of branches, as they are 'undefined'.
+-- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
-- However, they may be defined one day, so we better document this behaviour.
genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
genSwitch env cond maybe_ids = do
-> genLit env lit
CmmLoad e' ty
- -> genCmmLoad env e' ty
+ -> genLoad env e' ty
-- Cmmreg in expression is the value, so must load. If you want actual
-- reg pointer, call getCmmReg directly.
case (isPointer . getVarType) v1 of
True -> do
-- Cmm wants the value, so pointer types must be cast to ints
- -- TODO: Remove, keep as pointers as much as possible
(v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord
return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
return (env', v1, stmts `snocOL` s1, top)
let toWidth = llvmWidthInBits ty
-- LLVM doesn't like trying to convert to same width, so
- -- need to check for that as we do get cmm code doing it.
+ -- need to check for that as we do get Cmm code doing it.
case widthInBits from of
w | w < toWidth -> sameConv' expand
w | w > toWidth -> sameConv' reduce
_w -> return x'
+-- Handle GlobalRegs pointers
+genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+ = genMachOp_fast env opt o r (fromInteger n) e
+
+genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+ = genMachOp_fast env opt o r (negate . fromInteger $ n) e
+
+-- Generic case
+genMachOp env opt op e = genMachOp_slow env opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This is a specialised method that handles Global register manipulations like
+-- 'Sp - 16', using the getelementptr instruction.
+genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
+ -> UniqSM ExprData
+genMachOp_fast env opt op r n e
+ = let gr = lmGlobalRegVar r
+ grt = (pLower . getVarType) gr
+ (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
+ in case isPointer grt && rem == 0 of
+ True -> do
+ (gv, s1) <- doExpr grt $ Load gr
+ (ptr, s2) <- doExpr grt $ GetElemPtr True gv [ix]
+ (var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord
+ return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
+
+ False -> genMachOp_slow env opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This handles all the cases not handle by the specialised genMachOp_fast.
+genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
-- Binary MachOp
-genMachOp env opt op [x, y] = case op of
+genMachOp_slow env opt op [x, y] = case op of
MO_Eq _ -> genBinComp opt LM_CMP_Eq
MO_Ne _ -> genBinComp opt LM_CMP_Ne
-- ++ "\ne2: " ++ (show.llvmSDoc.PprCmm.pprExpr $ y)
-- | Need to use EOption here as Cmm expects word size results from
- -- comparisons while llvm return i1. Need to extend to llvmWord type
+ -- comparisons while LLVM return i1. Need to extend to llvmWord type
-- if expected
genBinComp opt cmp = do
ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) $ Compare cmp
else
panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
-
-- More then two expression, invalid!
-genMachOp _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
+genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
-- | Handle CmmLoad expression.
-genCmmLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
+genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
-- First we try to detect a few common cases and produce better code for
-- these then the default case. We are mostly trying to detect Cmm code
-- like I32[Sp + n] and use 'getelementptr' operations instead of the
-- generic case that uses casts and pointer arithmetic
-genCmmLoad env e@(CmmReg (CmmGlobal r)) ty
- = genCmmLoad_fast env e r 0 ty
+genLoad env e@(CmmReg (CmmGlobal r)) ty
+ = genLoad_fast env e r 0 ty
-genCmmLoad env e@(CmmRegOff (CmmGlobal r) n) ty
- = genCmmLoad_fast env e r n ty
+genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
+ = genLoad_fast env e r n ty
-genCmmLoad env e@(CmmMachOp (MO_Add _) [
+genLoad env e@(CmmMachOp (MO_Add _) [
(CmmReg (CmmGlobal r)),
(CmmLit (CmmInt n _))])
ty
- = genCmmLoad_fast env e r (fromInteger n) ty
+ = genLoad_fast env e r (fromInteger n) ty
-genCmmLoad env e@(CmmMachOp (MO_Sub _) [
+genLoad env e@(CmmMachOp (MO_Sub _) [
(CmmReg (CmmGlobal r)),
(CmmLit (CmmInt n _))])
ty
- = genCmmLoad_fast env e r (negate $ fromInteger n) ty
+ = genLoad_fast env e r (negate $ fromInteger n) ty
-- generic case
-genCmmLoad env e ty = genCmmLoad_slow env e ty
+genLoad env e ty = genLoad_slow env e ty
-- | Handle CmmLoad expression.
-- This is a special case for loading from a global register pointer
-- offset such as I32[Sp+8].
-genCmmLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
+genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
-> UniqSM ExprData
-genCmmLoad_fast env e r n ty =
+genLoad_fast env e r n ty =
let gr = lmGlobalRegVar r
grt = (pLower . getVarType) gr
- ix = n `div` ((llvmWidthInBits . pLower) grt `div` 8)
ty' = cmmToLlvmType ty
- in case isPointer grt of
+ (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8)
+ in case isPointer grt && rem == 0 of
True -> do
(gv, s1) <- doExpr grt $ Load gr
- (ptr, s2) <- doExpr grt $ GetElemPtr gv [ix]
+ (ptr, s2) <- doExpr grt $ GetElemPtr True gv [ix]
-- We might need a different pointer type, so check
case grt == ty' of
-- were fine
-- If its a bit type then we use the slow method since
-- we can't avoid casting anyway.
- False -> genCmmLoad_slow env e ty
+ False -> genLoad_slow env e ty
-- | Handle Cmm load expression.
-- Generic case. Uses casts and pointer arithmetic if needed.
-genCmmLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
-genCmmLoad_slow env e ty = do
+genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
+genLoad_slow env e ty = do
(env', iptr, stmts, tops) <- exprToVar env e
case getVarType iptr of
LMPointer _ -> do
--
-- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
-- equivalent SSA form and avoids having to deal with Phi node insertion.
--- This is also the approach recommended by llvm developers.
+-- This is also the approach recommended by LLVM developers.
getCmmReg :: LlvmEnv -> CmmReg -> ExprData
getCmmReg env r@(CmmLocal (LocalReg un _))
= let exists = varLookup un env
ty = funLookup label env
lmty = cmmToLlvmType $ cmmLitType cmm
in case ty of
- -- Make generic external label defenition and then pointer to it
+ -- Make generic external label definition and then pointer to it
Nothing -> do
let glob@(var, _) = genStringLabelRef label
let ldata = [CmmData Data [([glob], [])]]
projects / ghc-hetmet.git / blobdiff