1 --------------------------------------------------------------------------------
2 -- | Pretty print LLVM IR Code.
7 -- * Top level LLVM objects.
22 -- * Utility functions
27 #include "HsVersions.h"
32 import Data.List ( intersperse )
34 import qualified Outputable as Out
37 --------------------------------------------------------------------------------
38 -- * Top Level Print functions
39 --------------------------------------------------------------------------------
41 -- | Print out a whole LLVM module.
42 ppLlvmModule :: LlvmModule -> Doc
43 ppLlvmModule (LlvmModule comments constants globals decls funcs)
44 = ppLlvmComments comments
46 $+$ ppLlvmConstants constants
47 $+$ ppLlvmGlobals globals
49 $+$ ppLlvmFunctionDecls decls
51 $+$ ppLlvmFunctions funcs
53 -- | Print out a multi-line comment, can be inside a function or on its own
54 ppLlvmComments :: [LMString] -> Doc
55 ppLlvmComments comments = vcat $ map ppLlvmComment comments
57 -- | Print out a comment, can be inside a function or on its own
58 ppLlvmComment :: LMString -> Doc
59 ppLlvmComment com = semi <+> ftext com
62 -- | Print out a list of global mutable variable definitions
63 ppLlvmGlobals :: [LMGlobal] -> Doc
64 ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
66 -- | Print out a global mutable variable definition
67 ppLlvmGlobal :: LMGlobal -> Doc
68 ppLlvmGlobal = ppLlvmGlobal' (text "global")
70 ppLlvmGlobal' :: Doc -> LMGlobal -> Doc
71 ppLlvmGlobal' vty (var@(LMGlobalVar _ _ link x a), cont) =
73 Just x' -> text ", section" <+> doubleQuotes (ftext x')
77 Just a' -> text ", align" <+> int a'
81 Just stat -> texts stat
82 Nothing -> texts (pLower $ getVarType var)
84 in ppAssignment var $ texts link <+> vty <+> rhs <> sect <> align
86 ppLlvmGlobal' _ oth = error $ "Non Global var ppr as global! " ++ show oth
89 -- | Print out a list global constant variable
90 ppLlvmConstants :: [LMConstant] -> Doc
91 ppLlvmConstants cons = vcat $ map ppLlvmConstant cons
93 -- | Print out a global constant variable
94 ppLlvmConstant :: LMConstant -> Doc
95 ppLlvmConstant (v,s) = ppLlvmGlobal' (text "constant") (v, Just s)
98 -- | Print out a list of LLVM type aliases.
99 ppLlvmTypes :: [LlvmType] -> Doc
100 ppLlvmTypes tys = vcat $ map ppLlvmType tys
102 -- | Print out an LLVM type alias.
103 ppLlvmType :: LlvmType -> Doc
105 ppLlvmType al@(LMAlias _ t)
106 = texts al <+> equals <+> text "type" <+> texts t
108 ppLlvmType (LMFunction t)
109 = ppLlvmFunctionDecl t
114 -- | Print out a list of function definitions.
115 ppLlvmFunctions :: LlvmFunctions -> Doc
116 ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
118 -- | Print out a function definition.
119 ppLlvmFunction :: LlvmFunction -> Doc
120 ppLlvmFunction (LlvmFunction dec attrs sec body) =
121 let attrDoc = ppSpaceJoin attrs
123 Just s' -> text "section " <+> (doubleQuotes $ ftext s')
125 in text "define" <+> texts dec
126 <+> attrDoc <+> secDoc
128 $+$ ppLlvmBlocks body
132 -- | Print out a list of function declaration.
133 ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
134 ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
136 -- | Print out a function declaration.
137 -- Declarations define the function type but don't define the actual body of
139 ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
140 ppLlvmFunctionDecl dec = text "declare" <+> texts dec
143 -- | Print out a list of LLVM blocks.
144 ppLlvmBlocks :: LlvmBlocks -> Doc
145 ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
147 -- | Print out an LLVM block.
148 -- It must be part of a function definition.
149 ppLlvmBlock :: LlvmBlock -> Doc
150 ppLlvmBlock (LlvmBlock blockId stmts)
151 = ppLlvmStatement (MkLabel blockId)
152 $+$ nest 4 (vcat $ map ppLlvmStatement stmts)
155 -- | Print out an LLVM statement.
156 ppLlvmStatement :: LlvmStatement -> Doc
159 Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr)
160 Branch target -> ppBranch target
161 BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF
162 Comment comments -> ppLlvmComments comments
163 MkLabel label -> (llvmSDoc $ pprUnique label) <> colon
164 Store value ptr -> ppStore value ptr
165 Switch scrut def tgs -> ppSwitch scrut def tgs
166 Return result -> ppReturn result
167 Expr expr -> ppLlvmExpression expr
168 Unreachable -> text "unreachable"
171 -- | Print out an LLVM expression.
172 ppLlvmExpression :: LlvmExpression -> Doc
173 ppLlvmExpression expr
175 Alloca tp amount -> ppAlloca tp amount
176 LlvmOp op left right -> ppMachOp op left right
177 Call tp fp args attrs -> ppCall tp fp args attrs
178 Cast op from to -> ppCast op from to
179 Compare op left right -> ppCmpOp op left right
180 GetElemPtr ptr indexes -> ppGetElementPtr ptr indexes
181 Load ptr -> ppLoad ptr
182 Malloc tp amount -> ppMalloc tp amount
183 Phi tp precessors -> ppPhi tp precessors
186 --------------------------------------------------------------------------------
187 -- * Individual print functions
188 --------------------------------------------------------------------------------
190 -- | Should always be a function pointer. So a global var of function type
191 -- (since globals are always pointers) or a local var of pointer function type.
192 ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> Doc
193 ppCall ct fptr vals attrs = case fptr of
195 -- if local var function pointer, unwrap
196 LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
198 -- should be function type otherwise
199 LMGlobalVar _ (LMFunction d) _ _ _ -> ppCall' d
201 -- not pointer or function, so error
202 _other -> error $ "ppCall called with non LMFunction type!\nMust be "
203 ++ " called with either global var of function type or "
204 ++ "local var of pointer function type."
207 ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
208 let tc = if ct == TailCall then text "tail " else empty
209 ppValues = ppCommaJoin vals
210 ppArgTy = either ppCommaJoin (\x -> ppCommaJoin $ map getVarType x) params <>
212 VarArgs -> text ", ..."
214 fnty = space <> lparen <> ppArgTy <> rparen <> text "*"
215 attrDoc = ppSpaceJoin attrs
216 in tc <> text "call" <+> texts cc <+> texts ret
217 <> fnty <+> (text $ getName fptr) <> lparen <+> ppValues
218 <+> rparen <+> attrDoc
221 ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> Doc
222 ppMachOp op left right =
223 (texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
224 <> comma <+> (text $ getName right)
227 ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc
228 ppCmpOp op left right =
230 | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
231 | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
232 | otherwise = error ("can't compare different types, left = "
233 ++ (show $ getVarType left) ++ ", right = "
234 ++ (show $ getVarType right))
235 in cmpOp <+> texts op <+> texts (getVarType left)
236 <+> (text $ getName left) <> comma <+> (text $ getName right)
239 ppAssignment :: LlvmVar -> Doc -> Doc
240 ppAssignment var expr = (text $ getName var) <+> equals <+> expr
243 ppLoad :: LlvmVar -> Doc
244 ppLoad var = text "load" <+> texts var
247 ppStore :: LlvmVar -> LlvmVar -> Doc
248 ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
251 ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
252 ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
255 ppMalloc :: LlvmType -> Int -> Doc
257 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
258 in text "malloc" <+> texts tp <> comma <+> texts amount'
261 ppAlloca :: LlvmType -> Int -> Doc
263 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
264 in text "alloca" <+> texts tp <> comma <+> texts amount'
267 ppGetElementPtr :: LlvmVar -> [Int] -> Doc
268 ppGetElementPtr ptr idx =
269 let indexes = hcat $ map ((comma <+> texts i32 <+>) . texts) idx
270 in text "getelementptr" <+> texts ptr <> indexes
273 ppReturn :: Maybe LlvmVar -> Doc
274 ppReturn (Just var) = text "ret" <+> texts var
275 ppReturn Nothing = text "ret" <+> texts LMVoid
278 ppBranch :: LlvmVar -> Doc
279 ppBranch var = text "br" <+> texts var
282 ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc
283 ppBranchIf cond trueT falseT
284 = text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
287 ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc
289 let ppPreds (val, label) = brackets $ (text $ getName val) <> comma
290 <+> (text $ getName label)
291 in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds)
294 ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> Doc
295 ppSwitch scrut dflt targets =
296 let ppTarget (val, lab) = texts val <> comma <+> texts lab
297 ppTargets xs = brackets $ vcat (map ppTarget xs)
298 in text "switch" <+> texts scrut <> comma <+> texts dflt
299 <+> ppTargets targets
302 --------------------------------------------------------------------------------
304 --------------------------------------------------------------------------------
305 ppCommaJoin :: (Show a) => [a] -> Doc
306 ppCommaJoin strs = hcat $ intersperse comma (map texts strs)
308 ppSpaceJoin :: (Show a) => [a] -> Doc
309 ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
311 -- | Convert SDoc to Doc
312 llvmSDoc :: Out.SDoc -> Doc
314 = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
317 texts :: (Show a) => a -> Doc
318 texts = (text . show)