diff options
Diffstat (limited to 'compiler/llvmGen/LlvmCodeGen/CodeGen.hs')
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 197 |
1 files changed, 102 insertions, 95 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index d62fbf4397..b5d4b4a76c 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -3,6 +3,7 @@ -- | Handle conversion of CmmProc to LLVM code. -- +{-# LANGUAGE GADTs #-} module LlvmCodeGen.CodeGen ( genLlvmProc ) where #include "HsVersions.h" @@ -14,8 +15,10 @@ import LlvmCodeGen.Regs import BlockId import CodeGen.Platform ( activeStgRegs, callerSaves ) import CLabel -import OldCmm -import qualified OldPprCmm as PprCmm +import Cmm +import PprCmm +import CmmUtils +import Hoopl import DynFlags import FastString @@ -37,9 +40,10 @@ type LlvmStatements = OrdList LlvmStatement -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do +genLlvmProc env proc0@(CmmProc infos lbl live graph) = do + let blocks = toBlockList graph (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], []) - let info = topInfoTable proc0 + let info = mapLookup (g_entry graph) infos proc = CmmProc info lbl live (ListGraph lmblocks) return (env', proc:lmdata) @@ -52,22 +56,23 @@ genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" -- | Generate code for a list of blocks that make up a complete procedure. basicBlocksCodeGen :: LlvmEnv -> LiveGlobalRegs - -> [CmmBasicBlock] + -> [CmmBlock] -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) -basicBlocksCodeGen env live ([]) (blocks, tops) - = do let dflags = getDflags env - let (blocks', allocs) = mapAndUnzip dominateAllocs blocks - let allocs' = concat allocs - let ((BasicBlock id fstmts):rblks) = blocks' - let fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks - return (env, fblocks, tops) - -basicBlocksCodeGen env live (block:blocks) (lblocks', ltops') +basicBlocksCodeGen env live [] (blocks0, tops0) + = return (env, fblocks, tops) + where + dflags = getDflags env + blocks = reverse blocks0 + tops = reverse tops0 + (blocks', allocs) = mapAndUnzip dominateAllocs blocks + allocs' = concat allocs + (BasicBlock id fstmts : rblks) = blocks' + fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks + +basicBlocksCodeGen env live (block:blocks) (lblocks, ltops) = do (env', lb, lt) <- basicBlockCodeGen env block - let lblocks = lblocks' ++ lb - let ltops = ltops' ++ lt - basicBlocksCodeGen env' live blocks (lblocks, ltops) + basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops) -- | Allocations need to be extracted so they can be moved to the entry @@ -81,16 +86,19 @@ dominateAllocs (BasicBlock id stmts) -- | Generate code for one block -basicBlockCodeGen :: LlvmEnv - -> CmmBasicBlock - -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmDecl] ) -basicBlockCodeGen env (BasicBlock id stmts) - = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, []) - return (env', [BasicBlock id (fromOL instrs)], top) - +basicBlockCodeGen :: LlvmEnv + -> CmmBlock + -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen env block + = do let (CmmEntry id, nodes, tail) = blockSplit block + let stmts = blockToList nodes + (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, []) + (env'', tail_instrs, top') <- stmtToInstrs env' tail + let instrs = fromOL (mid_instrs `appOL` tail_instrs) + return (env'', BasicBlock id instrs, top' ++ top) -- ----------------------------------------------------------------------------- --- * CmmStmt code generation +-- * CmmNode code generation -- -- A statement conversion return data. @@ -100,8 +108,8 @@ basicBlockCodeGen env (BasicBlock id stmts) type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl]) --- | Convert a list of CmmStmt's to LlvmStatement's -stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmDecl]) +-- | Convert a list of CmmNode's to LlvmStatement's +stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl]) -> UniqSM StmtData stmtsToInstrs env [] (llvm, top) = return (env, llvm, top) @@ -111,34 +119,28 @@ stmtsToInstrs env (stmt : stmts) (llvm, top) stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops) --- | Convert a CmmStmt to a list of LlvmStatement's -stmtToInstrs :: LlvmEnv -> CmmStmt +-- | Convert a CmmNode to a list of LlvmStatement's +stmtToInstrs :: LlvmEnv -> CmmNode e x -> UniqSM StmtData stmtToInstrs env stmt = case stmt of - CmmNop -> return (env, nilOL, []) CmmComment _ -> return (env, nilOL, []) -- nuke comments CmmAssign reg src -> genAssign env reg src CmmStore addr src -> genStore env addr src CmmBranch id -> genBranch env id - CmmCondBranch arg id -> genCondBranch env arg id + CmmCondBranch arg true false -> genCondBranch env arg true false CmmSwitch arg ids -> genSwitch env arg ids -- Foreign Call - CmmCall target res args ret - -> genCall env target res args ret + CmmUnsafeForeignCall target res args -> genCall env target res args -- Tail call - CmmJump arg live -> genJump env arg live - - -- CPS, only tail calls, no return's - -- Actually, there are a few return statements that occur because of hand - -- written Cmm code. - CmmReturn - -> return (env, unitOL $ Return Nothing, []) + CmmCall { cml_target = arg, + cml_args_regs = live } -> genJump env arg live + _ -> panic "Llvm.CodeGen.stmtToInstrs" -- | Memory barrier instruction for LLVM >= 3.0 barrier :: LlvmEnv -> UniqSM StmtData @@ -171,12 +173,12 @@ oldBarrier env = do lmTrue = mkIntLit i1 (-1) -- | Foreign Calls -genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] - -> CmmReturnInfo -> UniqSM StmtData +genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> UniqSM StmtData -- Write barrier needs to be handled specially as it is implemented as an LLVM -- intrinsic function. -genCall env (CmmPrim MO_WriteBarrier _) _ _ _ +genCall env (PrimTarget MO_WriteBarrier) _ _ | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] = return (env, nilOL, []) | getLlvmVer env > 29 = barrier env @@ -186,7 +188,7 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _ -- types and things like Word8 are backed by an i32 and just present a logical -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- is strict about types. -genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do +genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do let dflags = getDflags env width = widthToLlvmInt w dstTy = cmmToLlvmType $ localRegType dst @@ -194,7 +196,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do CC_Ccc width FixedArgs (tysToParams [width]) Nothing (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) - (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, []) + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, []) (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t (argsV', stmts4) <- castVars dflags $ zip argsV [width] (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] @@ -207,7 +211,7 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. -genCall env t@(CmmPrim op _) [] args' CmmMayReturn +genCall env t@(PrimTarget op) [] args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = do @@ -220,7 +224,9 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing - (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t (argVars', stmts3) <- castVars dflags $ zip argVars argTy @@ -236,48 +242,43 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other -- than a direct constant (i.e. 'i32 8') as the alignment argument for the -- memcpy & co llvm intrinsic functions. So we handle this directly now. - extractLit (CmmHinted (CmmLit (CmmInt i _)) _) = mkIntLit i32 i + extractLit (CmmLit (CmmInt i _)) = mkIntLit i32 i extractLit _other = trace ("WARNING: Non constant alignment value given" ++ " for memcpy! Please report to GHC developers") mkIntLit i32 0 -genCall env (CmmPrim _ (Just stmts)) _ _ _ - = stmtsToInstrs env stmts (nilOL, []) - -- Handle all other foreign calls and prim ops. -genCall env target res args ret = do +genCall env target res args = do let dflags = getDflags env -- parameter types - let arg_type (CmmHinted _ AddrHint) = i8Ptr + let arg_type (_, AddrHint) = i8Ptr -- cast pointers to i8*. Llvm equivalent of void* - arg_type (CmmHinted expr _ ) = cmmToLlvmType $ cmmExprType dflags expr + arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr -- ret type - let ret_type ([]) = LMVoid - ret_type ([CmmHinted _ AddrHint]) = i8Ptr - ret_type ([CmmHinted reg _]) = cmmToLlvmType $ localRegType reg + let ret_type [] = LMVoid + ret_type [(_, AddrHint)] = i8Ptr + ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg ret_type t = panic $ "genCall: Too many return values! Can only handle" ++ " 0 or 1, given " ++ show (length t) ++ "." - -- extract Cmm call convention - let cconv = case target of - CmmCallee _ conv -> conv - CmmPrim _ _ -> PrimCallConv - - -- translate to LLVM call convention - let lmconv = case cconv of - StdCallConv -> case platformArch (getLlvmPlatform env) of - ArchX86 -> CC_X86_Stdcc - ArchX86_64 -> CC_X86_Stdcc - _ -> CC_Ccc - CCallConv -> CC_Ccc - CApiConv -> CC_Ccc - PrimCallConv -> CC_Ccc + -- extract Cmm call convention, and translate to LLVM call convention + let lmconv = case target of + ForeignTarget _ (ForeignConvention conv _ _ _) -> + case conv of + StdCallConv -> case platformArch (getLlvmPlatform env) of + ArchX86 -> CC_X86_Stdcc + ArchX86_64 -> CC_X86_Stdcc + _ -> CC_Ccc + CCallConv -> CC_Ccc + CApiConv -> CC_Ccc + + PrimTarget _ -> CC_Ccc {- - Some of the possibilities here are a worry with the use of a custom + CC_Ccc of the possibilities here are a worry with the use of a custom calling convention for passing STG args. In practice the more dangerous combinations (e.g StdCall + llvmGhcCC) don't occur. @@ -285,23 +286,31 @@ genCall env target res args ret = do -} -- call attributes - let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs - | otherwise = llvmStdFunAttrs + let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs + | otherwise = llvmStdFunAttrs + + never_returns = case target of + ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True + _ -> False -- fun type + let (res_hints, arg_hints) = foreignTargetHints target + let args_hints = zip args arg_hints + let ress_hints = zip res res_hints let ccTy = StdCall -- tail calls should be done through CmmJump - let retTy = ret_type res - let argTy = tysToParams $ map arg_type args + let retTy = ret_type ress_hints + let argTy = tysToParams $ map arg_type args_hints let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible lmconv retTy FixedArgs argTy (llvmFunAlign dflags) - (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) + + (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target - let retStmt | ccTy == TailCall = unitOL $ Return Nothing - | ret == CmmNeverReturns = unitOL $ Unreachable - | otherwise = nilOL + let retStmt | ccTy == TailCall = unitOL $ Return Nothing + | never_returns = unitOL $ Unreachable + | otherwise = nilOL let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env) @@ -315,10 +324,10 @@ genCall env target res args ret = do _ -> do (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs -- get the return register - let ret_reg ([CmmHinted reg hint]) = (reg, hint) + let ret_reg [reg] = reg ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" ++ " 1, given " ++ show (length t) ++ "." - let (creg, _) = ret_reg res + let creg = ret_reg res let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) let allStmts = stmts `snocOL` s1 `appOL` stmts3 if retTy == pLower (getVarType vreg) @@ -342,12 +351,12 @@ genCall env target res args ret = do -- | Create a function pointer from a target. -getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget +getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget -> UniqSM ExprData getFunPtr env funTy targ = case targ of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl - CmmCallee expr _ -> do + ForeignTarget expr _ -> do (env', v1, stmts, top) <- exprToVar env expr let fty = funTy $ fsLit "dynamic" cast = case getVarType v1 of @@ -360,7 +369,7 @@ getFunPtr env funTy targ = case targ of (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) return (env', v2, stmts `snocOL` s1, top) - CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop + PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop where litCase name = do @@ -392,14 +401,14 @@ getFunPtr env funTy targ = case targ of -- | Conversion of call arguments. arg_vars :: LlvmEnv - -> [HintedCmmActual] + -> [(CmmActual, ForeignHint)] -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl]) arg_vars env [] (vars, stmts, tops) = return (env, vars, stmts, tops) -arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops) +arg_vars env ((e, AddrHint):rest) (vars, stmts, tops) = do (env', v1, stmts', top') <- exprToVar env e let op = case getVarType v1 of ty | isPointer ty -> LM_Bitcast @@ -412,7 +421,7 @@ arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops) arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top') -arg_vars env (CmmHinted e _:rest) (vars, stmts, tops) +arg_vars env ((e, _):rest) (vars, stmts, tops) = do (env', v1, stmts', top') <- exprToVar env e arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') @@ -673,17 +682,15 @@ genBranch env id = -- | Conditional branch -genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData -genCondBranch env cond idT = do - idF <- getUniqueUs +genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData +genCondBranch env cond idT idF = do let labelT = blockIdToLlvm idT - let labelF = LMLocalVar idF LMLabel + let labelF = blockIdToLlvm idF (env', vc, stmts, top) <- exprToVarOpt env i1Option cond if getVarType vc == i1 then do let s1 = BranchIf vc labelT labelF - let s2 = MkLabel idF - return $ (env', stmts `snocOL` s1 `snocOL` s2, top) + return $ (env', stmts `snocOL` s1, top) else panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")" |