Commit 99d39221 authored by Peter Wortmann's avatar Peter Wortmann Committed by dterei

Use SDoc for all LLVM pretty-printing

This patch reworks some parts of the LLVM pretty-printing code that were
still using Show and String. Now we should be using SDoc and Outputable
throughout. Note that many get*Name functions become pp*Name
here as a side-effect.
parent 12148d91
......@@ -41,11 +41,12 @@ module Llvm (
MetaExpr(..), MetaAnnot(..), MetaDecl(..),
-- ** Operations on the type system.
isGlobal, getLitType, getLit, getName, getPlainName, getVarType,
isGlobal, getLitType, getVarType,
getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower,
pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
-- * Pretty Printing
ppLit, ppName, ppPlainName,
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
......
......@@ -52,11 +52,10 @@
--
module Llvm.MetaData where
import Data.List (intercalate)
import Llvm.Types
import FastString
import Outputable
-- | LLVM metadata expressions
data MetaExpr = MetaStr LMString
......@@ -65,11 +64,11 @@ data MetaExpr = MetaStr LMString
| MetaStruct [MetaExpr]
deriving (Eq)
instance Show MetaExpr where
show (MetaStr s ) = "metadata !\"" ++ unpackFS s ++ "\""
show (MetaNode n ) = "metadata !" ++ show n
show (MetaVar v ) = show v
show (MetaStruct es) = "metadata !{ " ++ intercalate ", " (map show es) ++ "}"
instance Outputable MetaExpr where
ppr (MetaStr s ) = text "metadata !\"" <> ftext s <> char '"'
ppr (MetaNode n ) = text "metadata !" <> int n
ppr (MetaVar v ) = ppr v
ppr (MetaStruct es) = text "metadata !{ " <> ppCommaJoin es <> char '}'
-- | Associates some metadata with a specific label for attaching to an
-- instruction.
......
......@@ -30,6 +30,7 @@ import Llvm.Types
import Data.List ( intersperse )
import Outputable
import Unique
import FastString ( sLit )
--------------------------------------------------------------------------------
-- * Top Level Print functions
......@@ -70,15 +71,17 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
Nothing -> empty
rhs = case dat of
Just stat -> texts stat
Nothing -> texts (pLower $ getVarType var)
Just stat -> ppr stat
Nothing -> ppr (pLower $ getVarType var)
const' = if c then text "constant" else text "global"
in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align
in ppAssignment var $ ppr link <+> const' <+> rhs <> sect <> align
$+$ newLine
ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
ppLlvmGlobal (var, val) = sdocWithDynFlags $ \dflags ->
error $ "Non Global var ppr as global! "
++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val)
-- | Print out a list of LLVM type aliases.
......@@ -88,7 +91,7 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
-- | Print out an LLVM type alias.
ppLlvmAlias :: LlvmAlias -> SDoc
ppLlvmAlias (name, ty)
= text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
= char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty
-- | Print out a list of LLVM metadata.
......@@ -110,7 +113,7 @@ ppLlvmMeta (MetaNamed n m)
ppLlvmMetaExpr :: MetaExpr -> SDoc
ppLlvmMetaExpr (MetaStr s ) = text "metadata !" <> doubleQuotes (ftext s)
ppLlvmMetaExpr (MetaNode n ) = text "metadata !" <> int n
ppLlvmMetaExpr (MetaVar v ) = texts v
ppLlvmMetaExpr (MetaVar v ) = ppr v
ppLlvmMetaExpr (MetaStruct es) =
text "metadata !{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}'
......@@ -138,17 +141,17 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) =
ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
= let varg' = case varg of
VarArgs | null p -> text "..."
| otherwise -> text ", ..."
_otherwise -> empty
VarArgs | null p -> sLit "..."
| otherwise -> sLit ", ..."
_otherwise -> sLit ""
align = case a of
Just a' -> text " align" <+> texts a'
Just a' -> text " align " <> ppr a'
Nothing -> empty
args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%"
args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'
<> ftext n)
(zip p args)
in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <>
(hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align
in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>
(hsep $ punctuate comma args') <> ptext varg' <> rparen <> align
-- | Print out a list of function declaration.
ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
......@@ -160,16 +163,16 @@ ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
= let varg' = case varg of
VarArgs | null p -> text "..."
| otherwise -> text ", ..."
_otherwise -> empty
VarArgs | null p -> sLit "..."
| otherwise -> sLit ", ..."
_otherwise -> sLit ""
align = case a of
Just a' -> text " align" <+> texts a'
Just a' -> text " align" <+> ppr a'
Nothing -> empty
args = hcat $ intersperse (comma <> space) $
map (\(t,a) -> texts t <+> ppSpaceJoin a) p
in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <>
ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine
map (\(t,a) -> ppr t <+> ppSpaceJoin a) p
in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>
ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine
-- | Print out a list of LLVM blocks.
......@@ -227,7 +230,7 @@ ppLlvmExpression expr
= case expr of
Alloca tp amount -> ppAlloca tp amount
LlvmOp op left right -> ppMachOp op left right
Call tp fp args attrs -> ppCall tp fp args attrs
Call tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs
CallM tp fp args attrs -> ppCall tp fp args attrs
Cast op from to -> ppCast op from to
Compare op left right -> ppCmpOp op left right
......@@ -247,7 +250,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 :: (Show a) => LlvmCallType -> LlvmVar -> [a] -> [LlvmFuncAttr] -> SDoc
ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall ct fptr args attrs = case fptr of
--
-- if local var function pointer, unwrap
......@@ -265,22 +268,21 @@ ppCall ct fptr args attrs = case fptr of
ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
let tc = if ct == TailCall then text "tail " else empty
ppValues = ppCommaJoin args
ppParams = map (texts . fst) params
ppArgTy = (hcat $ intersperse comma ppParams) <>
ppArgTy = (ppCommaJoin $ map fst params) <>
(case argTy of
VarArgs -> text ", ..."
FixedArgs -> empty)
fnty = space <> lparen <> ppArgTy <> rparen <> text "*"
fnty = space <> lparen <> ppArgTy <> rparen <> char '*'
attrDoc = ppSpaceJoin attrs
in tc <> text "call" <+> texts cc <+> texts ret
<> fnty <+> (text $ getName fptr) <> lparen <+> ppValues
in tc <> text "call" <+> ppr cc <+> ppr ret
<> fnty <+> ppName fptr <> lparen <+> ppValues
<+> rparen <+> attrDoc
ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp op left right =
(texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
<> comma <+> (text $ getName right)
(ppr op) <+> (ppr (getVarType left)) <+> ppName left
<> comma <+> ppName right
ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
......@@ -294,12 +296,12 @@ ppCmpOp op left right =
++ (show $ getVarType left) ++ ", right = "
++ (show $ getVarType right))
-}
in cmpOp <+> texts op <+> texts (getVarType left)
<+> (text $ getName left) <> comma <+> (text $ getName right)
in cmpOp <+> ppr op <+> ppr (getVarType left)
<+> ppName left <> comma <+> ppName right
ppAssignment :: LlvmVar -> SDoc -> SDoc
ppAssignment var expr = (text $ getName var) <+> equals <+> expr
ppAssignment var expr = ppName var <+> equals <+> expr
ppFence :: Bool -> LlvmSyncOrdering -> SDoc
ppFence st ord =
......@@ -325,72 +327,71 @@ ppSyncOrdering SyncSeqCst = text "seq_cst"
ppLoad :: LlvmVar -> SDoc
ppLoad var
| isVecPtrVar var = text "load" <+> texts var <>
| isVecPtrVar var = text "load" <+> ppr var <>
comma <+> text "align 1"
| otherwise = text "load" <+> texts var
| otherwise = text "load" <+> ppr var
where
isVecPtrVar :: LlvmVar -> Bool
isVecPtrVar = isVector . pLower . getVarType
ppStore :: LlvmVar -> LlvmVar -> SDoc
ppStore val dst
| isVecPtrVar dst = text "store" <+> texts val <> comma <+> texts dst <>
| isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <>
comma <+> text "align 1"
| otherwise = text "store" <+> texts val <> comma <+> texts dst
| otherwise = text "store" <+> ppr val <> comma <+> ppr dst
where
isVecPtrVar :: LlvmVar -> Bool
isVecPtrVar = isVector . pLower . getVarType
ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
ppCast op from to = ppr op <+> ppr from <+> text "to" <+> ppr to
ppMalloc :: LlvmType -> Int -> SDoc
ppMalloc tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "malloc" <+> texts tp <> comma <+> texts amount'
in text "malloc" <+> ppr tp <> comma <+> ppr amount'
ppAlloca :: LlvmType -> Int -> SDoc
ppAlloca tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "alloca" <+> texts tp <> comma <+> texts amount'
in text "alloca" <+> ppr tp <> comma <+> ppr amount'
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
in text "getelementptr" <+> inbound <+> ppr ptr <> indexes
ppReturn :: Maybe LlvmVar -> SDoc
ppReturn (Just var) = text "ret" <+> texts var
ppReturn Nothing = text "ret" <+> texts LMVoid
ppReturn (Just var) = text "ret" <+> ppr var
ppReturn Nothing = text "ret" <+> ppr LMVoid
ppBranch :: LlvmVar -> SDoc
ppBranch var = text "br" <+> texts var
ppBranch var = text "br" <+> ppr var
ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf cond trueT falseT
= text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
= text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT
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)
let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label
in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)
ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
ppSwitch scrut dflt targets =
let ppTarget (val, lab) = texts val <> comma <+> texts lab
let ppTarget (val, lab) = ppr val <> comma <+> ppr lab
ppTargets xs = brackets $ vcat (map ppTarget xs)
in text "switch" <+> texts scrut <> comma <+> texts dflt
in text "switch" <+> ppr scrut <> comma <+> ppr dflt
<+> ppTargets targets
......@@ -398,7 +399,7 @@ ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
ppAsm asm constraints rty vars sideeffect alignstack =
let asm' = doubleQuotes $ ftext asm
cons = doubleQuotes $ ftext constraints
rty' = texts rty
rty' = ppr rty
vars' = lparen <+> ppCommaJoin vars <+> rparen
side = if sideeffect then text "sideeffect" else empty
align = if alignstack then text "alignstack" else empty
......@@ -408,15 +409,15 @@ ppAsm asm constraints rty vars sideeffect alignstack =
ppExtract :: LlvmVar -> LlvmVar -> SDoc
ppExtract vec idx =
text "extractelement"
<+> texts (getVarType vec) <+> text (getName vec) <> comma
<+> texts idx
<+> ppr (getVarType vec) <+> ppName vec <> comma
<+> ppr idx
ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert vec elt idx =
text "insertelement"
<+> texts (getVarType vec) <+> text (getName vec) <> comma
<+> texts (getVarType elt) <+> text (getName elt) <> comma
<+> texts idx
<+> ppr (getVarType vec) <+> ppName vec <> comma
<+> ppr (getVarType elt) <+> ppName elt <> comma
<+> ppr idx
ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc
......@@ -433,27 +434,17 @@ ppMetaAnnots meta = hcat $ map ppMeta meta
case e of
MetaNode n -> exclamation <> int n
MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)
other -> exclamation <> braces (texts other) -- possible?
other -> exclamation <> braces (ppr other) -- possible?
--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------
ppCommaJoin :: (Show a) => [a] -> SDoc
ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs)
ppSpaceJoin :: (Show a) => [a] -> SDoc
ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
-- | Showable to SDoc
texts :: (Show a) => a -> SDoc
texts = (text . show)
-- | Blank line.
newLine :: SDoc
newLine = text ""
newLine = empty
-- | Exclamation point.
exclamation :: SDoc
exclamation = text "!"
exclamation = char '!'
This diff is collapsed.
......@@ -115,7 +115,7 @@ mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSectio
mkLlvmFunc env live lbl link sec blks
= let dflags = getDflags env
funDec = llvmFunSig env live lbl link
funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags live)
funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live)
in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
-- | Alignment to use for functions
......
......@@ -404,7 +404,7 @@ getFunPtr env funTy targ = case targ of
ty | isInt ty -> LM_Inttoptr
ty -> panic $ "genCall: Expr is of bad type for function"
++ " call! (" ++ show (ty) ++ ")"
++ " call! (" ++ showSDoc (getDflags env) (ppr ty) ++ ")"
(v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
return (env', v2, stmts `snocOL` s1, top)
......@@ -455,7 +455,7 @@ arg_vars env ((e, AddrHint):rest) (vars, stmts, tops)
ty | isInt ty -> LM_Inttoptr
a -> panic $ "genCall: Can't cast llvmType to i8*! ("
++ show a ++ ")"
++ showSDoc (getDflags env) (ppr a) ++ ")"
(v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
......@@ -495,7 +495,7 @@ castVar dflags v t
(vt, _) | isVector vt && isVector t -> LM_Bitcast
(vt, _) -> panic $ "castVars: Can't cast this type ("
++ show vt ++ ") to (" ++ show t ++ ")"
++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
in doExpr t $ Cast op v t
......@@ -541,7 +541,7 @@ 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_Prefetch_Data -> fsLit "llvm.prefetch"
......@@ -557,9 +557,9 @@ cmmPrimOpFunctions env mop
where
dflags = getDflags env
intrinTy1 = (if getLlvmVer env >= 28
then "p0i8.p0i8." else "") ++ show (llvmWord dflags)
then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags)
intrinTy2 = (if getLlvmVer env >= 28
then "p0i8." else "") ++ show (llvmWord dflags)
then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags)
unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
++ " not supported here")
......@@ -585,7 +585,7 @@ genJump env expr live = do
ty | isInt ty -> LM_Inttoptr
ty -> panic $ "genJump: Expr is of bad type for function call! ("
++ show (ty) ++ ")"
++ showSDoc (getDflags env) (ppr ty) ++ ")"
(v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
(stgRegs, stgStmts) <- funEpilogue env live
......@@ -719,7 +719,7 @@ genStore_slow env addr val meta = do
(PprCmm.pprExpr addr <+> text (
"Size of Ptr: " ++ show (llvmPtrBits dflags) ++
", Size of var: " ++ show (llvmWidthInBits dflags other) ++
", Var: " ++ show vaddr))
", Var: " ++ showSDoc dflags (ppr vaddr)))
where dflags = getDflags env
......@@ -741,8 +741,9 @@ genCondBranch env cond idT idF = do
then do
let s1 = BranchIf vc labelT labelF
return $ (env', stmts `snocOL` s1, top)
else
panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
else do
let dflags = getDflags env
panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
{- Note [Literals and branch conditions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1226,7 +1227,7 @@ genMachOp_slow env opt op [x, y] = case op of
return (env', 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)
......@@ -1263,7 +1264,7 @@ genMachOp_slow env opt op [x, y] = case op of
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 ++ ")"
......@@ -1359,7 +1360,7 @@ genLoad_slow env e ty meta = do
(PprCmm.pprExpr e <+> text (
"Size of Ptr: " ++ show (llvmPtrBits dflags) ++
", Size of var: " ++ show (llvmWidthInBits dflags other) ++
", Var: " ++ show iptr))
", Var: " ++ showSDoc dflags (ppr iptr)))
where dflags = getDflags env
-- | Handle CmmReg expression
......
......@@ -90,6 +90,7 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Char
import qualified Data.Map as M
import Data.Int
import qualified Data.IntMap as IM
import Data.Set (Set)
import qualified Data.Set as Set
......@@ -619,6 +620,12 @@ instance Outputable Bool where
ppr True = ptext (sLit "True")
ppr False = ptext (sLit "False")
instance Outputable Int32 where
ppr n = integer $ fromIntegral n
instance Outputable Int64 where
ppr n = integer $ fromIntegral n
instance Outputable Int where
ppr n = int n
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment