diff options
Diffstat (limited to 'compiler/llvmGen/LlvmCodeGen/CodeGen.hs')
-rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 1175 |
1 files changed, 601 insertions, 574 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 915981752e..6f898fa56c 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -29,232 +29,216 @@ import Platform import OrdList import UniqSupply import Unique -import Util -import Data.List ( partition ) +import Data.List ( nub ) +import Data.Maybe ( catMaybes ) type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM proc Code generator -- -genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env (CmmProc infos lbl live graph) = do +genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] +genLlvmProc (CmmProc infos lbl live graph) = do let blocks = toBlockListEntryFirstFalseFallthrough graph - (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], []) + (lmblocks, lmdata) <- basicBlocksCodeGen live blocks let info = mapLookup (g_entry graph) infos proc = CmmProc info lbl live (ListGraph lmblocks) - return (env', proc:lmdata) + return (proc:lmdata) -genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" +genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!" -- ----------------------------------------------------------------------------- -- * Block code generation -- --- | Generate code for a list of blocks that make up a complete procedure. -basicBlocksCodeGen :: LlvmEnv - -> LiveGlobalRegs - -> [CmmBlock] - -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) - -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) -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 - basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops) +-- | Generate code for a list of blocks that make up a complete +-- procedure. The first block in the list is exepected to be the entry +-- point and will get the prologue. +basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock] + -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) +basicBlocksCodeGen _ [] = panic "no entry block!" +basicBlocksCodeGen live (entryBlock:cmmBlocks) + = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks) + -- Generate code + (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock + (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks --- | 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) + -- Compose + let entryBlock = BasicBlock bid (fromOL prologue ++ entry) + return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss) -- | Generate code for one block -basicBlockCodeGen :: LlvmEnv - -> CmmBlock - -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] ) -basicBlockCodeGen env block +basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen 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 + (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes + (tail_instrs, top') <- stmtToInstrs tail let instrs = fromOL (mid_instrs `appOL` tail_instrs) - return (env'', BasicBlock id instrs, top' ++ top) + return (BasicBlock id instrs, top' ++ top) -- ----------------------------------------------------------------------------- -- * CmmNode code generation -- -- A statement conversion return data. --- * LlvmEnv: The new environment -- * LlvmStatements: The compiled LLVM statements. -- * LlvmCmmDecl: Any global data needed. -type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl]) +type StmtData = (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) +stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData +stmtsToInstrs stmts + = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts + return (concatOL instrss, concat topss) -stmtsToInstrs env (stmt : stmts) (llvm, top) - = do (env', instrs, tops) <- stmtToInstrs env stmt - stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops) +-- | Convert a CmmStmt to a list of LlvmStatement's +stmtToInstrs :: CmmNode e x -> LlvmM StmtData +stmtToInstrs stmt = case stmt of --- | Convert a CmmNode to a list of LlvmStatement's -stmtToInstrs :: LlvmEnv -> CmmNode e x - -> UniqSM StmtData -stmtToInstrs env stmt = case stmt of + CmmComment _ -> return (nilOL, []) -- nuke comments - CmmComment _ -> return (env, nilOL, []) -- nuke comments + CmmAssign reg src -> genAssign reg src + CmmStore addr src -> genStore addr src - CmmAssign reg src -> genAssign env reg src - CmmStore addr src -> genStore env addr src - - CmmBranch id -> genBranch env id - CmmCondBranch arg true false -> genCondBranch env arg true false - CmmSwitch arg ids -> genSwitch env arg ids + CmmBranch id -> genBranch id + CmmCondBranch arg true false + -> genCondBranch arg true false + CmmSwitch arg ids -> genSwitch arg ids -- Foreign Call - CmmUnsafeForeignCall target res args -> genCall env target res args + CmmUnsafeForeignCall target res args + -> genCall target res args -- Tail call CmmCall { cml_target = arg, - cml_args_regs = live } -> genJump env arg live + cml_args_regs = live } -> genJump arg live _ -> panic "Llvm.CodeGen.stmtToInstrs" +-- | Wrapper function to declare an instrinct function by function type +getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData +getInstrinct2 fname fty@(LMFunction funSig) = do + + let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant + + fn <- funLookup fname + tops <- case fn of + Just _ -> + return [] + Nothing -> do + funInsert fname fty + return [CmmData Data [([],[fty])]] + + return (fv, nilOL, tops) + +getInstrinct2 _ _ = error "getInstrinct2: Non-function type!" + +-- | Declares an instrinct function by return and parameter types +getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData +getInstrinct fname retTy parTys = + let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy + FixedArgs (tysToParams parTys) Nothing + fty = LMFunction funSig + in getInstrinct2 fname fty + -- | Memory barrier instruction for LLVM >= 3.0 -barrier :: LlvmEnv -> UniqSM StmtData -barrier env = do +barrier :: LlvmM StmtData +barrier = do let s = Fence False SyncSeqCst - return (env, unitOL s, []) + return (unitOL s, []) -- | Memory barrier instruction for LLVM < 3.0 -oldBarrier :: LlvmEnv -> UniqSM StmtData -oldBarrier env = do - let dflags = getDflags env - let fname = fsLit "llvm.memory.barrier" - let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid - FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags) - let fty = LMFunction funSig - - let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False - let tops = case funLookup fname env of - Just _ -> [] - Nothing -> [CmmData Data [([],[fty])]] +oldBarrier :: LlvmM StmtData +oldBarrier = do + + (fv, _, tops) <- getInstrinct (fsLit "llvm.memory.barrier") LMVoid [i1, i1, i1, i1, i1] let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue] let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs - let env' = funInsert fname fty env - return (env', unitOL s1, tops) + return (unitOL s1, tops) where lmTrue :: LlvmVar lmTrue = mkIntLit i1 (-1) -- | Foreign Calls -genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> UniqSM StmtData +genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData -- Write barrier needs to be handled specially as it is implemented as an LLVM -- intrinsic function. -genCall env (PrimTarget MO_WriteBarrier) _ _ - | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] - = return (env, nilOL, []) - | getLlvmVer env > 29 = barrier env - | otherwise = oldBarrier env - -genCall env (PrimTarget MO_Touch) _ _ - = return (env, nilOL, []) - -genCall env (PrimTarget (MO_UF_Conv w)) [dst] [e] = do - let (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) - ty = cmmToLlvmType $ localRegType dst +genCall (PrimTarget MO_WriteBarrier) _ _ = do + platform <- getLlvmPlatform + ver <- getLlvmVer + case () of + _ | platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC] + -> return (nilOL, []) + | ver > 29 -> barrier + | otherwise -> oldBarrier + +genCall (PrimTarget MO_Touch) _ _ + = return (nilOL, []) + +genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = do + dstV <- getCmmReg (CmmLocal dst) + let ty = cmmToLlvmType $ localRegType dst width = widthToLlvmFloat w castV <- mkLocalVar ty - (env2, ve, stmts2, top2) <- exprToVar env1 e + (ve, stmts, top) <- exprToVar e let stmt3 = Assignment castV $ Cast LM_Uitofp ve width stmt4 = Store castV dstV - stmts = stmts1 `appOL` stmts2 `snocOL` stmt3 `snocOL` stmt4 - return (env2, stmts, top1 ++ top2) + return (stmts `snocOL` stmt3 `snocOL` stmt4, top) -genCall _ (PrimTarget (MO_UF_Conv _)) [_] args = +genCall (PrimTarget (MO_UF_Conv _)) [_] args = panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ "Can only handle 1, given" ++ show (length args) ++ "." -- Handle prefetching data -genCall env t@(PrimTarget MO_Prefetch_Data) [] args = do - let dflags = getDflags env - argTy = [i8Ptr, i32, i32, i32] +genCall t@(PrimTarget MO_Prefetch_Data) [] args = do + ver <- getLlvmVer + let argTy | ver <= 29 = [i8Ptr, i32, i32] + | otherwise = [i8Ptr, i32, i32, i32] funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing 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 - - let arguments = argVars' ++ [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1] - call = Expr $ Call StdCall fptr arguments [] + (argVars, stmts1, top1) <- arg_vars args_hints' ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + + trash <- getTrashStmts + let argSuffix | ver <= 29 = [mkIntLit i32 0, mkIntLit i32 3] + | otherwise = [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1] + call = Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] stmts = stmts1 `appOL` stmts2 `appOL` stmts3 - `appOL` trashStmts (getDflags env) `snocOL` call - return (env2, stmts, top1 ++ top2) - --- Handle popcnt function specifically since GHC only really has i32 and i64 --- 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@(PrimTarget (MO_PopCnt w)) [dst] args = do - let dflags = getDflags env - width = widthToLlvmInt w - dstTy = cmmToLlvmType $ localRegType dst - funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible - CC_Ccc width FixedArgs (tysToParams [width]) Nothing - (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) + `appOL` trash `snocOL` call + return (stmts, top1 ++ top2) - 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' [] - ([retV'], stmts5) <- castVars dflags [(retV,dstTy)] - let s2 = Store retV' dstV - - let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` - s1 `appOL` stmts5 `snocOL` s2 - return (env3, stmts, top1 ++ top2 ++ top3) +-- Handle PopCnt and BSwap that need to only convert arg and return types +genCall t@(PrimTarget (MO_PopCnt w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_BSwap w)) dsts args = + genCallSimpleCast w t dsts args -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. -genCall env t@(PrimTarget op) [] args' +genCall t@(PrimTarget op) [] args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = do - let dflags = getDflags env - (args, alignVal) = splitAlignVal args' - (isVolTy, isVolVal) = if getLlvmVer env >= 28 - then ([i1], [mkIntLit i1 0]) else ([], []) + ver <- getLlvmVer + dflags <- getDynFlags + let (args, alignVal) = splitAlignVal args' + (isVolTy, isVolVal) + | ver >= 28 = ([i1], [mkIntLit i1 0]) + | otherwise = ([], []) argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible @@ -262,16 +246,16 @@ genCall env t@(PrimTarget op) [] args' 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 + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + stmts4 <- getTrashStmts let arguments = argVars' ++ (alignVal:isVolVal) call = Expr $ Call StdCall fptr arguments [] stmts = stmts1 `appOL` stmts2 `appOL` stmts3 - `appOL` trashStmts (getDflags env) `snocOL` call - return (env2, stmts, top1 ++ top2) - + `appOL` stmts4 `snocOL` call + return (stmts, top1 ++ top2) where splitAlignVal xs = (init xs, extractLit $ last xs) @@ -284,9 +268,9 @@ genCall env t@(PrimTarget op) [] args' mkIntLit i32 0 -- Handle all other foreign calls and prim ops. -genCall env target res args = do +genCall target res args = do - let dflags = getDflags env + dflags <- getDynFlags -- parameter types let arg_type (_, AddrHint) = i8Ptr @@ -301,10 +285,11 @@ genCall env target res args = do ++ " 0 or 1, given " ++ show (length t) ++ "." -- extract Cmm call convention, and translate to LLVM call convention + platform <- getLlvmPlatform let lmconv = case target of ForeignTarget _ (ForeignConvention conv _ _ _) -> case conv of - StdCallConv -> case platformArch (getLlvmPlatform env) of + StdCallConv -> case platformArch platform of ArchX86 -> CC_X86_Stdcc ArchX86_64 -> CC_X86_Stdcc _ -> CC_Ccc @@ -341,22 +326,22 @@ genCall env target res args = do lmconv retTy FixedArgs argTy (llvmFunAlign dflags) - - (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy target let retStmt | ccTy == TailCall = unitOL $ Return Nothing | never_returns = unitOL $ Unreachable | otherwise = nilOL - let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env) + stmts3 <- getTrashStmts + let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 -- make the actual call case retTy of LMVoid -> do let s1 = Expr $ Call ccTy fptr argVars fnAttrs let allStmts = stmts `snocOL` s1 `appOL` retStmt - return (env2, allStmts, top1 ++ top2) + return (allStmts, top1 ++ top2) _ -> do (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs @@ -365,13 +350,13 @@ genCall env target res args = do ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" ++ " 1, given " ++ show (length t) ++ "." let creg = ret_reg res - let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) - let allStmts = stmts `snocOL` s1 `appOL` stmts3 + vreg <- getCmmReg (CmmLocal creg) + let allStmts = stmts `snocOL` s1 if retTy == pLower (getVarType vreg) then do let s2 = Store v1 vreg - return (env3, allStmts `snocOL` s2 `appOL` retStmt, - top1 ++ top2 ++ top3) + return (allStmts `snocOL` s2 `appOL` retStmt, + top1 ++ top2) else do let ty = pLower $ getVarType vreg let op = case ty of @@ -383,102 +368,110 @@ genCall env target res args = do (v2, s2) <- doExpr ty $ Cast op v1 ty let s3 = Store v2 vreg - return (env3, allStmts `snocOL` s2 `snocOL` s3 - `appOL` retStmt, top1 ++ top2 ++ top3) + return (allStmts `snocOL` s2 `snocOL` s3 + `appOL` retStmt, top1 ++ top2) + +-- Handle simple function call that only need simple type casting, of the form: +-- truncate arg >>= \a -> call(a) >>= zext +-- +-- since GHC only really has i32 and i64 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. +genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast w t@(PrimTarget op) [dst] args = do + let width = widthToLlvmInt w + dstTy = cmmToLlvmType $ localRegType dst + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width [width] + + dstV <- getCmmReg (CmmLocal dst) + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars $ zip argsV [width] + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + ([retV'], stmts5) <- castVars [(retV,dstTy)] + let s2 = Store retV' dstV + let stmts = stmts2 `appOL` stmts4 `snocOL` + s1 `appOL` stmts5 `snocOL` s2 + return (stmts, top2 ++ top3) +genCallSimpleCast _ _ dsts _ = + panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") -- | Create a function pointer from a target. -getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget - -> UniqSM ExprData -getFunPtr env funTy targ = case targ of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl +getFunPtr :: (LMString -> LlvmType) -> ForeignTarget + -> LlvmM ExprData +getFunPtr funTy targ = case targ of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + name <- strCLabel_llvm lbl + getHsFunc' name (funTy name) ForeignTarget expr _ -> do - (env', v1, stmts, top) <- exprToVar env expr + (v1, stmts, top) <- exprToVar expr + dflags <- getDynFlags let fty = funTy $ fsLit "dynamic" cast = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr ty -> panic $ "genCall: Expr is of bad type for function" - ++ " call! (" ++ show (ty) ++ ")" + ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")" (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) - return (env', v2, stmts `snocOL` s1, top) - - PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop - - where - litCase name = do - case funLookup name env of - Just ty'@(LMFunction sig) -> do - -- Function in module in right form - let fun = LMGlobalVar name ty' (funcLinkage sig) - Nothing Nothing False - return (env, fun, nilOL, []) - - Just ty' -> do - -- label in module but not function pointer, convert - let fty@(LMFunction sig) = funTy name - fun = LMGlobalVar name (pLift ty') (funcLinkage sig) - Nothing Nothing False - (v1, s1) <- doExpr (pLift fty) - $ Cast LM_Bitcast fun (pLift fty) - return (env, v1, unitOL s1, []) - - Nothing -> do - -- label not in module, create external reference - let fty@(LMFunction sig) = funTy name - fun = LMGlobalVar name fty (funcLinkage sig) - Nothing Nothing False - top = [CmmData Data [([],[fty])]] - env' = funInsert name fty env - return (env', fun, nilOL, top) + return (v2, stmts `snocOL` s1, top) + PrimTarget mop -> do + name <- cmmPrimOpFunctions mop + let fty = funTy name + getInstrinct2 name fty -- | Conversion of call arguments. -arg_vars :: LlvmEnv - -> [(CmmActual, ForeignHint)] +arg_vars :: [(CmmActual, ForeignHint)] -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) -arg_vars env [] (vars, stmts, tops) - = return (env, vars, stmts, tops) +arg_vars [] (vars, stmts, tops) + = return (vars, stmts, tops) -arg_vars env ((e, AddrHint):rest) (vars, stmts, tops) - = do (env', v1, stmts', top') <- exprToVar env e +arg_vars ((e, AddrHint):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + dflags <- getDynFlags let op = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr a -> panic $ "genCall: Can't cast llvmType to i8*! (" - ++ show a ++ ")" + ++ showSDoc dflags (ppr a) ++ ")" (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr - arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, + arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top') -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') +arg_vars ((e, _):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') -- | Cast a collection of LLVM variables to specific types. -castVars :: DynFlags -> [(LlvmVar, LlvmType)] - -> UniqSM ([LlvmVar], LlvmStatements) -castVars dflags vars = do - done <- mapM (uncurry (castVar dflags)) vars +castVars :: [(LlvmVar, LlvmType)] + -> LlvmM ([LlvmVar], LlvmStatements) +castVars vars = do + done <- mapM (uncurry castVar) vars let (vars', stmts) = unzip done return (vars', toOL stmts) -- | Cast an LLVM variable to a specific type, panicing if it can't be done. -castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) -castVar dflags v t - | getVarType v == t +castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) +castVar v t | getVarType v == t = return (v, Nop) | otherwise - = let op = case (getVarType v, t) of + = do dflags <- getDynFlags + let op = case (getVarType v, t) of (LMInt n, LMInt m) -> if n < m then LM_Sext else LM_Trunc (vt, _) | isFloat vt && isFloat t @@ -492,14 +485,24 @@ castVar dflags v t (vt, _) | isVector vt && isVector t -> LM_Bitcast (vt, _) -> panic $ "castVars: Can't cast this type (" - ++ show vt ++ ") to (" ++ show t ++ ")" - in doExpr t $ Cast op v t + ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")" + doExpr t $ Cast op v t -- | Decide what C function to use to implement a CallishMachOp -cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString -cmmPrimOpFunctions env mop - = case mop of +cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString +cmmPrimOpFunctions mop = do + + ver <- getLlvmVer + dflags <- getDynFlags + let intrinTy1 = (if ver >= 28 + then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + intrinTy2 = (if ver >= 28 + then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") + + return $ case mop of MO_F32_Exp -> fsLit "expf" MO_F32_Log -> fsLit "logf" MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" @@ -538,7 +541,8 @@ cmmPrimOpFunctions env mop MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1 MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2 - (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w) + (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w) MO_Prefetch_Data -> fsLit "llvm.prefetch" @@ -551,44 +555,36 @@ cmmPrimOpFunctions env mop MO_Touch -> unsupported MO_UF_Conv _ -> unsupported - where - dflags = getDflags env - intrinTy1 = (if getLlvmVer env >= 28 - then "p0i8.p0i8." else "") ++ show (llvmWord dflags) - intrinTy2 = (if getLlvmVer env >= 28 - then "p0i8." else "") ++ show (llvmWord dflags) - unsupported = panic ("cmmPrimOpFunctions: " ++ show mop - ++ " not supported here") - -- | Tail function calls -genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData +genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData -- Call to known function -genJump env (CmmLit (CmmLabel lbl)) live = do - (env', vf, stmts, top) <- getHsFunc env live lbl - (stgRegs, stgStmts) <- funEpilogue env live +genJump (CmmLit (CmmLabel lbl)) live = do + (vf, stmts, top) <- getHsFunc live lbl + (stgRegs, stgStmts) <- funEpilogue live let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs let s2 = Return Nothing - return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) + return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) -- Call to unknown function / address -genJump env expr live = do - let fty = llvmFunTy (getDflags env) live - (env', vf, stmts, top) <- exprToVar env expr +genJump expr live = do + fty <- llvmFunTy live + (vf, stmts, top) <- exprToVar expr + dflags <- getDynFlags let cast = case getVarType vf of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr ty -> panic $ "genJump: Expr is of bad type for function call! (" - ++ show (ty) ++ ")" + ++ showSDoc dflags (ppr ty) ++ ")" (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) - (stgRegs, stgStmts) <- funEpilogue env live + (stgRegs, stgStmts) <- funEpilogue live let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs let s3 = Return Nothing - return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, + return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, top) @@ -596,81 +592,81 @@ genJump env expr live = do -- -- We use stack allocated variables for CmmReg. The optimiser will replace -- these with registers when possible. -genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData -genAssign env reg val = do - let dflags = getDflags env - (env1, vreg, stmts1, top1) = getCmmReg env reg - (env2, vval, stmts2, top2) <- exprToVar env1 val - let stmts = stmts1 `appOL` stmts2 +genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData +genAssign reg val = do + vreg <- getCmmReg reg + (vval, stmts2, top2) <- exprToVar val + let stmts = stmts2 let ty = (pLower . getVarType) vreg + dflags <- getDynFlags case ty of -- Some registers are pointer types, so need to cast value to pointer LMPointer _ | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = Store v vreg - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top2) LMVector _ _ -> do (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty let s2 = Store v vreg - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top2) _ -> do let s1 = Store vval vreg - return (env2, stmts `snocOL` s1, top1 ++ top2) + return (stmts `snocOL` s1, top2) -- | CmmStore operation -genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData +genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData -- 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 -genStore env addr@(CmmReg (CmmGlobal r)) val - = genStore_fast env addr r 0 val +genStore addr@(CmmReg (CmmGlobal r)) val + = genStore_fast addr r 0 val -genStore env addr@(CmmRegOff (CmmGlobal r) n) val - = genStore_fast env addr r n val +genStore addr@(CmmRegOff (CmmGlobal r) n) val + = genStore_fast addr r n val -genStore env addr@(CmmMachOp (MO_Add _) [ +genStore addr@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) val - = genStore_fast env addr r (fromInteger n) val + = genStore_fast addr r (fromInteger n) val -genStore env addr@(CmmMachOp (MO_Sub _) [ +genStore addr@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) val - = genStore_fast env addr r (negate $ fromInteger n) val + = genStore_fast addr r (negate $ fromInteger n) val -- generic case -genStore env addr val = genStore_slow env addr val [other] +genStore addr val + = do other <- getTBAAMeta otherN + genStore_slow addr val other -- | CmmStore operation -- This is a special case for storing to a global register pointer -- offset such as I32[Sp+8]. -genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr - -> UniqSM StmtData -genStore_fast env addr r n val - = let dflags = getDflags env - gr = lmGlobalRegVar (getDflags env) r - meta = [getTBAA r] - grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of +genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr + -> LlvmM StmtData +genStore_fast addr r n val + = do dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of True -> do - (env', vval, stmts, top) <- exprToVar env val - (gv, s1) <- doExpr grt $ Load gr + (vval, stmts, top) <- exprToVar val (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 True -> do let s3 = MetaStmt meta $ Store vval ptr - return (env', stmts `snocOL` s1 `snocOL` s2 + return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3, top) -- cast to pointer type needed @@ -678,68 +674,69 @@ genStore_fast env addr r n val let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty let s4 = MetaStmt meta $ Store vval ptr' - return (env', stmts `snocOL` s1 `snocOL` s2 + return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genStore_slow env addr val meta + False -> genStore_slow addr val meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData -genStore_slow env addr val meta = do - (env1, vaddr, stmts1, top1) <- exprToVar env addr - (env2, vval, stmts2, top2) <- exprToVar env1 val +genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData +genStore_slow addr val meta = do + (vaddr, stmts1, top1) <- exprToVar addr + (vval, stmts2, top2) <- exprToVar val let stmts = stmts1 `appOL` stmts2 + dflags <- getDynFlags case getVarType vaddr of -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = MetaStmt meta $ Store v vaddr - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do let s1 = MetaStmt meta $ Store vval vaddr - return (env2, stmts `snocOL` s1, top1 ++ top2) + return (stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord dflags -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty let s2 = MetaStmt meta $ Store vval vptr - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> pprPanic "genStore: ptr not right type!" (PprCmm.pprExpr addr <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ show vaddr)) - where dflags = getDflags env + ", Var: " ++ showSDoc dflags (ppr vaddr))) -- | Unconditional branch -genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData -genBranch env id = +genBranch :: BlockId -> LlvmM StmtData +genBranch id = let label = blockIdToLlvm id - in return (env, unitOL $ Branch label, []) + in return (unitOL $ Branch label, []) -- | Conditional branch -genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData -genCondBranch env cond idT idF = do +genCondBranch :: CmmExpr -> BlockId -> BlockId -> LlvmM StmtData +genCondBranch cond idT idF = do let labelT = blockIdToLlvm idT let labelF = blockIdToLlvm idF -- See Note [Literals and branch conditions]. - (env', vc, stmts, top) <- exprToVarOpt env i1Option cond + (vc, stmts, top) <- exprToVarOpt i1Option cond if getVarType vc == i1 then do let s1 = BranchIf vc labelT labelF - return $ (env', stmts `snocOL` s1, top) - else - panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")" + return (stmts `snocOL` s1, top) + else do + dflags <- getDynFlags + panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")" {- Note [Literals and branch conditions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -797,9 +794,9 @@ For a real example of this, see ./rts/StgStdThunks.cmm -- -- 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 - (env', vc, stmts, top) <- exprToVar env cond +genSwitch :: CmmExpr -> [Maybe BlockId] -> LlvmM StmtData +genSwitch cond maybe_ids = do + (vc, stmts, top) <- exprToVar cond let ty = getVarType vc let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ] @@ -808,7 +805,7 @@ genSwitch env cond maybe_ids = do let (_, defLbl) = head labels let s1 = Switch vc defLbl labels - return $ (env', stmts `snocOL` s1, top) + return $ (stmts `snocOL` s1, top) -- ----------------------------------------------------------------------------- @@ -816,11 +813,10 @@ genSwitch env cond maybe_ids = do -- -- | An expression conversion return data: --- * LlvmEnv: The new enviornment -- * LlvmVar: The var holding the result of the expression -- * LlvmStatements: Any statements needed to evaluate the expression -- * LlvmCmmDecl: Any global data needed for this expression -type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmDecl]) +type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) -- | Values which can be passed to 'exprToVar' to configure its -- behaviour in certain circumstances. @@ -840,47 +836,47 @@ wordOption = EOption False -- | Convert a CmmExpr to a list of LlvmStatements with the result of the -- expression being stored in the returned LlvmVar. -exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData -exprToVar env = exprToVarOpt env wordOption +exprToVar :: CmmExpr -> LlvmM ExprData +exprToVar = exprToVarOpt wordOption -exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData -exprToVarOpt env opt e = case e of +exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData +exprToVarOpt opt e = case e of CmmLit lit - -> genLit opt env lit + -> genLit opt lit CmmLoad e' ty - -> genLoad env e' ty + -> genLoad e' ty -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly. CmmReg r -> do - let (env', vreg, stmts, top) = getCmmReg env r - (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg - case (isPointer . getVarType) v1 of + (v1, ty, s1) <- getCmmRegVal r + case isPointer ty of True -> do -- Cmm wants the value, so pointer types must be cast to ints + dflags <- getDynFlags (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) - return (env', v2, stmts `snocOL` s1 `snocOL` s2, top) + return (v2, s1 `snocOL` s2, []) - False -> return (env', v1, stmts `snocOL` s1, top) + False -> return (v1, s1, []) CmmMachOp op exprs - -> genMachOp env opt op exprs + -> genMachOp opt op exprs CmmRegOff r i - -> exprToVar env $ expandCmmReg dflags (r, i) + -> do dflags <- getDynFlags + exprToVar $ expandCmmReg dflags (r, i) CmmStackSlot _ _ -> panic "exprToVar: CmmStackSlot not supported!" - where dflags = getDflags env -- | Handle CmmMachOp expressions -genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData +genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData -- Unary Machop -genMachOp env _ op [x] = case op of +genMachOp _ op [x] = case op of MO_Not w -> let all1 = mkIntLit (widthToLlvmInt w) (-1) @@ -980,29 +976,28 @@ genMachOp env _ op [x] = case op of MO_VF_Quot _ _ -> panicOp where - dflags = getDflags env - negate ty v2 negOp = do - (env', vx, stmts, top) <- exprToVar env x + (vx, stmts, top) <- exprToVar x (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) negateVec ty v2 negOp = do - (env', vx, stmts1, top) <- exprToVar env x - ([vx'], stmts2) <- castVars dflags [(vx, ty)] + (vx, stmts1, top) <- exprToVar x + ([vx'], stmts2) <- castVars [(vx, ty)] (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' - return (env', v1, stmts1 `appOL` stmts2 `snocOL` s1, top) + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) fiConv ty convOp = do - (env', vx, stmts, top) <- exprToVar env x + (vx, stmts, top) <- exprToVar x (v1, s1) <- doExpr ty $ Cast convOp vx ty - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) sameConv from ty reduce expand = do - x'@(env', vx, stmts, top) <- exprToVar env x + x'@(vx, stmts, top) <- exprToVar x let sameConv' op = do (v1, s1) <- doExpr ty $ Cast op vx ty - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) + dflags <- getDynFlags let toWidth = llvmWidthInBits dflags 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. @@ -1015,88 +1010,82 @@ genMachOp env _ op [x] = case op of ++ "with one argument! (" ++ show op ++ ")" -- 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 opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast 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 +genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (negate . fromInteger $ n) e -- Generic case -genMachOp env opt op e = genMachOp_slow env opt op e +genMachOp opt op e = genMachOp_slow 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 dflags = getDflags env - gr = lmGlobalRegVar dflags r - grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of +genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] + -> LlvmM ExprData +genMachOp_fast opt op r n e + = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + dflags <- getDynFlags + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of True -> do - (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) + return (var, s1 `snocOL` s2 `snocOL` s3, []) - False -> genMachOp_slow env opt op e + False -> genMachOp_slow 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 +genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData -- Element extraction -genMachOp_slow env _ (MO_V_Extract l w) [val, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, vidx, stmts2, top2) <- exprToVar env1 idx - ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)] - (v1, s1) <- doExpr ty $ Extract vval' vidx - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) +genMachOp_slow _ (MO_V_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) where - dflags = getDflags env ty = widthToLlvmInt w -genMachOp_slow env _ (MO_VF_Extract l w) [val, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, vidx, stmts2, top2) <- exprToVar env1 idx - ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)] - (v1, s1) <- doExpr ty $ Extract vval' vidx - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) +genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) where - dflags = getDflags env ty = widthToLlvmFloat w -- Element insertion -genMachOp_slow env _ (MO_V_Insert l w) [val, elt, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, velt, stmts2, top2) <- exprToVar env1 elt - (env3, vidx, stmts3, top3) <- exprToVar env2 idx - ([vval'], stmts4) <- castVars dflags [(vval, ty)] - (v1, s1) <- doExpr ty $ Insert vval' velt vidx - return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, +genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, top1 ++ top2 ++ top3) where - dflags = getDflags env ty = LMVector l (widthToLlvmInt w) -genMachOp_slow env _ (MO_VF_Insert l w) [val, elt, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, velt, stmts2, top2) <- exprToVar env1 elt - (env3, vidx, stmts3, top3) <- exprToVar env2 idx - ([vval'], stmts4) <- castVars dflags [(vval, ty)] - (v1, s1) <- doExpr ty $ Insert vval' velt vidx - return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, +genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, top1 ++ top2 ++ top3) where - dflags = getDflags env ty = LMVector l (widthToLlvmFloat w) -- Binary MachOp -genMachOp_slow env opt op [x, y] = case op of +genMachOp_slow opt op [x, y] = case op of MO_Eq _ -> genBinComp opt LM_CMP_Eq MO_Ne _ -> genBinComp opt LM_CMP_Ne @@ -1177,21 +1166,19 @@ genMachOp_slow env opt op [x, y] = case op of MO_VF_Neg {} -> panicOp where - dflags = getDflags env - binLlvmOp ty binOp = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y if getVarType vx == getVarType vy then do (v1, s1) <- doExpr (ty vx) $ binOp vx vy - return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1, + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) else do -- Error. Continue anyway so we can debug the generated ll file. - let dflags = getDflags env - style = mkCodeStyle CStyle + dflags <- getDynFlags + let style = mkCodeStyle CStyle toString doc = renderWithStyle dflags doc style cmmToStr = (lines . toString . PprCmm.pprExpr) let dx = Comment $ map fsLit $ cmmToStr x @@ -1199,31 +1186,32 @@ genMachOp_slow env opt op [x, y] = case op of (v1, s1) <- doExpr (ty vx) $ binOp vx vy let allStmts = stmts1 `appOL` stmts2 `snocOL` dx `snocOL` dy `snocOL` s1 - return (env2, v1, allStmts, top1 ++ top2) + return (v1, allStmts, top1 ++ top2) binCastLlvmOp ty binOp = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y - ([vx', vy'], stmts3) <- castVars dflags [(vx, ty), (vy, ty)] + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + ([vx', vy'], stmts3) <- castVars [(vx, ty), (vy, ty)] (v1, s1) <- doExpr ty $ binOp vx' vy' - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) -- | Need to use EOption here as Cmm expects word size results from -- comparisons while LLVM return i1. Need to extend to llvmWord type -- if expected. See Note [Literals and branch conditions]. genBinComp opt cmp = do - ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + dflags <- getDynFlags if getVarType v1 == i1 then case i1Expected opt of True -> return ed False -> do let w_ = llvmWord dflags (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ - return (env', v2, stmts `snocOL` s1, top) + return (v2, stmts `snocOL` s1, top) else panic $ "genBinComp: Compare returned type other then i1! " - ++ (show $ getVarType v1) + ++ (showSDoc dflags $ ppr $ getVarType v1) genBinMach op = binLlvmOp getVarType (LlvmOp op) @@ -1233,11 +1221,12 @@ genMachOp_slow env opt op [x, y] = case op of -- CmmExpr's. This is the LLVM assembly equivalent of the NCG -- implementation. Its much longer due to type information/safety. -- This should actually compile to only about 3 asm instructions. - isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData + isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData isSMulOK _ x y = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + dflags <- getDynFlags let word = getVarType vx let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) let shift = llvmWidthInBits dflags word @@ -1256,127 +1245,151 @@ genMachOp_slow env opt op [x, y] = case op of (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8 - return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts, + return (dst, stmts1 `appOL` stmts2 `appOL` stmts, top1 ++ top2) else - panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")" + panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")" panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encourntered" ++ "with two arguments! (" ++ show op ++ ")" -- More then two expression, invalid! -genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" +genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" -- | Handle CmmLoad expression. -genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData +genLoad :: CmmExpr -> CmmType -> LlvmM 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 -genLoad env e@(CmmReg (CmmGlobal r)) ty - = genLoad_fast env e r 0 ty +genLoad e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast e r 0 ty -genLoad env e@(CmmRegOff (CmmGlobal r) n) ty - = genLoad_fast env e r n ty +genLoad e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast e r n ty -genLoad env e@(CmmMachOp (MO_Add _) [ +genLoad e@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast env e r (fromInteger n) ty + = genLoad_fast e r (fromInteger n) ty -genLoad env e@(CmmMachOp (MO_Sub _) [ +genLoad e@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast env e r (negate $ fromInteger n) ty + = genLoad_fast e r (negate $ fromInteger n) ty -- generic case -genLoad env e ty = genLoad_slow env e ty [other] +genLoad e ty + = do other <- getTBAAMeta otherN + genLoad_slow e ty other -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. -genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType - -> UniqSM ExprData -genLoad_fast env e r n ty = - let dflags = getDflags env - gr = lmGlobalRegVar dflags r - meta = [getTBAA r] - grt = (pLower . getVarType) gr - ty' = cmmToLlvmType ty +genLoad_fast :: CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast e r n ty = do + dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of + case isPointer grt && rem == 0 of True -> do - (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] -- We might need a different pointer type, so check case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr) - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, + (var, s3) <- doExpr ty' (MExpr meta $ Load ptr) + return (var, s1 `snocOL` s2 `snocOL` s3, []) -- cast to pointer type needed False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr') - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3 + (var, s4) <- doExpr ty' (MExpr meta $ Load ptr') + return (var, s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow env e ty meta + False -> genLoad_slow e ty meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData -genLoad_slow env e ty meta = do - (env', iptr, stmts, tops) <- exprToVar env e +genLoad_slow :: CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow e ty meta = do + (iptr, stmts, tops) <- exprToVar e + dflags <- getDynFlags case getVarType iptr of LMPointer _ -> do (dvar, load) <- doExpr (cmmToLlvmType ty) - (MetaExpr meta $ Load iptr) - return (env', dvar, stmts `snocOL` load, tops) + (MExpr meta $ Load iptr) + return (dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord dflags -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) - (MetaExpr meta $ Load ptr) - return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) + (MExpr meta $ Load ptr) + return (dvar, stmts `snocOL` cast `snocOL` load, tops) - other -> pprPanic "exprToVar: CmmLoad expression is not right type!" + other -> do dflags <- getDynFlags + pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ - ", Var: " ++ show iptr)) - where dflags = getDflags env - --- | Handle CmmReg expression --- --- 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. -getCmmReg :: LlvmEnv -> CmmReg -> ExprData -getCmmReg env r@(CmmLocal (LocalReg un _)) - = let exists = varLookup un env - (newv, stmts) = allocReg r - nenv = varInsert un (pLower $ getVarType newv) env - in case exists of - Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, []) - Nothing -> (nenv, newv, stmts, []) - -getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, []) - - --- | Allocate a CmmReg on the stack + ", Var: " ++ showSDoc dflags (ppr iptr))) + + +-- | Handle CmmReg expression. This will return a pointer to the stack +-- location of the register. Throws an error if it isn't allocated on +-- the stack. +getCmmReg :: CmmReg -> LlvmM LlvmVar +getCmmReg (CmmLocal (LocalReg un _)) + = do exists <- varLookup un + dflags <- getDynFlags + case exists of + Just ety -> return (LMLocalVar un $ pLift ety) + Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!" + -- This should never happen, as every local variable should + -- have been assigned a value at some point, triggering + -- "funPrologue" to allocate it on the stack. + +getCmmReg (CmmGlobal g) + = do onStack <- checkStackReg g + dflags <- getDynFlags + if onStack + then return (lmGlobalRegVar dflags g) + else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!" + +-- | Return the value of a given register, as well as its type. Might +-- need to be load from stack. +getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) +getCmmRegVal reg = + case reg of + CmmGlobal g -> do + onStack <- checkStackReg g + dflags <- getDynFlags + if onStack then loadFromStack else do + let r = lmGlobalRegArg dflags g + return (r, getVarType r, nilOL) + _ -> loadFromStack + where loadFromStack = do + ptr <- getCmmReg reg + let ty = pLower $ getVarType ptr + (v, s) <- doExpr ty (Load ptr) + return (v, ty, unitOL s) + +-- | Allocate a local CmmReg on the stack allocReg :: CmmReg -> (LlvmVar, LlvmStatements) allocReg (CmmLocal (LocalReg un ty)) = let ty' = cmmToLlvmType ty @@ -1389,8 +1402,8 @@ allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" -- | Generate code for a literal -genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData -genLit opt env (CmmInt i w) +genLit :: EOption -> CmmLit -> LlvmM ExprData +genLit opt (CmmInt i w) -- See Note [Literals and branch conditions]. = let width | i1Expected opt = i1 | otherwise = LMInt (widthInBits w) @@ -1398,56 +1411,41 @@ genLit opt env (CmmInt i w) -- , fsLit $ "Width : " ++ show w -- , fsLit $ "Width' : " ++ show (widthInBits w) -- ] - in return (env, mkIntLit width i, nilOL, []) + in return (mkIntLit width i, nilOL, []) -genLit _ env (CmmFloat r w) - = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), +genLit _ (CmmFloat r w) + = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), nilOL, []) - -genLit opt env (CmmVec ls) + +genLit opt (CmmVec ls) = do llvmLits <- mapM toLlvmLit ls - return (env, LMLitVar $ LMVectorLit llvmLits, nilOL, []) + return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) where - toLlvmLit :: CmmLit -> UniqSM LlvmLit + toLlvmLit :: CmmLit -> LlvmM LlvmLit toLlvmLit lit = do - (_, llvmLitVar, _, _) <- genLit opt env lit + (llvmLitVar, _, _) <- genLit opt lit case llvmLitVar of LMLitVar llvmLit -> return llvmLit _ -> panic "genLit" -genLit _ env cmm@(CmmLabel l) - = let dflags = getDflags env - label = strCLabel_llvm env l - ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType dflags cmm - in case ty of - -- Make generic external label definition and then pointer to it - Nothing -> do - let glob@(var, _) = genStringLabelRef dflags label - let ldata = [CmmData Data [([glob], [])]] - let env' = funInsert label (pLower $ getVarType var) env - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (env', v1, unitOL s1, ldata) - - -- Referenced data exists in this module, retrieve type and make - -- pointer to it. - Just ty' -> do - let var = LMGlobalVar label (LMPointer ty') - ExternallyVisible Nothing Nothing False - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (env, v1, unitOL s1, []) - -genLit opt env (CmmLabelOff label off) = do - let dflags = getDflags env - (env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label) +genLit _ cmm@(CmmLabel l) + = do var <- getGlobalPtr =<< strCLabel_llvm l + dflags <- getDynFlags + let lmty = cmmToLlvmType $ cmmLitType dflags cmm + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) + return (v1, unitOL s1, []) + +genLit opt (CmmLabelOff label off) = do + dflags <- getDynFlags + (vlbl, stmts, stat) <- genLit opt (CmmLabel label) let voff = toIWord dflags off (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff - return (env', v1, stmts `snocOL` s1, stat) + return (v1, stmts `snocOL` s1, stat) -genLit opt env (CmmLabelDiffOff l1 l2 off) = do - let dflags = getDflags env - (env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1) - (env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2) +genLit opt (CmmLabelDiffOff l1 l2 off) = do + dflags <- getDynFlags + (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1) + (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2) let voff = toIWord dflags off let ty1 = getVarType vl1 let ty2 = getVarType vl2 @@ -1457,16 +1455,16 @@ genLit opt env (CmmLabelDiffOff l1 l2 off) = do then do (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff - return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, + return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, stat1 ++ stat2) else panic "genLit: CmmLabelDiffOff encountered with different label ty!" -genLit opt env (CmmBlock b) - = genLit opt env (CmmLabel $ infoTblLbl b) +genLit opt (CmmBlock b) + = genLit opt (CmmLabel $ infoTblLbl b) -genLit _ _ CmmHighStackMark +genLit _ CmmHighStackMark = panic "genStaticLit - CmmHighStackMark unsupported!" @@ -1474,51 +1472,82 @@ genLit _ _ CmmHighStackMark -- * Misc -- --- | Function prologue. Load STG arguments into variables for function. -funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement] -funPrologue dflags live = concat $ map getReg $ activeStgRegs platform - where platform = targetPlatform dflags - isLive r = r `elem` alwaysLive || r `elem` live - getReg rr = - let reg = lmGlobalRegVar dflags rr - arg = lmGlobalRegArg dflags rr - ty = (pLower . getVarType) reg - trash = LMLitVar $ LMUndefLit ty - alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - in - if isLive rr - then [alloc, Store arg reg] - else [alloc, Store trash reg] - +-- | Find CmmRegs that get assigned and allocate them on the stack +-- +-- Any register that gets written needs to be allcoated 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. +-- +-- On the other hand, this is unecessarily verbose if the register in +-- question is never written. Therefore we skip it where we can to +-- save a few lines in the output and hopefully speed compilation up a +-- bit. +funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData +funPrologue live cmmBlocks = do + + trash <- getTrashRegs + let getAssignedRegs :: CmmNode O O -> [CmmReg] + getAssignedRegs (CmmAssign reg _) = [reg] + -- Calls will trash all registers. Unfortunately, this needs them to + -- be stack-allocated in the first place. + getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs + getAssignedRegs _ = [] + getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body + assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks + isLive r = r `elem` alwaysLive || r `elem` live + + dflags <- getDynFlags + stmtss <- flip mapM assignedRegs $ \reg -> + case reg of + CmmLocal (LocalReg un _) -> do + let (newv, stmts) = allocReg reg + varInsert un (pLower $ getVarType newv) + return stmts + CmmGlobal r -> do + let reg = lmGlobalRegVar dflags r + arg = lmGlobalRegArg dflags r + ty = (pLower . getVarType) reg + trash = LMLitVar $ LMUndefLit ty + rval = if isLive r then arg else trash + alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 + markStackReg r + return $ toOL [alloc, Store rval reg] + + return (concatOL stmtss, []) -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here. -funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements) +funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) +funEpilogue live = do + + -- Have information and liveness optimisation is enabled? + let liveRegs = alwaysLive ++ live + isSSE (FloatReg _) = True + isSSE (DoubleReg _) = True + isSSE (XmmReg _) = True + isSSE _ = False + + -- Set to value or "undef" depending on whether the register is + -- actually live + dflags <- getDynFlags + let loadExpr r = do + (v, _, s) <- getCmmRegVal (CmmGlobal r) + return (Just $ v, s) + loadUndef r = do + let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) + return (Just $ LMLitVar $ LMUndefLit ty, nilOL) + platform <- getDynFlag targetPlatform + loads <- flip mapM (activeStgRegs platform) $ \r -> case () of + _ | r `elem` liveRegs -> loadExpr r + | not (isSSE r) -> loadUndef r + | otherwise -> return (Nothing, nilOL) --- Have information and liveness optimisation is enabled -funEpilogue env live = do - loads <- mapM loadExpr (filter isPassed (activeStgRegs platform)) let (vars, stmts) = unzip loads - return (vars, concatOL stmts) - where - dflags = getDflags env - platform = targetPlatform dflags - isLive r = r `elem` alwaysLive || r `elem` live - isPassed r = not (isSSE r) || isLive r - isSSE (FloatReg _) = True - isSSE (DoubleReg _) = True - isSSE (XmmReg _) = True - isSSE _ = False - loadExpr r | isLive r = do - let reg = lmGlobalRegVar dflags r - (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg - return (v, unitOL s) - loadExpr r = do - let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) - return (LMLitVar $ LMUndefLit ty, unitOL Nop) - - --- | A serries of statements to trash all the STG registers. + return (catMaybes vars, concatOL stmts) + + +-- | A series of statements to trash all the STG registers. -- -- In LLVM we pass the STG registers around everywhere in function calls. -- So this means LLVM considers them live across the entire function, when @@ -1529,59 +1558,47 @@ funEpilogue env live = do -- 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. -trashStmts :: DynFlags -> LlvmStatements -trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform - where platform = targetPlatform dflags - trashReg r = - let reg = lmGlobalRegVar dflags r - ty = (pLower . getVarType) reg - trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg - in case callerSaves (targetPlatform dflags) r of - True -> trash - False -> nilOL - +getTrashStmts :: LlvmM LlvmStatements +getTrashStmts = do + regs <- getTrashRegs + stmts <- flip mapM regs $ \ r -> do + reg <- getCmmReg (CmmGlobal r) + let ty = (pLower . getVarType) reg + return $ Store (LMLitVar $ LMUndefLit ty) reg + return $ toOL stmts + +getTrashRegs :: LlvmM [GlobalReg] +getTrashRegs = do plat <- getLlvmPlatform + return $ filter (callerSaves plat) (activeStgRegs plat) -- | Get a function pointer to the CLabel specified. -- -- This is for Haskell functions, function type is assumed, so doesn't work -- with foreign functions. -getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData -getHsFunc env live lbl - = let dflags = getDflags env - fn = strCLabel_llvm env lbl - ty = funLookup fn env - in case ty of - -- Function in module in right form - Just ty'@(LMFunction sig) -> do - let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False - return (env, fun, nilOL, []) - - -- label in module but not function pointer, convert - Just ty' -> do - let fun = LMGlobalVar fn (pLift ty') ExternallyVisible - Nothing Nothing False - (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $ - Cast LM_Bitcast fun (pLift (llvmFunTy dflags live)) - return (env, v1, unitOL s1, []) - - -- label not in module, create external reference - Nothing -> do - let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible - let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False - let top = CmmData Data [([],[ty'])] - let env' = funInsert fn ty' env - return (env', fun, nilOL, [top]) - +getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData +getHsFunc live lbl + = do fty <- llvmFunTy live + name <- strCLabel_llvm lbl + getHsFunc' name fty + +getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData +getHsFunc' name fty + = do fun <- getGlobalPtr name + if getVarType fun == fty + then return (fun, nilOL, []) + else do (v1, s1) <- doExpr (pLift fty) + $ Cast LM_Bitcast fun (pLift fty) + return (v1, unitOL s1, []) -- | Create a new local var -mkLocalVar :: LlvmType -> UniqSM LlvmVar +mkLocalVar :: LlvmType -> LlvmM LlvmVar mkLocalVar ty = do - un <- getUniqueUs + un <- runUs getUniqueUs return $ LMLocalVar un ty -- | Execute an expression, assigning result to a var -doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement) +doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) doExpr ty expr = do v <- mkLocalVar ty return (v, Assignment v expr) @@ -1618,3 +1635,13 @@ panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s pprPanic :: String -> SDoc -> a pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d + +-- | Returns TBAA meta data by unique +getTBAAMeta :: Unique -> LlvmM [MetaAnnot] +getTBAAMeta u = do + mi <- getUniqMeta u + return [MetaAnnot tbaa (MetaNode i) | let Just i = mi] + +-- | Returns TBAA meta data for given register +getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] +getTBAARegMeta = getTBAAMeta . getTBAA |