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