import LlvmCodeGen.Regs
import BlockId
-import CgUtils ( activeStgRegs )
+import CgUtils ( activeStgRegs, callerSaves )
import CLabel
-import Cmm
-import qualified PprCmm
+import OldCmm
+import qualified OldPprCmm as PprCmm
import OrdList
import BasicTypes
import Unique
import Util
+import Data.List ( partition )
import Control.Monad ( liftM )
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 _ _)
= 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 posible 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
--
-- 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.
+#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
+#endif
-- 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.
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 [toI32 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
let ty = getVarType vc
let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ]
- let labels = map (\(ix, b) -> (mkIntLit ix ty, blockIdToLlvm b)) pairs
+ 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 (-1::Int) (widthToLlvmInt w)
+ let all1 = mkIntLit (widthToLlvmInt w) (-1::Int)
in negate (widthToLlvmInt w) all1 LM_MO_Xor
MO_S_Neg w ->
- let all0 = mkIntLit (0::Int) (widthToLlvmInt w)
+ let all0 = mkIntLit (widthToLlvmInt w) (0::Int)
in negate (widthToLlvmInt w) all0 LM_MO_Sub
MO_F_Neg w ->
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
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 [toI32 ix]
(var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord
return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
-- ++ "\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
let word = getVarType vx
let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx)
let shift = llvmWidthInBits word
- let shift1 = mkIntLit (shift - 1) llvmWord
- let shift2 = mkIntLit shift llvmWord
+ let shift1 = toIWord (shift - 1)
+ let shift2 = toIWord shift
if isInt word
then do
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 [toI32 ix]
-- We might need a different pointer type, so check
case grt == ty' of
-- were fine
--
-- 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
-- | Generate code for a literal
genLit :: LlvmEnv -> CmmLit -> UniqSM ExprData
genLit env (CmmInt i w)
- = return (env, mkIntLit i (LMInt $ widthInBits w), nilOL, [])
+ = return (env, mkIntLit (LMInt $ widthInBits w) i, nilOL, [])
genLit env (CmmFloat r w)
= return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
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], [])]]
genLit env (CmmLabelOff label off) = do
(env', vlbl, stmts, stat) <- genLit env (CmmLabel label)
- let voff = mkIntLit off llvmWord
+ let voff = toIWord off
(v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
return (env', v1, stmts `snocOL` s1, stat)
genLit env (CmmLabelDiffOff l1 l2 off) = do
(env1, vl1, stmts1, stat1) <- genLit env (CmmLabel l1)
(env2, vl2, stmts2, stat2) <- genLit env1 (CmmLabel l2)
- let voff = mkIntLit off llvmWord
+ let voff = toIWord off
let ty1 = getVarType vl1
let ty2 = getVarType vl2
if (isInt ty1) && (isInt ty2)
blockIdToLlvm :: BlockId -> LlvmVar
blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
-
-- | Create Llvm int Literal
-mkIntLit :: Integral a => a -> LlvmType -> LlvmVar
-mkIntLit i ty = LMLitVar $ LMIntLit (toInteger i) ty
+mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
+mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
+
+-- | Convert int type to a LLvmVar of word or i32 size
+toI32, toIWord :: Integral a => a -> LlvmVar
+toI32 = mkIntLit i32
+toIWord = mkIntLit llvmWord
-- | Error functions
projects / ghc-hetmet.git / blobdiff