Commit ffa6d17c authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Use SDoc rather than Doc in LLVM

In particular, this makes life simpler when we want to use a general
GHC SDoc in the middle of some LLVM.
parent f6fb322c
......@@ -49,7 +49,6 @@ module Llvm (
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
llvmSDoc
) where
......
......@@ -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 "!"
......@@ -48,9 +48,9 @@ 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
Prt.bufLeftRender bufh $ withPprStyleDoc (mkCodeStyle CStyle) pprLlvmHeader
ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
-- cache llvm version for later use
writeIORef (llvmVersion dflags) ver
......@@ -72,11 +72,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 (mkCodeStyle CStyle) lmdoc
return env'
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
......@@ -108,6 +108,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 (mkCodeStyle CStyle) $
pprLlvmData ([lmUsed], [])
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
......@@ -119,7 +120,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 (mkCodeStyle CStyle) $ vcat docs
cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
......@@ -139,7 +141,7 @@ cmmLlvmGen dflags us env cmm = do
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)
......@@ -226,7 +226,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
......
......@@ -950,7 +950,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 (getLlvmPlatform env))
let dx = Comment $ map fsLit $ cmmToStr x
let dy = Comment $ map fsLit $ cmmToStr y
(v1, s1) <- doExpr (ty vx) $ binOp vx vy
......
......@@ -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
......
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