X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvmCodeGen%2FCodeGen.hs;h=f5dd3bbf830f2c7dbdf348a1447d0a10ff17ff77;hb=18691d440f90a3dff4ef538091c886af505e5cf5;hp=437570f190c0b514f217ade3163d2be41d3093e3;hpb=dc1deadaafcb7b4ced8a6a072382b07c39999327;p=ghc-hetmet.git diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 437570f..f5dd3bb 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -11,10 +11,10 @@ import LlvmCodeGen.Base 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 @@ -26,25 +26,27 @@ import UniqSupply 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) @@ -62,9 +64,9 @@ basicBlocksCodeGen :: LlvmEnv 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') @@ -74,6 +76,16 @@ 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 @@ -83,26 +95,13 @@ basicBlockCodeGen env (BasicBlock id stmts) 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]) @@ -142,7 +141,7 @@ stmtToInstrs env stmt = case stmt of -- 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, []) @@ -151,8 +150,12 @@ stmtToInstrs env stmt = case stmt of 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 @@ -173,11 +176,12 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do 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 @@ -189,12 +193,12 @@ genCall env target res args ret = do 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 @@ -224,7 +228,7 @@ genCall env target res args ret = do 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 @@ -287,23 +291,44 @@ genCall env target res args ret = do | 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 @@ -315,8 +340,8 @@ genCall env target res args ret = do (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. @@ -482,7 +507,7 @@ genStore_fast env addr r n val 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 @@ -562,7 +587,7 @@ genCondBranch env cond idT = do -- | 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 @@ -570,7 +595,7 @@ 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 @@ -650,11 +675,11 @@ genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData 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 -> @@ -693,20 +718,20 @@ genMachOp env _ op [x] = case op of 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 @@ -722,7 +747,7 @@ genMachOp_fast env opt op r n 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, []) @@ -815,7 +840,7 @@ genMachOp_slow env opt op [x, y] = case op of -- ++ "\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 @@ -854,8 +879,8 @@ genMachOp_slow env opt op [x, y] = case op of 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 @@ -920,7 +945,7 @@ genLoad_fast env e r n ty = 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 @@ -969,7 +994,7 @@ genLoad_slow env e ty = 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 @@ -998,7 +1023,7 @@ allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" -- | 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), @@ -1009,7 +1034,7 @@ genLit env cmm@(CmmLabel l) 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], [])]] @@ -1027,14 +1052,14 @@ genLit env cmm@(CmmLabel l) 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) @@ -1139,10 +1164,14 @@ expandCmmReg (reg, off) 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