summaryrefslogtreecommitdiff
path: root/compiler/llvmGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/llvmGen')
-rw-r--r--compiler/llvmGen/Llvm/AbsSyn.hs10
-rw-r--r--compiler/llvmGen/Llvm/MetaData.hs2
-rw-r--r--compiler/llvmGen/Llvm/PpLlvm.hs4
-rw-r--r--compiler/llvmGen/Llvm/Types.hs6
-rw-r--r--compiler/llvmGen/LlvmCodeGen.hs13
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Base.hs2
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs159
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Data.hs10
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Ppr.hs65
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Regs.hs2
-rw-r--r--compiler/llvmGen/LlvmMangler.hs2
11 files changed, 170 insertions, 105 deletions
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 8f38c799c7..a89ee35706 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -4,6 +4,8 @@
module Llvm.AbsSyn where
+import GhcPrelude
+
import Llvm.MetaData
import Llvm.Types
@@ -106,7 +108,7 @@ data LlvmAtomicOp
-- | Llvm Statements
data LlvmStatement
{- |
- Assign an expression to an variable:
+ Assign an expression to a variable:
* dest: Variable to assign to
* source: Source expression
-}
@@ -258,7 +260,7 @@ data LlvmExpression
| ALoad LlvmSyncOrdering SingleThreaded LlvmVar
{- |
- Navigate in an structure, selecting elements
+ Navigate in a structure, selecting elements
* inbound: Is the pointer inbounds? (computed pointer doesn't overflow)
* ptr: Location of the structure
* indexes: A list of indexes to select the correct value.
@@ -323,8 +325,8 @@ data LlvmExpression
basic block in a new variable of type tp.
* tp: type of the merged variable, must match the types of the
predecessor variables.
- * precessors: A list of variables and the basic block that they originate
- from.
+ * predecessors: A list of variables and the basic block that they originate
+ from.
-}
| Phi LlvmType [(LlvmVar,LlvmVar)]
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
index 5fe9e37ddc..97e8086f42 100644
--- a/compiler/llvmGen/Llvm/MetaData.hs
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -2,6 +2,8 @@
module Llvm.MetaData where
+import GhcPrelude
+
import Llvm.Types
import Outputable
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 293999bd1e..b350ab408d 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -25,6 +25,8 @@ module Llvm.PpLlvm (
#include "HsVersions.h"
+import GhcPrelude
+
import Llvm.AbsSyn
import Llvm.MetaData
import Llvm.Types
@@ -238,7 +240,7 @@ ppLlvmExpression expr
Malloc tp amount -> ppMalloc tp amount
AtomicRMW aop tgt src ordering -> ppAtomicRMW aop tgt src ordering
CmpXChg addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord
- Phi tp precessors -> ppPhi tp precessors
+ Phi tp predecessors -> ppPhi tp predecessors
Asm asm c ty v se sk -> ppAsm asm c ty v se sk
MExpr meta expr -> ppMetaExpr meta expr
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index bf23cd89f7..bc7bbaab1b 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -8,6 +8,8 @@ module Llvm.Types where
#include "HsVersions.h"
+import GhcPrelude
+
import Data.Char
import Data.Int
import Numeric
@@ -152,6 +154,7 @@ data LlvmStatic
-- static expressions, could split out but leave
-- for moment for ease of use. Not many of them.
+ | LMTrunc LlvmStatic LlvmType -- ^ Truncate
| LMBitc LlvmStatic LlvmType -- ^ Pointer to Pointer conversion
| LMPtoI LlvmStatic LlvmType -- ^ Pointer to Integer conversion
| LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation
@@ -165,6 +168,8 @@ instance Outputable LlvmStatic where
ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']'
ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>"
ppr (LMStaticPointer v) = ppr v
+ ppr (LMTrunc v t)
+ = ppr t <> text " trunc (" <> ppr v <> text " to " <> ppr t <> char ')'
ppr (LMBitc v t)
= ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')'
ppr (LMPtoI v t)
@@ -275,6 +280,7 @@ getStatType (LMStaticStr _ t) = t
getStatType (LMStaticArray _ t) = t
getStatType (LMStaticStruc _ t) = t
getStatType (LMStaticPointer v) = getVarType v
+getStatType (LMTrunc _ t) = t
getStatType (LMBitc _ t) = t
getStatType (LMPtoI _ t) = t
getStatType (LMAdd t _) = getStatType t
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 71b9996ceb..3fcf83ab2f 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -7,6 +7,8 @@ module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
#include "HsVersions.h"
+import GhcPrelude
+
import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.CodeGen
@@ -72,7 +74,7 @@ llvmCodeGen dflags h us cmm_stream
llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
llvmCodeGen' cmm_stream
= do -- Preamble
- renderLlvm pprLlvmHeader
+ renderLlvm header
ghcInternalFunctions
cmmMetaLlvmPrelude
@@ -85,6 +87,15 @@ llvmCodeGen' cmm_stream
-- Postamble
cmmUsedLlvmGens
+ where
+ header :: SDoc
+ header = sdocWithDynFlags $ \dflags ->
+ let target = LLVM_TARGET
+ layout = case lookup target (llvmTargets dflags) of
+ Just (LlvmTarget dl _ _) -> dl
+ Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)
+ in text ("target datalayout = \"" ++ layout ++ "\"")
+ $+$ text ("target triple = \"" ++ target ++ "\"")
llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
llvmGroupLlvmGens cmm = do
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 424891fe77..6e20da48c1 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -37,6 +37,8 @@ module LlvmCodeGen.Base (
#include "HsVersions.h"
#include "ghcautoconf.h"
+import GhcPrelude
+
import Llvm
import LlvmCodeGen.Regs
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index a4f67fa4d2..3a56b33753 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -7,6 +7,8 @@ module LlvmCodeGen.CodeGen ( genLlvmProc ) where
#include "HsVersions.h"
+import GhcPrelude
+
import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.Regs
@@ -36,16 +38,16 @@ import Util
import Control.Monad.Trans.Class
import Control.Monad.Trans.Writer
-#if __GLASGOW_HASKELL__ > 710
import Data.Semigroup ( Semigroup )
import qualified Data.Semigroup as Semigroup
-#endif
import Data.List ( nub )
import Data.Maybe ( catMaybes )
type Atomic = Bool
type LlvmStatements = OrdList LlvmStatement
+data Signage = Signed | Unsigned deriving (Eq, Show)
+
-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM proc Code generator
--
@@ -207,7 +209,7 @@ genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
let args_hints' = zip args arg_hints
argVars <- arg_varsW args_hints' ([], nilOL, [])
fptr <- liftExprData $ getFunPtr funTy t
- argVars' <- castVarsW $ zip argVars argTy
+ argVars' <- castVarsW Signed $ zip argVars argTy
let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]
statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
@@ -217,6 +219,11 @@ genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
-- and return types
genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
genCallSimpleCast w t dsts args
+
+genCall t@(PrimTarget (MO_Pdep w)) dsts args =
+ genCallSimpleCast2 w t dsts args
+genCall t@(PrimTarget (MO_Pext w)) dsts args =
+ genCallSimpleCast2 w t dsts args
genCall t@(PrimTarget (MO_Clz w)) dsts args =
genCallSimpleCast w t dsts args
genCall t@(PrimTarget (MO_Ctz w)) dsts args =
@@ -284,7 +291,7 @@ genCall t@(PrimTarget op) [] args
let args_hints = zip args arg_hints
argVars <- arg_varsW args_hints ([], nilOL, [])
fptr <- getFunPtrW funTy t
- argVars' <- castVarsW $ zip argVars argTy
+ argVars' <- castVarsW Signed $ zip argVars argTy
let alignVal = mkIntLit i32 align
arguments = argVars' ++ (alignVal:isVolVal)
@@ -368,6 +375,9 @@ genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =
genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =
genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] =
+ genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
@@ -480,6 +490,7 @@ genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
let valid = op `elem` [ MO_Add2 w
, MO_AddIntC w
, MO_SubIntC w
+ , MO_AddWordC w
, MO_SubWordC w
]
MASSERT(valid)
@@ -515,7 +526,7 @@ genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do
-- Process the arguments.
let args_hints = zip [argA, argB] (snd $ foreignTargetHints target)
(argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, [])
- (argsV2, args2) <- castVars $ zip argsV1 argTy
+ (argsV2, args2) <- castVars Signed $ zip argsV1 argTy
-- Get the function and make the call.
fname <- cmmPrimOpFunctions op
@@ -555,9 +566,10 @@ genCallSimpleCast w t@(PrimTarget op) [dst] args = do
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]
+ (argsV', stmts4) <- castVars Signed $ zip argsV [width]
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
- ([retV'], stmts5) <- castVars [(retV,dstTy)]
+ (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+ let retV' = singletonPanic "genCallSimpleCast" retVs'
let s2 = Store retV' dstV
let stmts = stmts2 `appOL` stmts4 `snocOL`
@@ -566,6 +578,38 @@ genCallSimpleCast w t@(PrimTarget op) [dst] args = do
genCallSimpleCast _ _ dsts _ =
panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
+-- 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.
+genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+ -> LlvmM StmtData
+genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do
+ let width = widthToLlvmInt w
+ dstTy = cmmToLlvmType $ localRegType dst
+
+ fname <- cmmPrimOpFunctions op
+ (fptr, _, top3) <- getInstrinct fname width (const width <$> args)
+
+ 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 Signed $ zip argsV (const width <$> argsV)
+ (retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
+ (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+ let retV' = singletonPanic "genCallSimpleCast2" retVs'
+ let s2 = Store retV' dstV
+
+ let stmts = stmts2 `appOL` stmts4 `snocOL`
+ s1 `appOL` stmts5 `snocOL` s2
+ return (stmts, top2 ++ top3)
+genCallSimpleCast2 _ _ dsts _ =
+ panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts")
+
-- | Create a function pointer from a target.
getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget
-> WriterT LlvmAccum LlvmM LlvmVar
@@ -635,31 +679,32 @@ arg_vars ((e, _):rest) (vars, stmts, tops)
-- | Cast a collection of LLVM variables to specific types.
-castVarsW :: [(LlvmVar, LlvmType)]
+castVarsW :: Signage
+ -> [(LlvmVar, LlvmType)]
-> WriterT LlvmAccum LlvmM [LlvmVar]
-castVarsW vars = do
- (vars, stmts) <- lift $ castVars vars
+castVarsW signage vars = do
+ (vars, stmts) <- lift $ castVars signage vars
tell $ LlvmAccum stmts mempty
return vars
-- | Cast a collection of LLVM variables to specific types.
-castVars :: [(LlvmVar, LlvmType)]
+castVars :: Signage -> [(LlvmVar, LlvmType)]
-> LlvmM ([LlvmVar], LlvmStatements)
-castVars vars = do
- done <- mapM (uncurry castVar) vars
+castVars signage vars = do
+ done <- mapM (uncurry (castVar signage)) 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 :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
-castVar v t | getVarType v == t
+castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
+castVar signage v t | getVarType v == t
= return (v, Nop)
| otherwise
= do dflags <- getDynFlags
let op = case (getVarType v, t) of
(LMInt n, LMInt m)
- -> if n < m then LM_Sext else LM_Trunc
+ -> if n < m then extend else LM_Trunc
(vt, _) | isFloat vt && isFloat t
-> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
then LM_Fpext else LM_Fptrunc
@@ -673,7 +718,16 @@ castVar v t | getVarType v == t
(vt, _) -> panic $ "castVars: Can't cast this type ("
++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
doExpr t $ Cast op v t
+ where extend = case signage of
+ Signed -> LM_Sext
+ Unsigned -> LM_Zext
+
+cmmPrimOpRetValSignage :: CallishMachOp -> Signage
+cmmPrimOpRetValSignage mop = case mop of
+ MO_Pdep _ -> Unsigned
+ MO_Pext _ -> Unsigned
+ _ -> Signed
-- | Decide what C function to use to implement a CallishMachOp
cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
@@ -704,6 +758,10 @@ cmmPrimOpFunctions mop = do
MO_F32_Cosh -> fsLit "coshf"
MO_F32_Tanh -> fsLit "tanhf"
+ MO_F32_Asinh -> fsLit "asinhf"
+ MO_F32_Acosh -> fsLit "acoshf"
+ MO_F32_Atanh -> fsLit "atanhf"
+
MO_F64_Exp -> fsLit "exp"
MO_F64_Log -> fsLit "log"
MO_F64_Sqrt -> fsLit "llvm.sqrt.f64"
@@ -722,15 +780,29 @@ cmmPrimOpFunctions mop = do
MO_F64_Cosh -> fsLit "cosh"
MO_F64_Tanh -> fsLit "tanh"
+ MO_F64_Asinh -> fsLit "asinh"
+ MO_F64_Acosh -> fsLit "acosh"
+ MO_F64_Atanh -> fsLit "atanh"
+
MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1
MO_Memmove _ -> fsLit $ "llvm.memmove." ++ intrinTy1
MO_Memset _ -> fsLit $ "llvm.memset." ++ intrinTy2
+ MO_Memcmp _ -> fsLit $ "memcmp"
(MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
(MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
(MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
(MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ (MO_Pdep w) -> let w' = showSDoc dflags (ppr $ widthInBits w)
+ in if isBmi2Enabled dflags
+ then fsLit $ "llvm.x86.bmi.pdep." ++ w'
+ else fsLit $ "hs_pdep" ++ w'
+ (MO_Pext w) -> let w' = showSDoc dflags (ppr $ widthInBits w)
+ in if isBmi2Enabled dflags
+ then fsLit $ "llvm.x86.bmi.pext." ++ w'
+ else fsLit $ "hs_pext" ++ w'
+
(MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"
MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow."
@@ -739,6 +811,8 @@ cmmPrimOpFunctions mop = do
++ showSDoc dflags (ppr $ widthToLlvmInt w)
MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow."
++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ MO_AddWordC w -> fsLit $ "llvm.uadd.with.overflow."
+ ++ showSDoc dflags (ppr $ widthToLlvmInt w)
MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow."
++ showSDoc dflags (ppr $ widthToLlvmInt w)
@@ -1136,6 +1210,8 @@ genMachOp _ op [x] = case op of
all0s = LMLitVar $ LMVectorLit (replicate len all0)
in negateVec vecty all0s LM_MO_FSub
+ MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"
+
-- Handle unsupported cases explicitly so we get a warning
-- of missing case when new MachOps added
MO_Add _ -> panicOp
@@ -1206,7 +1282,8 @@ genMachOp _ op [x] = case op of
negateVec ty v2 negOp = do
(vx, stmts1, top) <- exprToVar x
- ([vx'], stmts2) <- castVars [(vx, ty)]
+ (vxs', stmts2) <- castVars Signed [(vx, ty)]
+ let vx' = singletonPanic "genMachOp: negateVec" vxs'
(v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
@@ -1269,7 +1346,8 @@ genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
vval <- exprToVarW val
vidx <- exprToVarW idx
- [vval'] <- castVarsW [(vval, LMVector l ty)]
+ vval' <- singletonPanic "genMachOp_slow" <$>
+ castVarsW Signed [(vval, LMVector l ty)]
doExprW ty $ Extract vval' vidx
where
ty = widthToLlvmInt w
@@ -1277,7 +1355,8 @@ genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
vval <- exprToVarW val
vidx <- exprToVarW idx
- [vval'] <- castVarsW [(vval, LMVector l ty)]
+ vval' <- singletonPanic "genMachOp_slow" <$>
+ castVarsW Signed [(vval, LMVector l ty)]
doExprW ty $ Extract vval' vidx
where
ty = widthToLlvmFloat w
@@ -1287,7 +1366,8 @@ genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
vval <- exprToVarW val
velt <- exprToVarW elt
vidx <- exprToVarW idx
- [vval'] <- castVarsW [(vval, ty)]
+ vval' <- singletonPanic "genMachOp_slow" <$>
+ castVarsW Signed [(vval, ty)]
doExprW ty $ Insert vval' velt vidx
where
ty = LMVector l (widthToLlvmInt w)
@@ -1296,7 +1376,8 @@ genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
vval <- exprToVarW val
velt <- exprToVarW elt
vidx <- exprToVarW idx
- [vval'] <- castVarsW [(vval, ty)]
+ vval' <- singletonPanic "genMachOp_slow" <$>
+ castVarsW Signed [(vval, ty)]
doExprW ty $ Insert vval' velt vidx
where
ty = LMVector l (widthToLlvmFloat w)
@@ -1385,6 +1466,8 @@ genMachOp_slow opt op [x, y] = case op of
MO_VF_Neg {} -> panicOp
+ MO_AlignmentCheck {} -> panicOp
+
where
binLlvmOp ty binOp = runExprData $ do
vx <- exprToVarW x
@@ -1406,8 +1489,10 @@ genMachOp_slow opt op [x, y] = case op of
binCastLlvmOp ty binOp = runExprData $ do
vx <- exprToVarW x
vy <- exprToVarW y
- [vx', vy'] <- castVarsW [(vx, ty), (vy, ty)]
- doExprW ty $ binOp vx' vy'
+ vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]
+ case vxy' of
+ [vx',vy'] -> doExprW ty $ binOp vx' vy'
+ _ -> panic "genMachOp_slow: binCastLlvmOp"
-- | Need to use EOption here as Cmm expects word size results from
-- comparisons while LLVM return i1. Need to extend to llvmWord type
@@ -1463,8 +1548,8 @@ genMachOp_slow opt op [x, y] = case op of
panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
++ "with two arguments! (" ++ show op ++ ")"
--- More then two expression, invalid!
-genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
+-- More than two expression, invalid!
+genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!"
-- | Handle CmmLoad expression.
@@ -1650,7 +1735,7 @@ genLit opt (CmmLabelOff label off) = do
(v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
return (v1, stmts `snocOL` s1, stat)
-genLit opt (CmmLabelDiffOff l1 l2 off) = do
+genLit opt (CmmLabelDiffOff l1 l2 off w) = do
dflags <- getDynFlags
(vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
(vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
@@ -1659,13 +1744,17 @@ genLit opt (CmmLabelDiffOff l1 l2 off) = do
let ty2 = getVarType vl2
if (isInt ty1) && (isInt ty2)
&& (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
-
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 (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
- stat1 ++ stat2)
-
+ let ty = widthToLlvmInt w
+ let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2
+ if w /= wordWidth dflags
+ then do
+ (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty
+ return (v3, stmts `snocOL` s3, stat1 ++ stat2)
+ else
+ return (v2, stmts, stat1 ++ stat2)
else
panic "genLit: CmmLabelDiffOff encountered with different label ty!"
@@ -1832,16 +1921,13 @@ getTBAARegMeta = getTBAAMeta . getTBAA
-- | A more convenient way of accumulating LLVM statements and declarations.
data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
-#if __GLASGOW_HASKELL__ > 710
instance Semigroup LlvmAccum where
LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =
LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)
-#endif
instance Monoid LlvmAccum where
mempty = LlvmAccum nilOL []
- LlvmAccum stmtsA declsA `mappend` LlvmAccum stmtsB declsB =
- LlvmAccum (stmtsA `mappend` stmtsB) (declsA `mappend` declsB)
+ mappend = (Semigroup.<>)
liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
liftExprData action = do
@@ -1876,3 +1962,8 @@ getCmmRegW = lift . getCmmReg
genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
genLoadW atomic e ty = liftExprData $ genLoad atomic e ty
+
+-- | Return element of single-element list; 'panic' if list is not a single-element list
+singletonPanic :: String -> [a] -> a
+singletonPanic _ [x] = x
+singletonPanic s _ = panic s
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 39abbd1ac0..36d51e9e18 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -9,6 +9,8 @@ module LlvmCodeGen.Data (
#include "HsVersions.h"
+import GhcPrelude
+
import Llvm
import LlvmCodeGen.Base
@@ -146,12 +148,14 @@ genStaticLit (CmmLabelOff label off) = do
let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
return $ LMAdd var offset
-genStaticLit (CmmLabelDiffOff l1 l2 off) = do
+genStaticLit (CmmLabelDiffOff l1 l2 off w) = do
dflags <- getDynFlags
var1 <- genStaticLit (CmmLabel l1)
var2 <- genStaticLit (CmmLabel l2)
- let var = LMSub var1 var2
- offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
+ let var
+ | w == wordWidth dflags = LMSub var1 var2
+ | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w)
+ offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w)
return $ LMAdd var offset
genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 8614084f0c..2a8340bcf9 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -4,18 +4,19 @@
-- | Pretty print helpers for the LLVM Code generator.
--
module LlvmCodeGen.Ppr (
- pprLlvmHeader, pprLlvmCmmDecl, pprLlvmData, infoSection
+ pprLlvmCmmDecl, pprLlvmData, infoSection
) where
#include "HsVersions.h"
+import GhcPrelude
+
import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.Data
import CLabel
import Cmm
-import Platform
import FastString
import Outputable
@@ -25,66 +26,6 @@ import Unique
-- * Top level
--
--- | Header code for LLVM modules
-pprLlvmHeader :: SDoc
-pprLlvmHeader = moduleLayout
-
-
--- | LLVM module layout description for the host target
-moduleLayout :: SDoc
-moduleLayout = sdocWithPlatform $ \platform ->
- case platform of
- Platform { platformArch = ArchX86, platformOS = OSDarwin } ->
- text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:128:128-n8:16:32\""
- $+$ text "target triple = \"i386-apple-darwin9.8\""
- Platform { platformArch = ArchX86, platformOS = OSMinGW32 } ->
- text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f80:128:128-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
- $+$ text "target triple = \"i686-pc-win32\""
- Platform { platformArch = ArchX86, platformOS = OSLinux } ->
- text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:32:64-f32:32:32-f64:32:64-v64:64:64-v128:128:128-a0:0:64-f80:32:32-n8:16:32\""
- $+$ text "target triple = \"i386-pc-linux-gnu\""
- Platform { platformArch = ArchX86_64, platformOS = OSDarwin } ->
- text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
- $+$ text "target triple = \"x86_64-apple-darwin10.0.0\""
- Platform { platformArch = ArchX86_64, platformOS = OSLinux } ->
- text "target datalayout = \"e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64\""
- $+$ text "target triple = \"x86_64-linux-gnu\""
- Platform { platformArch = ArchARM {}, platformOS = OSLinux } ->
- text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
- $+$ text "target triple = \"armv6-unknown-linux-gnueabihf\""
- Platform { platformArch = ArchARM {}, platformOS = OSAndroid } ->
- text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
- $+$ text "target triple = \"arm-unknown-linux-androideabi\""
- Platform { platformArch = ArchARM {}, platformOS = OSQNXNTO } ->
- text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
- $+$ text "target triple = \"arm-unknown-nto-qnx8.0.0eabi\""
- Platform { platformArch = ArchARM {}, platformOS = OSiOS } ->
- text "target datalayout = \"e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32\""
- $+$ text "target triple = \"thumbv7-apple-ios7.0.0\""
- Platform { platformArch = ArchARM64, platformOS = OSiOS } ->
- text "target datalayout = \"e-m:o-i64:64-i128:128-n32:64-S128\""
- $+$ text "target triple = \"arm64-apple-ios7.0.0\""
- Platform { platformArch = ArchX86, platformOS = OSiOS } ->
- text "target datalayout = \"e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128\""
- $+$ text "target triple = \"i386-apple-ios7.0.0\""
- Platform { platformArch = ArchX86_64, platformOS = OSiOS } ->
- text "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\""
- $+$ text "target triple = \"x86_64-apple-ios7.0.0\""
- Platform { platformArch = ArchARM64, platformOS = OSLinux } ->
- text "target datalayout = \"e-m:e-i64:64-i128:128-n32:64-S128\""
- $+$ text "target triple = \"aarch64-unknown-linux-gnu\""
- _ ->
- if platformIsCrossCompiling platform
- then panic "LlvmCodeGen.Ppr: Cross compiling without valid target info."
- else empty
- -- If you see the above panic, GHC is missing the required target datalayout
- -- and triple information. You can obtain this info by compiling a simple
- -- 'hello world' C program with the clang C compiler eg:
- -- clang -S hello.c -emit-llvm -o -
- -- and the first two lines of hello.ll should provide the 'target datalayout'
- -- and 'target triple' lines required.
-
-
-- | Pretty print LLVM data code
pprLlvmData :: LlvmData -> SDoc
pprLlvmData (globals, types) =
diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
index e09ab8026c..8cdf3c6869 100644
--- a/compiler/llvmGen/LlvmCodeGen/Regs.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -11,6 +11,8 @@ module LlvmCodeGen.Regs (
#include "HsVersions.h"
+import GhcPrelude
+
import Llvm
import CmmExpr
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
index eed13ba203..fe03cf21e9 100644
--- a/compiler/llvmGen/LlvmMangler.hs
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -11,6 +11,8 @@
module LlvmMangler ( llvmFixupAsm ) where
+import GhcPrelude
+
import DynFlags ( DynFlags, targetPlatform )
import Platform ( platformArch, Arch(..) )
import ErrUtils ( withTiming )
View Lorry Controller Status