summaryrefslogtreecommitdiff
path: root/compiler/llvmGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/llvmGen')
-rw-r--r--compiler/llvmGen/Llvm.hs1
-rw-r--r--compiler/llvmGen/Llvm/PpLlvm.hs106
-rw-r--r--compiler/llvmGen/LlvmCodeGen.hs41
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Base.hs16
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs57
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Ppr.hs13
6 files changed, 137 insertions, 97 deletions
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index 32df9e3217..d05a90609e 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -49,7 +49,6 @@ module Llvm (
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
- llvmSDoc
) where
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index c2177782f2..2b2725d187 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -19,9 +19,6 @@ module Llvm.PpLlvm (
ppLlvmFunctions,
ppLlvmFunction,
- -- * Utility functions
- llvmSDoc
-
) where
#include "HsVersions.h"
@@ -30,8 +27,7 @@ import Llvm.AbsSyn
import Llvm.Types
import Data.List ( intersperse )
-import Pretty
-import qualified Outputable as Out
+import Outputable
import Unique
--------------------------------------------------------------------------------
@@ -39,7 +35,7 @@ import Unique
--------------------------------------------------------------------------------
-- | Print out a whole LLVM module.
-ppLlvmModule :: LlvmModule -> Doc
+ppLlvmModule :: LlvmModule -> SDoc
ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
= ppLlvmComments comments $+$ newLine
$+$ ppLlvmAliases aliases $+$ newLine
@@ -49,20 +45,20 @@ ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
$+$ ppLlvmFunctions funcs
-- | Print out a multi-line comment, can be inside a function or on its own
-ppLlvmComments :: [LMString] -> Doc
+ppLlvmComments :: [LMString] -> SDoc
ppLlvmComments comments = vcat $ map ppLlvmComment comments
-- | Print out a comment, can be inside a function or on its own
-ppLlvmComment :: LMString -> Doc
+ppLlvmComment :: LMString -> SDoc
ppLlvmComment com = semi <+> ftext com
-- | Print out a list of global mutable variable definitions
-ppLlvmGlobals :: [LMGlobal] -> Doc
+ppLlvmGlobals :: [LMGlobal] -> SDoc
ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
-- | Print out a global mutable variable definition
-ppLlvmGlobal :: LMGlobal -> Doc
+ppLlvmGlobal :: LMGlobal -> SDoc
ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
let sect = case x of
Just x' -> text ", section" <+> doubleQuotes (ftext x')
@@ -85,21 +81,21 @@ ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
-- | Print out a list of LLVM type aliases.
-ppLlvmAliases :: [LlvmAlias] -> Doc
+ppLlvmAliases :: [LlvmAlias] -> SDoc
ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
-- | Print out an LLVM type alias.
-ppLlvmAlias :: LlvmAlias -> Doc
+ppLlvmAlias :: LlvmAlias -> SDoc
ppLlvmAlias (name, ty)
= text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
-- | Print out a list of LLVM metadata.
-ppLlvmMetas :: [LlvmMeta] -> Doc
+ppLlvmMetas :: [LlvmMeta] -> SDoc
ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
-- | Print out an LLVM metadata definition.
-ppLlvmMeta :: LlvmMeta -> Doc
+ppLlvmMeta :: LlvmMeta -> SDoc
ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas)
= exclamation <> int u <> text " = metadata !{" <>
hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}"
@@ -112,7 +108,7 @@ ppLlvmMeta (MetaNamed n metas)
pprNode n = exclamation <> int n
-- | Print out an LLVM metadata value.
-ppLlvmMetaVal :: LlvmMetaVal -> Doc
+ppLlvmMetaVal :: LlvmMetaVal -> SDoc
ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s)
ppLlvmMetaVal (MetaVar v) = texts v
ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
@@ -120,11 +116,11 @@ ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
-- | Print out a list of function definitions.
-ppLlvmFunctions :: LlvmFunctions -> Doc
+ppLlvmFunctions :: LlvmFunctions -> SDoc
ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
-- | Print out a function definition.
-ppLlvmFunction :: LlvmFunction -> Doc
+ppLlvmFunction :: LlvmFunction -> SDoc
ppLlvmFunction (LlvmFunction dec args attrs sec body) =
let attrDoc = ppSpaceJoin attrs
secDoc = case sec of
@@ -139,7 +135,7 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) =
$+$ newLine
-- | Print out a function defenition header.
-ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc
+ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
= let varg' = case varg of
VarArgs | null p -> text "..."
@@ -155,13 +151,13 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
(hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align
-- | Print out a list of function declaration.
-ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
+ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
-- | Print out a function declaration.
-- Declarations define the function type but don't define the actual body of
-- the function.
-ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
+ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
= let varg' = case varg of
VarArgs | null p -> text "..."
@@ -177,12 +173,12 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
-- | Print out a list of LLVM blocks.
-ppLlvmBlocks :: LlvmBlocks -> Doc
+ppLlvmBlocks :: LlvmBlocks -> SDoc
ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
-- | Print out an LLVM block.
-- It must be part of a function definition.
-ppLlvmBlock :: LlvmBlock -> Doc
+ppLlvmBlock :: LlvmBlock -> SDoc
ppLlvmBlock (LlvmBlock blockId stmts)
= go blockId stmts
where
@@ -201,12 +197,12 @@ ppLlvmBlock (LlvmBlock blockId stmts)
$+$ ppRest
-- | Print out an LLVM block label.
-ppLlvmBlockLabel :: LlvmBlockId -> Doc
-ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon
+ppLlvmBlockLabel :: LlvmBlockId -> SDoc
+ppLlvmBlockLabel id = pprUnique id <> colon
-- | Print out an LLVM statement.
-ppLlvmStatement :: LlvmStatement -> Doc
+ppLlvmStatement :: LlvmStatement -> SDoc
ppLlvmStatement stmt =
let ind = (text " " <>)
in case stmt of
@@ -226,7 +222,7 @@ ppLlvmStatement stmt =
-- | Print out an LLVM expression.
-ppLlvmExpression :: LlvmExpression -> Doc
+ppLlvmExpression :: LlvmExpression -> SDoc
ppLlvmExpression expr
= case expr of
Alloca tp amount -> ppAlloca tp amount
@@ -248,7 +244,7 @@ ppLlvmExpression expr
-- | Should always be a function pointer. So a global var of function type
-- (since globals are always pointers) or a local var of pointer function type.
-ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> Doc
+ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> SDoc
ppCall ct fptr vals attrs = case fptr of
--
-- if local var function pointer, unwrap
@@ -278,13 +274,13 @@ ppCall ct fptr vals attrs = case fptr of
<+> rparen <+> attrDoc
-ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> Doc
+ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp op left right =
(texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
<> comma <+> (text $ getName right)
-ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc
+ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
ppCmpOp op left right =
let cmpOp
| isInt (getVarType left) && isInt (getVarType right) = text "icmp"
@@ -299,16 +295,16 @@ ppCmpOp op left right =
<+> (text $ getName left) <> comma <+> (text $ getName right)
-ppAssignment :: LlvmVar -> Doc -> Doc
+ppAssignment :: LlvmVar -> SDoc -> SDoc
ppAssignment var expr = (text $ getName var) <+> equals <+> expr
-ppFence :: Bool -> LlvmSyncOrdering -> Doc
+ppFence :: Bool -> LlvmSyncOrdering -> SDoc
ppFence st ord =
let singleThread = case st of True -> text "singlethread"
False -> empty
in text "fence" <+> singleThread <+> ppSyncOrdering ord
-ppSyncOrdering :: LlvmSyncOrdering -> Doc
+ppSyncOrdering :: LlvmSyncOrdering -> SDoc
ppSyncOrdering SyncUnord = text "unordered"
ppSyncOrdering SyncMonotonic = text "monotonic"
ppSyncOrdering SyncAcquire = text "acquire"
@@ -316,59 +312,59 @@ ppSyncOrdering SyncRelease = text "release"
ppSyncOrdering SyncAcqRel = text "acq_rel"
ppSyncOrdering SyncSeqCst = text "seq_cst"
-ppLoad :: LlvmVar -> Doc
+ppLoad :: LlvmVar -> SDoc
ppLoad var = text "load" <+> texts var
-ppStore :: LlvmVar -> LlvmVar -> Doc
+ppStore :: LlvmVar -> LlvmVar -> SDoc
ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
-ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
+ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
-ppMalloc :: LlvmType -> Int -> Doc
+ppMalloc :: LlvmType -> Int -> SDoc
ppMalloc tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "malloc" <+> texts tp <> comma <+> texts amount'
-ppAlloca :: LlvmType -> Int -> Doc
+ppAlloca :: LlvmType -> Int -> SDoc
ppAlloca tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "alloca" <+> texts tp <> comma <+> texts amount'
-ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> Doc
+ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr inb ptr idx =
let indexes = comma <+> ppCommaJoin idx
inbound = if inb then text "inbounds" else empty
in text "getelementptr" <+> inbound <+> texts ptr <> indexes
-ppReturn :: Maybe LlvmVar -> Doc
+ppReturn :: Maybe LlvmVar -> SDoc
ppReturn (Just var) = text "ret" <+> texts var
ppReturn Nothing = text "ret" <+> texts LMVoid
-ppBranch :: LlvmVar -> Doc
+ppBranch :: LlvmVar -> SDoc
ppBranch var = text "br" <+> texts var
-ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc
+ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf cond trueT falseT
= text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
-ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc
+ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
ppPhi tp preds =
let ppPreds (val, label) = brackets $ (text $ getName val) <> comma
<+> (text $ getName label)
in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds)
-ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> Doc
+ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
ppSwitch scrut dflt targets =
let ppTarget (val, lab) = texts val <> comma <+> texts lab
ppTargets xs = brackets $ vcat (map ppTarget xs)
@@ -376,7 +372,7 @@ ppSwitch scrut dflt targets =
<+> ppTargets targets
-ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> Doc
+ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
ppAsm asm constraints rty vars sideeffect alignstack =
let asm' = doubleQuotes $ ftext asm
cons = doubleQuotes $ ftext constraints
@@ -388,15 +384,15 @@ ppAsm asm constraints rty vars sideeffect alignstack =
<+> cons <> vars'
-ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc
+ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc
ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta
-ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc
+ppMetaExpr :: [MetaData] -> LlvmExpression -> SDoc
ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta
-ppMetas :: [MetaData] -> Doc
+ppMetas :: [MetaData] -> SDoc
ppMetas meta = hcat $ map ppMeta meta
where
ppMeta (name, (LMMetaUnamed n))
@@ -406,25 +402,21 @@ ppMetas meta = hcat $ map ppMeta meta
--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------
-ppCommaJoin :: (Show a) => [a] -> Doc
+ppCommaJoin :: (Show a) => [a] -> SDoc
ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs)
-ppSpaceJoin :: (Show a) => [a] -> Doc
+ppSpaceJoin :: (Show a) => [a] -> SDoc
ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
--- | Convert SDoc to Doc
-llvmSDoc :: Out.SDoc -> Doc
-llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
-
--- | Showable to Doc
-texts :: (Show a) => a -> Doc
+-- | Showable to SDoc
+texts :: (Show a) => a -> SDoc
texts = (text . show)
-- | Blank line.
-newLine :: Doc
+newLine :: SDoc
newLine = text ""
-- | Exclamation point.
-exclamation :: Doc
+exclamation :: SDoc
exclamation = text "!"
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 531d90a8ee..5c2e420545 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -27,6 +27,7 @@ import UniqSupply
import Util
import SysTools ( figureLlvmVersion )
+import Control.Monad ( when )
import Data.IORef ( writeIORef )
import Data.Maybe ( fromMaybe )
import System.IO
@@ -48,12 +49,10 @@ llvmCodeGen dflags h us cmms
in (d,env')
in do
showPass dflags "LlVM CodeGen"
- dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc pprLlvmHeader
+ dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader
bufh <- newBufHandle h
- Prt.bufLeftRender bufh $ pprLlvmHeader
- ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
- -- cache llvm version for later use
- writeIORef (llvmVersion dflags) ver
+ Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader
+ ver <- getLlvmVersion
env' <- {-# SCC "llvm_datas_gen" #-}
cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
{-# SCC "llvm_procs_gen" #-}
@@ -61,6 +60,22 @@ llvmCodeGen dflags h us cmms
bFlush bufh
return ()
+ where
+ -- | Handle setting up the LLVM version.
+ getLlvmVersion = do
+ ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
+ -- cache llvm version for later use
+ writeIORef (llvmVersion dflags) ver
+ when (ver < minSupportLlvmVersion) $
+ errorMsg dflags (text "You are using an old version of LLVM that"
+ <> text " isn't supported anymore!"
+ $+$ text "We will try though...")
+ when (ver > maxSupportLlvmVersion) $
+ putMsg dflags (text "You are using a new version of LLVM that"
+ <> text " hasn't been tested yet!"
+ $+$ text "We will try though...")
+ return ver
+
-- -----------------------------------------------------------------------------
-- | Do LLVM code generation on all these Cmms data sections.
@@ -72,11 +87,11 @@ cmmDataLlvmGens dflags h env [] lmdata
= let (env', lmdata') = {-# SCC "llvm_resolve" #-}
resolveLlvmDatas env lmdata
lmdoc = {-# SCC "llvm_data_ppr" #-}
- Prt.vcat $ map pprLlvmData lmdata'
+ vcat $ map pprLlvmData lmdata'
in do
- dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
+ dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc
{-# SCC "llvm_data_out" #-}
- Prt.bufLeftRender h lmdoc
+ Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc
return env'
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
@@ -100,7 +115,7 @@ cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl
cmmProcLlvmGens _ _ _ _ [] _ []
= return ()
-cmmProcLlvmGens _ h _ _ [] _ ivars
+cmmProcLlvmGens dflags h _ _ [] _ ivars
= let ivars' = concat ivars
cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
ty = (LMArray (length ivars') i8Ptr)
@@ -108,6 +123,7 @@ cmmProcLlvmGens _ h _ _ [] _ ivars
lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
(Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-}
+ withPprStyleDoc dflags (mkCodeStyle CStyle) $
pprLlvmData ([lmUsed], [])
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
@@ -119,7 +135,8 @@ cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivar
cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
(us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
- Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} Prt.vcat docs
+ Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
+ withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs
cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
@@ -132,14 +149,14 @@ cmmLlvmGen dflags us env cmm = do
fixStgRegisters cmm
dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
- (pprCmmGroup (targetPlatform dflags) [fixed_cmm])
+ (pprCmmGroup [fixed_cmm])
-- generate llvm code from cmm
let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
initUs us $ genLlvmProc env fixed_cmm
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
- (vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC)
+ (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC)
return (usGen, env', llvmBC)
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 9bdb115505..19ca511f16 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -9,7 +9,8 @@ module LlvmCodeGen.Base (
LlvmCmmDecl, LlvmBasicBlock,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
- LlvmVersion, defaultLlvmVersion,
+ LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
+ maxSupportLlvmVersion,
LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform,
@@ -144,7 +145,13 @@ type LlvmVersion = Int
-- | The LLVM Version we assume if we don't know
defaultLlvmVersion :: LlvmVersion
-defaultLlvmVersion = 28
+defaultLlvmVersion = 30
+
+minSupportLlvmVersion :: LlvmVersion
+minSupportLlvmVersion = 28
+
+maxSupportLlvmVersion :: LlvmVersion
+maxSupportLlvmVersion = 31
-- ----------------------------------------------------------------------------
-- * Environment Handling
@@ -226,7 +233,10 @@ getDflags (LlvmEnv (_, _, _, d)) = d
-- | Pretty print a 'CLabel'.
strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
- (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l
+ (fsLit . toString . pprCLabel (getLlvmPlatform env)) l
+ where dflags = getDflags env
+ style = Outp.mkCodeStyle Outp.CStyle
+ toString doc = Outp.renderWithStyle dflags doc style
-- | Create an external definition for a 'CLabel' defined in another module.
genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 059328f868..79a0c00543 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -172,7 +172,7 @@ genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
-- Write barrier needs to be handled specially as it is implemented as an LLVM
-- intrinsic function.
-genCall env (CmmPrim MO_WriteBarrier) _ _ _
+genCall env (CmmPrim MO_WriteBarrier _) _ _ _
| platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
= return (env, nilOL, [])
| getLlvmVer env > 29 = barrier env
@@ -182,7 +182,7 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _
-- types and things like Word8 are backed by an i32 and just present a logical
-- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
-- is strict about types.
-genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do
+genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
let width = widthToLlvmInt w
dstTy = cmmToLlvmType $ localRegType dst
funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible
@@ -202,10 +202,12 @@ genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
-genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
- op == MO_Memset ||
- op == MO_Memmove = do
- let (isVolTy, isVolVal) = if getLlvmVer env >= 28
+genCall env t@(CmmPrim op _) [] args' CmmMayReturn
+ | op == MO_Memcpy ||
+ op == MO_Memset ||
+ op == MO_Memmove = do
+ let (args, alignVal) = splitAlignVal args'
+ (isVolTy, isVolVal) = if getLlvmVer env >= 28
then ([i1], [mkIntLit i1 0]) else ([], [])
argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy
| otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy
@@ -216,11 +218,25 @@ genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
(env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
(argVars', stmts3) <- castVars $ zip argVars argTy
- let arguments = argVars' ++ isVolVal
+ let arguments = argVars' ++ (alignVal:isVolVal)
call = Expr $ Call StdCall fptr arguments []
stmts = stmts1 `appOL` stmts2 `appOL` stmts3
`appOL` trashStmts `snocOL` call
return (env2, stmts, top1 ++ top2)
+
+ where
+ splitAlignVal xs = (init xs, extractLit $ last xs)
+
+ -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other
+ -- than a direct constant (i.e. 'i32 8') as the alignment argument for the
+ -- memcpy & co llvm intrinsic functions. So we handle this directly now.
+ extractLit (CmmHinted (CmmLit (CmmInt i _)) _) = mkIntLit i32 i
+ extractLit _other = trace ("WARNING: Non constant alignment value given" ++
+ " for memcpy! Please report to GHC developers")
+ mkIntLit i32 0
+
+genCall env (CmmPrim _ (Just stmts)) _ _ _
+ = stmtsToInstrs env stmts (nilOL, [])
-- Handle all other foreign calls and prim ops.
genCall env target res args ret = do
@@ -240,7 +256,7 @@ genCall env target res args ret = do
-- extract Cmm call convention
let cconv = case target of
CmmCallee _ conv -> conv
- CmmPrim _ -> PrimCallConv
+ CmmPrim _ _ -> PrimCallConv
-- translate to LLVM call convention
let lmconv = case cconv of
@@ -337,7 +353,7 @@ getFunPtr env funTy targ = case targ of
(v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
return (env', v2, stmts `snocOL` s1, top)
- CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop
+ CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop
where
litCase name = do
@@ -469,17 +485,21 @@ cmmPrimOpFunctions env mop
(MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w)
- MO_WriteBarrier ->
- panic $ "cmmPrimOpFunctions: MO_WriteBarrier not supported here"
- MO_Touch ->
- panic $ "cmmPrimOpFunctions: MO_Touch not supported here"
+ MO_S_QuotRem {} -> unsupported
+ MO_U_QuotRem {} -> unsupported
+ MO_U_QuotRem2 {} -> unsupported
+ MO_Add2 {} -> unsupported
+ MO_U_Mul2 {} -> unsupported
+ MO_WriteBarrier -> unsupported
+ MO_Touch -> unsupported
where
intrinTy1 = (if getLlvmVer env >= 28
then "p0i8.p0i8." else "") ++ show llvmWord
intrinTy2 = (if getLlvmVer env >= 28
then "p0i8." else "") ++ show llvmWord
-
+ unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
+ ++ " not supported here")
-- | Tail function calls
genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData
@@ -627,7 +647,7 @@ genStore_slow env addr val meta = do
other ->
pprPanic "genStore: ptr not right type!"
- (PprCmm.pprExpr (getLlvmPlatform env) addr <+> text (
+ (PprCmm.pprExpr addr <+> text (
"Size of Ptr: " ++ show llvmPtrBits ++
", Size of var: " ++ show (llvmWidthInBits other) ++
", Var: " ++ show vaddr))
@@ -942,7 +962,10 @@ genMachOp_slow env opt op [x, y] = case op of
else do
-- Error. Continue anyway so we can debug the generated ll file.
- let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr (getLlvmPlatform env))
+ let dflags = getDflags env
+ style = mkCodeStyle CStyle
+ toString doc = renderWithStyle dflags doc style
+ cmmToStr = (lines . toString . PprCmm.pprExpr)
let dx = Comment $ map fsLit $ cmmToStr x
let dy = Comment $ map fsLit $ cmmToStr y
(v1, s1) <- doExpr (ty vx) $ binOp vx vy
@@ -1101,7 +1124,7 @@ genLoad_slow env e ty meta = do
return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
- (PprCmm.pprExpr (getLlvmPlatform env) e <+> text (
+ (PprCmm.pprExpr e <+> text (
"Size of Ptr: " ++ show llvmPtrBits ++
", Size of var: " ++ show (llvmWidthInBits other) ++
", Var: " ++ show iptr))
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 187d1ecf03..1c715989a8 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -17,8 +17,7 @@ import CLabel
import OldCmm
import FastString
-import qualified Outputable
-import Pretty
+import Outputable
import Unique
@@ -27,7 +26,7 @@ import Unique
--
-- | Header code for LLVM modules
-pprLlvmHeader :: Doc
+pprLlvmHeader :: SDoc
pprLlvmHeader =
moduleLayout
$+$ text ""
@@ -37,7 +36,7 @@ pprLlvmHeader =
-- | LLVM module layout description for the host target
-moduleLayout :: Doc
+moduleLayout :: SDoc
moduleLayout =
#if i386_TARGET_ARCH
@@ -76,7 +75,7 @@ moduleLayout =
-- | Pretty print LLVM data code
-pprLlvmData :: LlvmData -> Doc
+pprLlvmData :: LlvmData -> SDoc
pprLlvmData (globals, types) =
let tryConst (v, Just s ) = ppLlvmGlobal (v, Just s)
tryConst g@(_, Nothing) = ppLlvmGlobal g
@@ -91,7 +90,7 @@ pprLlvmData (globals, types) =
-- | Pretty print LLVM code
-pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (Doc, [LlvmVar])
+pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar])
pprLlvmCmmDecl _ _ (CmmData _ lmdata)
= (vcat $ map pprLlvmData lmdata, [])
@@ -116,7 +115,7 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks))
-- | Pretty print CmmStatic
-pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar])
+pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar])
pprInfoTable env count info_lbl stat
= let unres = genLlvmData env (Text, stat)
(_, (ldata, ltypes)) = resolveLlvmData env unres
View Lorry Controller Status