Iteration on dterei's metadata design
[ghc.git] / compiler / llvmGen / Llvm / PpLlvm.hs
1 --------------------------------------------------------------------------------
2 -- | Pretty print LLVM IR Code.
3 --
4
5 module Llvm.PpLlvm (
6
7 -- * Top level LLVM objects.
8 ppLlvmModule,
9 ppLlvmComments,
10 ppLlvmComment,
11 ppLlvmGlobals,
12 ppLlvmGlobal,
13 ppLlvmAliases,
14 ppLlvmAlias,
15 ppLlvmMetas,
16 ppLlvmMeta,
17 ppLlvmFunctionDecls,
18 ppLlvmFunctionDecl,
19 ppLlvmFunctions,
20 ppLlvmFunction,
21
22 ) where
23
24 #include "HsVersions.h"
25
26 import Llvm.AbsSyn
27 import Llvm.MetaData
28 import Llvm.Types
29
30 import Data.List ( intersperse )
31 import Outputable
32 import Unique
33
34 --------------------------------------------------------------------------------
35 -- * Top Level Print functions
36 --------------------------------------------------------------------------------
37
38 -- | Print out a whole LLVM module.
39 ppLlvmModule :: LlvmModule -> SDoc
40 ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
41 = ppLlvmComments comments $+$ newLine
42 $+$ ppLlvmAliases aliases $+$ newLine
43 $+$ ppLlvmMetas meta $+$ newLine
44 $+$ ppLlvmGlobals globals $+$ newLine
45 $+$ ppLlvmFunctionDecls decls $+$ newLine
46 $+$ ppLlvmFunctions funcs
47
48 -- | Print out a multi-line comment, can be inside a function or on its own
49 ppLlvmComments :: [LMString] -> SDoc
50 ppLlvmComments comments = vcat $ map ppLlvmComment comments
51
52 -- | Print out a comment, can be inside a function or on its own
53 ppLlvmComment :: LMString -> SDoc
54 ppLlvmComment com = semi <+> ftext com
55
56
57 -- | Print out a list of global mutable variable definitions
58 ppLlvmGlobals :: [LMGlobal] -> SDoc
59 ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
60
61 -- | Print out a global mutable variable definition
62 ppLlvmGlobal :: LMGlobal -> SDoc
63 ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
64 let sect = case x of
65 Just x' -> text ", section" <+> doubleQuotes (ftext x')
66 Nothing -> empty
67
68 align = case a of
69 Just a' -> text ", align" <+> int a'
70 Nothing -> empty
71
72 rhs = case dat of
73 Just stat -> texts stat
74 Nothing -> texts (pLower $ getVarType var)
75
76 const' = if c then text "constant" else text "global"
77
78 in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align
79 $+$ newLine
80
81 ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
82
83
84 -- | Print out a list of LLVM type aliases.
85 ppLlvmAliases :: [LlvmAlias] -> SDoc
86 ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
87
88 -- | Print out an LLVM type alias.
89 ppLlvmAlias :: LlvmAlias -> SDoc
90 ppLlvmAlias (name, ty)
91 = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
92
93
94 -- | Print out a list of LLVM metadata.
95 ppLlvmMetas :: [MetaDecl] -> SDoc
96 ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
97
98 -- | Print out an LLVM metadata definition.
99 ppLlvmMeta :: MetaDecl -> SDoc
100 ppLlvmMeta (MetaUnamed n m)
101 = exclamation <> int n <> text " = metadata !" <> braces (ppLlvmMetaExpr m)
102
103 ppLlvmMeta (MetaNamed n m)
104 = exclamation <> ftext n <> text " = !" <> braces nodes
105 where
106 nodes = hcat $ intersperse comma $ map pprNode m
107 pprNode n = exclamation <> int n
108
109 -- | Print out an LLVM metadata value.
110 ppLlvmMetaExpr :: MetaExpr -> SDoc
111 ppLlvmMetaExpr (MetaStr s ) = text "metadata !" <> doubleQuotes (ftext s)
112 ppLlvmMetaExpr (MetaNode n ) = text "metadata !" <> int n
113 ppLlvmMetaExpr (MetaVar v ) = texts v
114 ppLlvmMetaExpr (MetaStruct es) =
115 text "metadata !{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}'
116
117
118 -- | Print out a list of function definitions.
119 ppLlvmFunctions :: LlvmFunctions -> SDoc
120 ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
121
122 -- | Print out a function definition.
123 ppLlvmFunction :: LlvmFunction -> SDoc
124 ppLlvmFunction (LlvmFunction dec args attrs sec body) =
125 let attrDoc = ppSpaceJoin attrs
126 secDoc = case sec of
127 Just s' -> text "section" <+> (doubleQuotes $ ftext s')
128 Nothing -> empty
129 in text "define" <+> ppLlvmFunctionHeader dec args
130 <+> attrDoc <+> secDoc
131 $+$ lbrace
132 $+$ ppLlvmBlocks body
133 $+$ rbrace
134 $+$ newLine
135 $+$ newLine
136
137 -- | Print out a function defenition header.
138 ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
139 ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
140 = let varg' = case varg of
141 VarArgs | null p -> text "..."
142 | otherwise -> text ", ..."
143 _otherwise -> empty
144 align = case a of
145 Just a' -> text " align" <+> texts a'
146 Nothing -> empty
147 args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%"
148 <> ftext n)
149 (zip p args)
150 in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <>
151 (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align
152
153 -- | Print out a list of function declaration.
154 ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
155 ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
156
157 -- | Print out a function declaration.
158 -- Declarations define the function type but don't define the actual body of
159 -- the function.
160 ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
161 ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
162 = let varg' = case varg of
163 VarArgs | null p -> text "..."
164 | otherwise -> text ", ..."
165 _otherwise -> empty
166 align = case a of
167 Just a' -> text " align" <+> texts a'
168 Nothing -> empty
169 args = hcat $ intersperse (comma <> space) $
170 map (\(t,a) -> texts t <+> ppSpaceJoin a) p
171 in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <>
172 ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine
173
174
175 -- | Print out a list of LLVM blocks.
176 ppLlvmBlocks :: LlvmBlocks -> SDoc
177 ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
178
179 -- | Print out an LLVM block.
180 -- It must be part of a function definition.
181 ppLlvmBlock :: LlvmBlock -> SDoc
182 ppLlvmBlock (LlvmBlock blockId stmts)
183 = go blockId stmts
184 where
185 lbreak acc [] = (Nothing, reverse acc, [])
186 lbreak acc (MkLabel id:xs) = (Just id, reverse acc, xs)
187 lbreak acc (x:xs) = lbreak (x:acc) xs
188
189 go id code =
190 let (id2, block, rest) = lbreak [] code
191 ppRest = case id2 of
192 Just id2' -> go id2' rest
193 Nothing -> empty
194 in ppLlvmBlockLabel id
195 $+$ (vcat $ map ppLlvmStatement block)
196 $+$ newLine
197 $+$ ppRest
198
199 -- | Print out an LLVM block label.
200 ppLlvmBlockLabel :: LlvmBlockId -> SDoc
201 ppLlvmBlockLabel id = pprUnique id <> colon
202
203
204 -- | Print out an LLVM statement.
205 ppLlvmStatement :: LlvmStatement -> SDoc
206 ppLlvmStatement stmt =
207 let ind = (text " " <>)
208 in case stmt of
209 Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr)
210 Fence st ord -> ind $ ppFence st ord
211 Branch target -> ind $ ppBranch target
212 BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF
213 Comment comments -> ind $ ppLlvmComments comments
214 MkLabel label -> ppLlvmBlockLabel label
215 Store value ptr -> ind $ ppStore value ptr
216 Switch scrut def tgs -> ind $ ppSwitch scrut def tgs
217 Return result -> ind $ ppReturn result
218 Expr expr -> ind $ ppLlvmExpression expr
219 Unreachable -> ind $ text "unreachable"
220 Nop -> empty
221 MetaStmt meta s -> ppMetaStatement meta s
222
223
224 -- | Print out an LLVM expression.
225 ppLlvmExpression :: LlvmExpression -> SDoc
226 ppLlvmExpression expr
227 = case expr of
228 Alloca tp amount -> ppAlloca tp amount
229 LlvmOp op left right -> ppMachOp op left right
230 Call tp fp args attrs -> ppCall tp fp args attrs
231 CallM tp fp args attrs -> ppCall tp fp args attrs
232 Cast op from to -> ppCast op from to
233 Compare op left right -> ppCmpOp op left right
234 Extract vec idx -> ppExtract vec idx
235 Insert vec elt idx -> ppInsert vec elt idx
236 GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes
237 Load ptr -> ppLoad ptr
238 Malloc tp amount -> ppMalloc tp amount
239 Phi tp precessors -> ppPhi tp precessors
240 Asm asm c ty v se sk -> ppAsm asm c ty v se sk
241 MExpr meta expr -> ppMetaExpr meta expr
242
243
244 --------------------------------------------------------------------------------
245 -- * Individual print functions
246 --------------------------------------------------------------------------------
247
248 -- | Should always be a function pointer. So a global var of function type
249 -- (since globals are always pointers) or a local var of pointer function type.
250 ppCall :: (Show a) => LlvmCallType -> LlvmVar -> [a] -> [LlvmFuncAttr] -> SDoc
251 ppCall ct fptr args attrs = case fptr of
252 --
253 -- if local var function pointer, unwrap
254 LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
255
256 -- should be function type otherwise
257 LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d
258
259 -- not pointer or function, so error
260 _other -> error $ "ppCall called with non LMFunction type!\nMust be "
261 ++ " called with either global var of function type or "
262 ++ "local var of pointer function type."
263
264 where
265 ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
266 let tc = if ct == TailCall then text "tail " else empty
267 ppValues = ppCommaJoin args
268 ppParams = map (texts . fst) params
269 ppArgTy = (hcat $ intersperse comma ppParams) <>
270 (case argTy of
271 VarArgs -> text ", ..."
272 FixedArgs -> empty)
273 fnty = space <> lparen <> ppArgTy <> rparen <> text "*"
274 attrDoc = ppSpaceJoin attrs
275 in tc <> text "call" <+> texts cc <+> texts ret
276 <> fnty <+> (text $ getName fptr) <> lparen <+> ppValues
277 <+> rparen <+> attrDoc
278
279
280 ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
281 ppMachOp op left right =
282 (texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
283 <> comma <+> (text $ getName right)
284
285
286 ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
287 ppCmpOp op left right =
288 let cmpOp
289 | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
290 | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
291 | otherwise = text "icmp" -- Just continue as its much easier to debug
292 {-
293 | otherwise = error ("can't compare different types, left = "
294 ++ (show $ getVarType left) ++ ", right = "
295 ++ (show $ getVarType right))
296 -}
297 in cmpOp <+> texts op <+> texts (getVarType left)
298 <+> (text $ getName left) <> comma <+> (text $ getName right)
299
300
301 ppAssignment :: LlvmVar -> SDoc -> SDoc
302 ppAssignment var expr = (text $ getName var) <+> equals <+> expr
303
304 ppFence :: Bool -> LlvmSyncOrdering -> SDoc
305 ppFence st ord =
306 let singleThread = case st of True -> text "singlethread"
307 False -> empty
308 in text "fence" <+> singleThread <+> ppSyncOrdering ord
309
310 ppSyncOrdering :: LlvmSyncOrdering -> SDoc
311 ppSyncOrdering SyncUnord = text "unordered"
312 ppSyncOrdering SyncMonotonic = text "monotonic"
313 ppSyncOrdering SyncAcquire = text "acquire"
314 ppSyncOrdering SyncRelease = text "release"
315 ppSyncOrdering SyncAcqRel = text "acq_rel"
316 ppSyncOrdering SyncSeqCst = text "seq_cst"
317
318 -- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
319 -- we have no way of guaranteeing that this is true with GHC (we would need to
320 -- modify the layout of the stack and closures, change the storage manager,
321 -- etc.). So, we blindly tell LLVM that *any* vector store or load could be
322 -- unaligned. In the future we may be able to guarantee that certain vector
323 -- access patterns are aligned, in which case we will need a more granular way
324 -- of specifying alignment.
325
326 ppLoad :: LlvmVar -> SDoc
327 ppLoad var
328 | isVecPtrVar var = text "load" <+> texts var <>
329 comma <+> text "align 1"
330 | otherwise = text "load" <+> texts var
331 where
332 isVecPtrVar :: LlvmVar -> Bool
333 isVecPtrVar = isVector . pLower . getVarType
334
335 ppStore :: LlvmVar -> LlvmVar -> SDoc
336 ppStore val dst
337 | isVecPtrVar dst = text "store" <+> texts val <> comma <+> texts dst <>
338 comma <+> text "align 1"
339 | otherwise = text "store" <+> texts val <> comma <+> texts dst
340 where
341 isVecPtrVar :: LlvmVar -> Bool
342 isVecPtrVar = isVector . pLower . getVarType
343
344
345 ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
346 ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
347
348
349 ppMalloc :: LlvmType -> Int -> SDoc
350 ppMalloc tp amount =
351 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
352 in text "malloc" <+> texts tp <> comma <+> texts amount'
353
354
355 ppAlloca :: LlvmType -> Int -> SDoc
356 ppAlloca tp amount =
357 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
358 in text "alloca" <+> texts tp <> comma <+> texts amount'
359
360
361 ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
362 ppGetElementPtr inb ptr idx =
363 let indexes = comma <+> ppCommaJoin idx
364 inbound = if inb then text "inbounds" else empty
365 in text "getelementptr" <+> inbound <+> texts ptr <> indexes
366
367
368 ppReturn :: Maybe LlvmVar -> SDoc
369 ppReturn (Just var) = text "ret" <+> texts var
370 ppReturn Nothing = text "ret" <+> texts LMVoid
371
372
373 ppBranch :: LlvmVar -> SDoc
374 ppBranch var = text "br" <+> texts var
375
376
377 ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
378 ppBranchIf cond trueT falseT
379 = text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
380
381
382 ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
383 ppPhi tp preds =
384 let ppPreds (val, label) = brackets $ (text $ getName val) <> comma
385 <+> (text $ getName label)
386 in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds)
387
388
389 ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
390 ppSwitch scrut dflt targets =
391 let ppTarget (val, lab) = texts val <> comma <+> texts lab
392 ppTargets xs = brackets $ vcat (map ppTarget xs)
393 in text "switch" <+> texts scrut <> comma <+> texts dflt
394 <+> ppTargets targets
395
396
397 ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
398 ppAsm asm constraints rty vars sideeffect alignstack =
399 let asm' = doubleQuotes $ ftext asm
400 cons = doubleQuotes $ ftext constraints
401 rty' = texts rty
402 vars' = lparen <+> ppCommaJoin vars <+> rparen
403 side = if sideeffect then text "sideeffect" else empty
404 align = if alignstack then text "alignstack" else empty
405 in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
406 <+> cons <> vars'
407
408 ppExtract :: LlvmVar -> LlvmVar -> SDoc
409 ppExtract vec idx =
410 text "extractelement"
411 <+> texts (getVarType vec) <+> text (getName vec) <> comma
412 <+> texts idx
413
414 ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
415 ppInsert vec elt idx =
416 text "insertelement"
417 <+> texts (getVarType vec) <+> text (getName vec) <> comma
418 <+> texts (getVarType elt) <+> text (getName elt) <> comma
419 <+> texts idx
420
421
422 ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc
423 ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta
424
425 ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc
426 ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta
427
428 ppMetaAnnots :: [MetaAnnot] -> SDoc
429 ppMetaAnnots meta = hcat $ map ppMeta meta
430 where
431 ppMeta (MetaAnnot name e)
432 = comma <+> exclamation <> ftext name <+>
433 case e of
434 MetaNode n -> exclamation <> int n
435 MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)
436 other -> exclamation <> braces (texts other) -- possible?
437
438
439 --------------------------------------------------------------------------------
440 -- * Misc functions
441 --------------------------------------------------------------------------------
442 ppCommaJoin :: (Show a) => [a] -> SDoc
443 ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs)
444
445 ppSpaceJoin :: (Show a) => [a] -> SDoc
446 ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
447
448 -- | Showable to SDoc
449 texts :: (Show a) => a -> SDoc
450 texts = (text . show)
451
452 -- | Blank line.
453 newLine :: SDoc
454 newLine = text ""
455
456 -- | Exclamation point.
457 exclamation :: SDoc
458 exclamation = text "!"
459