summaryrefslogtreecommitdiff
path: root/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/llvmGen/LlvmCodeGen/CodeGen.hs')
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs1175
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