Commit a62b56ef authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Pass DynFlags down to llvmWord

parent 7f5af24f
...@@ -12,6 +12,7 @@ import Data.List (intercalate) ...@@ -12,6 +12,7 @@ import Data.List (intercalate)
import Numeric import Numeric
import Constants import Constants
import DynFlags
import FastString import FastString
import Unique import Unique
...@@ -325,21 +326,21 @@ isGlobal (LMGlobalVar _ _ _ _ _ _) = True ...@@ -325,21 +326,21 @@ isGlobal (LMGlobalVar _ _ _ _ _ _) = True
isGlobal _ = False isGlobal _ = False
-- | Width in bits of an 'LlvmType', returns 0 if not applicable -- | Width in bits of an 'LlvmType', returns 0 if not applicable
llvmWidthInBits :: LlvmType -> Int llvmWidthInBits :: DynFlags -> LlvmType -> Int
llvmWidthInBits (LMInt n) = n llvmWidthInBits _ (LMInt n) = n
llvmWidthInBits (LMFloat) = 32 llvmWidthInBits _ (LMFloat) = 32
llvmWidthInBits (LMDouble) = 64 llvmWidthInBits _ (LMDouble) = 64
llvmWidthInBits (LMFloat80) = 80 llvmWidthInBits _ (LMFloat80) = 80
llvmWidthInBits (LMFloat128) = 128 llvmWidthInBits _ (LMFloat128) = 128
-- Could return either a pointer width here or the width of what -- Could return either a pointer width here or the width of what
-- it points to. We will go with the former for now. -- it points to. We will go with the former for now.
llvmWidthInBits (LMPointer _) = llvmWidthInBits llvmWord llvmWidthInBits dflags (LMPointer _) = llvmWidthInBits dflags (llvmWord dflags)
llvmWidthInBits (LMArray _ _) = llvmWidthInBits llvmWord llvmWidthInBits dflags (LMArray _ _) = llvmWidthInBits dflags (llvmWord dflags)
llvmWidthInBits LMLabel = 0 llvmWidthInBits _ LMLabel = 0
llvmWidthInBits LMVoid = 0 llvmWidthInBits _ LMVoid = 0
llvmWidthInBits (LMStruct tys) = sum $ map llvmWidthInBits tys llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys
llvmWidthInBits (LMFunction _) = 0 llvmWidthInBits _ (LMFunction _) = 0
llvmWidthInBits (LMAlias (_,t)) = llvmWidthInBits t llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
...@@ -356,9 +357,9 @@ i1 = LMInt 1 ...@@ -356,9 +357,9 @@ i1 = LMInt 1
i8Ptr = pLift i8 i8Ptr = pLift i8
-- | The target architectures word size -- | The target architectures word size
llvmWord, llvmWordPtr :: LlvmType llvmWord, llvmWordPtr :: DynFlags -> LlvmType
llvmWord = LMInt (wORD_SIZE * 8) llvmWord _ = LMInt (wORD_SIZE * 8)
llvmWordPtr = pLift llvmWord llvmWordPtr dflags = pLift (llvmWord dflags)
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- * LLVM Function Types -- * LLVM Function Types
......
...@@ -99,20 +99,19 @@ llvmFunSig env lbl link ...@@ -99,20 +99,19 @@ llvmFunSig env lbl link
llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
llvmFunSig' dflags lbl link llvmFunSig' dflags lbl link
= let platform = targetPlatform dflags = let toParams x | isPointer x = (x, [NoAlias, NoCapture])
toParams x | isPointer x = (x, [NoAlias, NoCapture])
| otherwise = (x, []) | otherwise = (x, [])
in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
(map (toParams . getVarType) (llvmFunArgs platform)) (map (toParams . getVarType) (llvmFunArgs dflags))
llvmFunAlign llvmFunAlign
-- | Create a Haskell function in LLVM. -- | Create a Haskell function in LLVM.
mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
-> LlvmFunction -> LlvmFunction
mkLlvmFunc env lbl link sec blks mkLlvmFunc env lbl link sec blks
= let platform = targetPlatform $ getDflags env = let dflags = getDflags env
funDec = llvmFunSig env lbl link funDec = llvmFunSig env lbl link
funArgs = map (fsLit . getPlainName) (llvmFunArgs platform) funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags)
in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
-- | Alignment to use for functions -- | Alignment to use for functions
...@@ -124,8 +123,9 @@ llvmInfAlign :: LMAlign ...@@ -124,8 +123,9 @@ llvmInfAlign :: LMAlign
llvmInfAlign = Just wORD_SIZE llvmInfAlign = Just wORD_SIZE
-- | A Function's arguments -- | A Function's arguments
llvmFunArgs :: Platform -> [LlvmVar] llvmFunArgs :: DynFlags -> [LlvmVar]
llvmFunArgs platform = map lmGlobalRegArg (activeStgRegs platform) llvmFunArgs dflags = map (lmGlobalRegArg dflags) (activeStgRegs platform)
where platform = targetPlatform dflags
-- | Llvm standard fun attributes -- | Llvm standard fun attributes
llvmStdFunAttrs :: [LlvmFuncAttr] llvmStdFunAttrs :: [LlvmFuncAttr]
...@@ -169,19 +169,19 @@ type LlvmEnvMap = UniqFM LlvmType ...@@ -169,19 +169,19 @@ type LlvmEnvMap = UniqFM LlvmType
-- | Get initial Llvm environment. -- | Get initial Llvm environment.
initLlvmEnv :: DynFlags -> LlvmEnv initLlvmEnv :: DynFlags -> LlvmEnv
initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags) initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags)
where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ] where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions dflags ]
-- | Here we pre-initialise some functions that are used internally by GHC -- | Here we pre-initialise some functions that are used internally by GHC
-- so as to make sure they have the most general type in the case that -- so as to make sure they have the most general type in the case that
-- user code also uses these functions but with a different type than GHC -- user code also uses these functions but with a different type than GHC
-- internally. (Main offender is treating return type as 'void' instead of -- internally. (Main offender is treating return type as 'void' instead of
-- 'void *'. Fixes trac #5486. -- 'void *'. Fixes trac #5486.
ghcInternalFunctions :: [(LMString, LlvmFunctionDecl)] ghcInternalFunctions :: DynFlags -> [(LMString, LlvmFunctionDecl)]
ghcInternalFunctions = ghcInternalFunctions dflags =
[ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord] [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
, mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord] , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
, mk "memset" i8Ptr [i8Ptr, llvmWord, llvmWord] , mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
, mk "newSpark" llvmWord [i8Ptr, i8Ptr] , mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
] ]
where where
mk n ret args = mk n ret args =
...@@ -244,12 +244,12 @@ strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-} ...@@ -244,12 +244,12 @@ strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
-- | Create an external definition for a 'CLabel' defined in another module. -- | Create an external definition for a 'CLabel' defined in another module.
genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
genCmmLabelRef env = genStringLabelRef . strCLabel_llvm env genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env
-- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'. -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
genStringLabelRef :: LMString -> LMGlobal genStringLabelRef :: DynFlags -> LMString -> LMGlobal
genStringLabelRef cl genStringLabelRef dflags cl
= let ty = LMPointer $ LMArray 0 llvmWord = let ty = LMPointer $ LMArray 0 (llvmWord dflags)
in (LMGlobalVar cl ty External Nothing Nothing False, Nothing) in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
......
...@@ -55,11 +55,11 @@ basicBlocksCodeGen :: LlvmEnv ...@@ -55,11 +55,11 @@ basicBlocksCodeGen :: LlvmEnv
-> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) -> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
-> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
basicBlocksCodeGen env ([]) (blocks, tops) basicBlocksCodeGen env ([]) (blocks, tops)
= do let platform = targetPlatform $ getDflags env = do let dflags = getDflags env
let (blocks', allocs) = mapAndUnzip dominateAllocs blocks let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
let allocs' = concat allocs let allocs' = concat allocs
let ((BasicBlock id fstmts):rblks) = blocks' let ((BasicBlock id fstmts):rblks) = blocks'
let fblocks = (BasicBlock id $ funPrologue platform ++ allocs' ++ fstmts):rblks let fblocks = (BasicBlock id $ funPrologue dflags ++ allocs' ++ fstmts):rblks
return (env, fblocks, tops) return (env, fblocks, tops)
basicBlocksCodeGen env (block:blocks) (lblocks', ltops') basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
...@@ -185,7 +185,8 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _ ...@@ -185,7 +185,8 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _
-- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
-- is strict about types. -- is strict about types.
genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
let width = widthToLlvmInt w let dflags = getDflags env
width = widthToLlvmInt w
dstTy = cmmToLlvmType $ localRegType dst dstTy = cmmToLlvmType $ localRegType dst
funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible
CC_Ccc width FixedArgs (tysToParams [width]) Nothing CC_Ccc width FixedArgs (tysToParams [width]) Nothing
...@@ -193,9 +194,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do ...@@ -193,9 +194,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
(env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, []) (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, [])
(env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t
(argsV', stmts4) <- castVars $ zip argsV [width] (argsV', stmts4) <- castVars dflags $ zip argsV [width]
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] (retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
([retV'], stmts5) <- castVars [(retV,dstTy)] ([retV'], stmts5) <- castVars dflags [(retV,dstTy)]
let s2 = Store retV' dstV let s2 = Store retV' dstV
let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL`
...@@ -208,17 +209,18 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn ...@@ -208,17 +209,18 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn
| op == MO_Memcpy || | op == MO_Memcpy ||
op == MO_Memset || op == MO_Memset ||
op == MO_Memmove = do op == MO_Memmove = do
let (args, alignVal) = splitAlignVal args' let dflags = getDflags env
(args, alignVal) = splitAlignVal args'
(isVolTy, isVolVal) = if getLlvmVer env >= 28 (isVolTy, isVolVal) = if getLlvmVer env >= 28
then ([i1], [mkIntLit i1 0]) else ([], []) then ([i1], [mkIntLit i1 0]) else ([], [])
argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy
| otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
(env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
(env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
(argVars', stmts3) <- castVars $ zip argVars argTy (argVars', stmts3) <- castVars dflags $ zip argVars argTy
let arguments = argVars' ++ (alignVal:isVolVal) let arguments = argVars' ++ (alignVal:isVolVal)
call = Expr $ Call StdCall fptr arguments [] call = Expr $ Call StdCall fptr arguments []
...@@ -415,16 +417,17 @@ arg_vars env (CmmHinted e _:rest) (vars, stmts, tops) ...@@ -415,16 +417,17 @@ arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
-- | Cast a collection of LLVM variables to specific types. -- | Cast a collection of LLVM variables to specific types.
castVars :: [(LlvmVar, LlvmType)] castVars :: DynFlags -> [(LlvmVar, LlvmType)]
-> UniqSM ([LlvmVar], LlvmStatements) -> UniqSM ([LlvmVar], LlvmStatements)
castVars vars = do castVars dflags vars = do
done <- mapM (uncurry castVar) vars done <- mapM (uncurry (castVar dflags)) vars
let (vars', stmts) = unzip done let (vars', stmts) = unzip done
return (vars', toOL stmts) return (vars', toOL stmts)
-- | Cast an LLVM variable to a specific type, panicing if it can't be done. -- | Cast an LLVM variable to a specific type, panicing if it can't be done.
castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement)
castVar v t | getVarType v == t castVar dflags v t
| getVarType v == t
= return (v, Nop) = return (v, Nop)
| otherwise | otherwise
...@@ -432,7 +435,7 @@ castVar v t | getVarType v == t ...@@ -432,7 +435,7 @@ castVar v t | getVarType v == t
(LMInt n, LMInt m) (LMInt n, LMInt m)
-> if n < m then LM_Sext else LM_Trunc -> if n < m then LM_Sext else LM_Trunc
(vt, _) | isFloat vt && isFloat t (vt, _) | isFloat vt && isFloat t
-> if llvmWidthInBits vt < llvmWidthInBits t -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
then LM_Fpext else LM_Fptrunc then LM_Fpext else LM_Fptrunc
(vt, _) | isInt vt && isFloat t -> LM_Sitofp (vt, _) | isInt vt && isFloat t -> LM_Sitofp
(vt, _) | isFloat vt && isInt t -> LM_Fptosi (vt, _) | isFloat vt && isInt t -> LM_Fptosi
...@@ -498,10 +501,11 @@ cmmPrimOpFunctions env mop ...@@ -498,10 +501,11 @@ cmmPrimOpFunctions env mop
MO_Touch -> unsupported MO_Touch -> unsupported
where where
dflags = getDflags env
intrinTy1 = (if getLlvmVer env >= 28 intrinTy1 = (if getLlvmVer env >= 28
then "p0i8.p0i8." else "") ++ show llvmWord then "p0i8.p0i8." else "") ++ show (llvmWord dflags)
intrinTy2 = (if getLlvmVer env >= 28 intrinTy2 = (if getLlvmVer env >= 28
then "p0i8." else "") ++ show llvmWord then "p0i8." else "") ++ show (llvmWord dflags)
unsupported = panic ("cmmPrimOpFunctions: " ++ show mop unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
++ " not supported here") ++ " not supported here")
...@@ -543,12 +547,13 @@ genJump env expr live = do ...@@ -543,12 +547,13 @@ genJump env expr live = do
-- these with registers when possible. -- these with registers when possible.
genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
genAssign env reg val = do genAssign env reg val = do
let (env1, vreg, stmts1, top1) = getCmmReg env reg let dflags = getDflags env
(env1, vreg, stmts1, top1) = getCmmReg env reg
(env2, vval, stmts2, top2) <- exprToVar env1 val (env2, vval, stmts2, top2) <- exprToVar env1 val
let stmts = stmts1 `appOL` stmts2 let stmts = stmts1 `appOL` stmts2
let ty = (pLower . getVarType) vreg let ty = (pLower . getVarType) vreg
case isPointer ty && getVarType vval == llvmWord of case isPointer ty && getVarType vval == llvmWord dflags of
-- Some registers are pointer types, so need to cast value to pointer -- Some registers are pointer types, so need to cast value to pointer
True -> do True -> do
(v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
...@@ -594,10 +599,11 @@ genStore env addr val = genStore_slow env addr val [other] ...@@ -594,10 +599,11 @@ genStore env addr val = genStore_slow env addr val [other]
genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
-> UniqSM StmtData -> UniqSM StmtData
genStore_fast env addr r n val genStore_fast env addr r n val
= let gr = lmGlobalRegVar r = let dflags = getDflags env
gr = lmGlobalRegVar (getDflags env) r
meta = [getTBAA r] meta = [getTBAA r]
grt = (pLower . getVarType) gr grt = (pLower . getVarType) gr
(ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
in case isPointer grt && rem == 0 of in case isPointer grt && rem == 0 of
True -> do True -> do
(env', vval, stmts, top) <- exprToVar env val (env', vval, stmts, top) <- exprToVar env val
...@@ -634,7 +640,7 @@ genStore_slow env addr val meta = do ...@@ -634,7 +640,7 @@ genStore_slow env addr val meta = do
let stmts = stmts1 `appOL` stmts2 let stmts = stmts1 `appOL` stmts2
case getVarType vaddr of case getVarType vaddr of
-- sometimes we need to cast an int to a pointer before storing -- sometimes we need to cast an int to a pointer before storing
LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
(v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
let s2 = MetaStmt meta $ Store v vaddr let s2 = MetaStmt meta $ Store v vaddr
return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
...@@ -643,7 +649,7 @@ genStore_slow env addr val meta = do ...@@ -643,7 +649,7 @@ genStore_slow env addr val meta = do
let s1 = MetaStmt meta $ Store vval vaddr let s1 = MetaStmt meta $ Store vval vaddr
return (env2, stmts `snocOL` s1, top1 ++ top2) return (env2, stmts `snocOL` s1, top1 ++ top2)
i@(LMInt _) | i == llvmWord -> do i@(LMInt _) | i == llvmWord dflags -> do
let vty = pLift $ getVarType vval let vty = pLift $ getVarType vval
(vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
let s2 = MetaStmt meta $ Store vval vptr let s2 = MetaStmt meta $ Store vval vptr
...@@ -653,7 +659,7 @@ genStore_slow env addr val meta = do ...@@ -653,7 +659,7 @@ genStore_slow env addr val meta = do
pprPanic "genStore: ptr not right type!" pprPanic "genStore: ptr not right type!"
(PprCmm.pprExpr addr <+> text ( (PprCmm.pprExpr addr <+> text (
"Size of Ptr: " ++ show (llvmPtrBits dflags) ++ "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
", Size of var: " ++ show (llvmWidthInBits other) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
", Var: " ++ show vaddr)) ", Var: " ++ show vaddr))
where dflags = getDflags env where dflags = getDflags env
...@@ -723,14 +729,14 @@ data EOption = EOption { ...@@ -723,14 +729,14 @@ data EOption = EOption {
i1Option :: EOption i1Option :: EOption
i1Option = EOption (Just i1) i1Option = EOption (Just i1)
wordOption :: EOption wordOption :: DynFlags -> EOption
wordOption = EOption (Just llvmWord) wordOption dflags = EOption (Just (llvmWord dflags))
-- | Convert a CmmExpr to a list of LlvmStatements with the result of the -- | Convert a CmmExpr to a list of LlvmStatements with the result of the
-- expression being stored in the returned LlvmVar. -- expression being stored in the returned LlvmVar.
exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
exprToVar env = exprToVarOpt env wordOption exprToVar env = exprToVarOpt env (wordOption (getDflags env))
exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
exprToVarOpt env opt e = case e of exprToVarOpt env opt e = case e of
...@@ -749,7 +755,7 @@ exprToVarOpt env opt e = case e of ...@@ -749,7 +755,7 @@ exprToVarOpt env opt e = case e of
case (isPointer . getVarType) v1 of case (isPointer . getVarType) v1 of
True -> do True -> do
-- Cmm wants the value, so pointer types must be cast to ints -- Cmm wants the value, so pointer types must be cast to ints
(v2, s2) <- doExpr llvmWord $ Cast LM_Ptrtoint v1 llvmWord (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
return (env', v2, stmts `snocOL` s1 `snocOL` s2, top) return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
False -> return (env', v1, stmts `snocOL` s1, top) False -> return (env', v1, stmts `snocOL` s1, top)
...@@ -837,6 +843,8 @@ genMachOp env _ op [x] = case op of ...@@ -837,6 +843,8 @@ genMachOp env _ op [x] = case op of
MO_S_Shr _ -> panicOp MO_S_Shr _ -> panicOp
where where
dflags = getDflags env
negate ty v2 negOp = do negate ty v2 negOp = do
(env', vx, stmts, top) <- exprToVar env x (env', vx, stmts, top) <- exprToVar env x
(v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
...@@ -852,7 +860,7 @@ genMachOp env _ op [x] = case op of ...@@ -852,7 +860,7 @@ genMachOp env _ op [x] = case op of
let sameConv' op = do let sameConv' op = do
(v1, s1) <- doExpr ty $ Cast op vx ty (v1, s1) <- doExpr ty $ Cast op vx ty
return (env', v1, stmts `snocOL` s1, top) return (env', v1, stmts `snocOL` s1, top)
let toWidth = llvmWidthInBits ty let toWidth = llvmWidthInBits dflags ty
-- LLVM doesn't like trying to convert to same width, so -- LLVM doesn't like trying to convert to same width, so
-- need to check for that as we do get Cmm code doing it. -- need to check for that as we do get Cmm code doing it.
case widthInBits from of case widthInBits from of
...@@ -880,14 +888,15 @@ genMachOp env opt op e = genMachOp_slow env opt op e ...@@ -880,14 +888,15 @@ genMachOp env opt op e = genMachOp_slow env opt op e
genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
-> UniqSM ExprData -> UniqSM ExprData
genMachOp_fast env opt op r n e genMachOp_fast env opt op r n e
= let gr = lmGlobalRegVar r = let dflags = getDflags env
gr = lmGlobalRegVar dflags r
grt = (pLower . getVarType) gr grt = (pLower . getVarType) gr
(ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
in case isPointer grt && rem == 0 of in case isPointer grt && rem == 0 of
True -> do True -> do
(gv, s1) <- doExpr grt $ Load gr (gv, s1) <- doExpr grt $ Load gr
(ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
(var, s3) <- doExpr llvmWord $ Cast LM_Ptrtoint ptr llvmWord (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
False -> genMachOp_slow env opt op e False -> genMachOp_slow env opt op e
...@@ -957,6 +966,8 @@ genMachOp_slow env opt op [x, y] = case op of ...@@ -957,6 +966,8 @@ genMachOp_slow env opt op [x, y] = case op of
MO_FF_Conv _ _ -> panicOp MO_FF_Conv _ _ -> panicOp
where where
dflags = getDflags env
binLlvmOp ty binOp = do binLlvmOp ty binOp = do
(env1, vx, stmts1, top1) <- exprToVar env x (env1, vx, stmts1, top1) <- exprToVar env x
(env2, vy, stmts2, top2) <- exprToVar env1 y (env2, vy, stmts2, top2) <- exprToVar env1 y
...@@ -1017,10 +1028,10 @@ genMachOp_slow env opt op [x, y] = case op of ...@@ -1017,10 +1028,10 @@ genMachOp_slow env opt op [x, y] = case op of
(env2, vy, stmts2, top2) <- exprToVar env1 y (env2, vy, stmts2, top2) <- exprToVar env1 y
let word = getVarType vx let word = getVarType vx
let word2 = LMInt $ 2 * (llvmWidthInBits $ getVarType vx) let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
let shift = llvmWidthInBits word let shift = llvmWidthInBits dflags word
let shift1 = toIWord (shift - 1) let shift1 = toIWord dflags (shift - 1)
let shift2 = toIWord shift let shift2 = toIWord dflags shift
if isInt word if isInt word
then do then do
...@@ -1081,11 +1092,12 @@ genLoad env e ty = genLoad_slow env e ty [other] ...@@ -1081,11 +1092,12 @@ genLoad env e ty = genLoad_slow env e ty [other]
genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
-> UniqSM ExprData -> UniqSM ExprData
genLoad_fast env e r n ty = genLoad_fast env e r n ty =
let gr = lmGlobalRegVar r let dflags = getDflags env
gr = lmGlobalRegVar dflags r
meta = [getTBAA r] meta = [getTBAA r]
grt = (pLower . getVarType) gr grt = (pLower . getVarType) gr
ty' = cmmToLlvmType ty ty' = cmmToLlvmType ty
(ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
in case isPointer grt && rem == 0 of in case isPointer grt && rem == 0 of
True -> do True -> do
(gv, s1) <- doExpr grt $ Load gr (gv, s1) <- doExpr grt $ Load gr
...@@ -1122,7 +1134,7 @@ genLoad_slow env e ty meta = do ...@@ -1122,7 +1134,7 @@ genLoad_slow env e ty meta = do
(MetaExpr meta $ Load iptr) (MetaExpr meta $ Load iptr)
return (env', dvar, stmts `snocOL` load, tops) return (env', dvar, stmts `snocOL` load, tops)
i@(LMInt _) | i == llvmWord -> do i@(LMInt _) | i == llvmWord dflags -> do
let pty = LMPointer $ cmmToLlvmType ty let pty = LMPointer $ cmmToLlvmType ty
(ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
(dvar, load) <- doExpr (cmmToLlvmType ty) (dvar, load) <- doExpr (cmmToLlvmType ty)
...@@ -1132,7 +1144,7 @@ genLoad_slow env e ty meta = do ...@@ -1132,7 +1144,7 @@ genLoad_slow env e ty meta = do
other -> pprPanic "exprToVar: CmmLoad expression is not right type!" other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
(PprCmm.pprExpr e <+> text ( (PprCmm.pprExpr e <+> text (
"Size of Ptr: " ++ show (llvmPtrBits dflags) ++ "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
", Size of var: " ++ show (llvmWidthInBits other) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
", Var: " ++