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.
-- | 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
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
+-- 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
+-- Generic case
genMachOp env opt op e = genMachOp_slow env opt op e
-- ++ "\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
--
-- 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], [])]]