never executed always true always false
1
2 {-# LANGUAGE LambdaCase #-}
3
4 --------------------------------------------------------------------------------
5 -- | Pretty print LLVM IR Code.
6 --
7
8 module GHC.Llvm.Ppr (
9
10 -- * Top level LLVM objects.
11 ppLlvmModule,
12 ppLlvmComments,
13 ppLlvmComment,
14 ppLlvmGlobals,
15 ppLlvmGlobal,
16 ppLlvmAliases,
17 ppLlvmAlias,
18 ppLlvmMetas,
19 ppLlvmMeta,
20 ppLlvmFunctionDecls,
21 ppLlvmFunctionDecl,
22 ppLlvmFunctions,
23 ppLlvmFunction,
24
25 ppVar,
26 ppLit,
27 ppTypeLit,
28 ppName,
29 ppPlainName
30
31 ) where
32
33 import GHC.Prelude
34
35 import GHC.Llvm.Syntax
36 import GHC.Llvm.MetaData
37 import GHC.Llvm.Types
38
39 import Data.Int
40 import Data.List ( intersperse )
41 import GHC.Utils.Outputable
42 import GHC.Utils.Panic
43 import GHC.Types.Unique
44
45 --------------------------------------------------------------------------------
46 -- * Top Level Print functions
47 --------------------------------------------------------------------------------
48
49 -- | Print out a whole LLVM module.
50 ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc
51 ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs)
52 = ppLlvmComments comments $+$ newLine
53 $+$ ppLlvmAliases aliases $+$ newLine
54 $+$ ppLlvmMetas opts meta $+$ newLine
55 $+$ ppLlvmGlobals opts globals $+$ newLine
56 $+$ ppLlvmFunctionDecls decls $+$ newLine
57 $+$ ppLlvmFunctions opts funcs
58
59 -- | Print out a multi-line comment, can be inside a function or on its own
60 ppLlvmComments :: [LMString] -> SDoc
61 ppLlvmComments comments = vcat $ map ppLlvmComment comments
62
63 -- | Print out a comment, can be inside a function or on its own
64 ppLlvmComment :: LMString -> SDoc
65 ppLlvmComment com = semi <+> ftext com
66
67
68 -- | Print out a list of global mutable variable definitions
69 ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc
70 ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls
71
72 -- | Print out a global mutable variable definition
73 ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc
74 ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
75 let sect = case x of
76 Just x' -> text ", section" <+> doubleQuotes (ftext x')
77 Nothing -> empty
78
79 align = case a of
80 Just a' -> text ", align" <+> int a'
81 Nothing -> empty
82
83 rhs = case dat of
84 Just stat -> pprSpecialStatic opts stat
85 Nothing -> ppr (pLower $ getVarType var)
86
87 -- Position of linkage is different for aliases.
88 const = case c of
89 Global -> "global"
90 Constant -> "constant"
91 Alias -> "alias"
92
93 in ppAssignment opts var $ ppr link <+> text const <+> rhs <> sect <> align
94 $+$ newLine
95
96 ppLlvmGlobal opts (LMGlobal var val) = pprPanic "ppLlvmGlobal" $
97 text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic opts) val)
98
99
100 -- | Print out a list of LLVM type aliases.
101 ppLlvmAliases :: [LlvmAlias] -> SDoc
102 ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
103
104 -- | Print out an LLVM type alias.
105 ppLlvmAlias :: LlvmAlias -> SDoc
106 ppLlvmAlias (name, ty)
107 = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty
108
109
110 -- | Print out a list of LLVM metadata.
111 ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc
112 ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas
113
114 -- | Print out an LLVM metadata definition.
115 ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc
116 ppLlvmMeta opts (MetaUnnamed n m)
117 = ppr n <+> equals <+> ppMetaExpr opts m
118
119 ppLlvmMeta _opts (MetaNamed n m)
120 = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes
121 where
122 nodes = hcat $ intersperse comma $ map ppr m
123
124
125 -- | Print out a list of function definitions.
126 ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc
127 ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs
128
129 -- | Print out a function definition.
130 ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc
131 ppLlvmFunction opts fun =
132 let attrDoc = ppSpaceJoin (funcAttrs fun)
133 secDoc = case funcSect fun of
134 Just s' -> text "section" <+> (doubleQuotes $ ftext s')
135 Nothing -> empty
136 prefixDoc = case funcPrefix fun of
137 Just v -> text "prefix" <+> ppStatic opts v
138 Nothing -> empty
139 in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
140 <+> attrDoc <+> secDoc <+> prefixDoc
141 $+$ lbrace
142 $+$ ppLlvmBlocks opts (funcBody fun)
143 $+$ rbrace
144 $+$ newLine
145 $+$ newLine
146
147 -- | Print out a function definition header.
148 ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
149 ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
150 = let varg' = case varg of
151 VarArgs | null p -> text "..."
152 | otherwise -> text ", ..."
153 _otherwise -> text ""
154 align = case a of
155 Just a' -> text " align " <> ppr a'
156 Nothing -> empty
157 args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'
158 <> ftext n)
159 (zip p args)
160 in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>
161 (hsep $ punctuate comma args') <> varg' <> rparen <> align
162
163 -- | Print out a list of function declaration.
164 ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
165 ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
166
167 -- | Print out a function declaration.
168 -- Declarations define the function type but don't define the actual body of
169 -- the function.
170 ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
171 ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
172 = let varg' = case varg of
173 VarArgs | null p -> text "..."
174 | otherwise -> text ", ..."
175 _otherwise -> text ""
176 align = case a of
177 Just a' -> text " align" <+> ppr a'
178 Nothing -> empty
179 args = hcat $ intersperse (comma <> space) $
180 map (\(t,a) -> ppr t <+> ppSpaceJoin a) p
181 in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>
182 ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine
183
184
185 -- | Print out a list of LLVM blocks.
186 ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc
187 ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks
188
189 -- | Print out an LLVM block.
190 -- It must be part of a function definition.
191 ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc
192 ppLlvmBlock opts (LlvmBlock blockId stmts) =
193 let isLabel (MkLabel _) = True
194 isLabel _ = False
195 (block, rest) = break isLabel stmts
196 ppRest = case rest of
197 MkLabel id:xs -> ppLlvmBlock opts (LlvmBlock id xs)
198 _ -> empty
199 in ppLlvmBlockLabel blockId
200 $+$ (vcat $ map (ppLlvmStatement opts) block)
201 $+$ newLine
202 $+$ ppRest
203
204 -- | Print out an LLVM block label.
205 ppLlvmBlockLabel :: LlvmBlockId -> SDoc
206 ppLlvmBlockLabel id = pprUniqueAlways id <> colon
207
208
209 -- | Print out an LLVM statement.
210 ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc
211 ppLlvmStatement opts stmt =
212 let ind = (text " " <>)
213 in case stmt of
214 Assignment dst expr -> ind $ ppAssignment opts dst (ppLlvmExpression opts expr)
215 Fence st ord -> ind $ ppFence st ord
216 Branch target -> ind $ ppBranch opts target
217 BranchIf cond ifT ifF -> ind $ ppBranchIf opts cond ifT ifF
218 Comment comments -> ind $ ppLlvmComments comments
219 MkLabel label -> ppLlvmBlockLabel label
220 Store value ptr -> ind $ ppStore opts value ptr
221 Switch scrut def tgs -> ind $ ppSwitch opts scrut def tgs
222 Return result -> ind $ ppReturn opts result
223 Expr expr -> ind $ ppLlvmExpression opts expr
224 Unreachable -> ind $ text "unreachable"
225 Nop -> empty
226 MetaStmt meta s -> ppMetaStatement opts meta s
227
228
229 -- | Print out an LLVM expression.
230 ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc
231 ppLlvmExpression opts expr
232 = case expr of
233 Alloca tp amount -> ppAlloca opts tp amount
234 LlvmOp op left right -> ppMachOp opts op left right
235 Call tp fp args attrs -> ppCall opts tp fp (map MetaVar args) attrs
236 CallM tp fp args attrs -> ppCall opts tp fp args attrs
237 Cast op from to -> ppCast opts op from to
238 Compare op left right -> ppCmpOp opts op left right
239 Extract vec idx -> ppExtract opts vec idx
240 ExtractV struct idx -> ppExtractV opts struct idx
241 Insert vec elt idx -> ppInsert opts vec elt idx
242 GetElemPtr inb ptr indexes -> ppGetElementPtr opts inb ptr indexes
243 Load ptr -> ppLoad opts ptr
244 ALoad ord st ptr -> ppALoad opts ord st ptr
245 Malloc tp amount -> ppMalloc opts tp amount
246 AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering
247 CmpXChg addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord
248 Phi tp predecessors -> ppPhi opts tp predecessors
249 Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk
250 MExpr meta expr -> ppMetaAnnotExpr opts meta expr
251
252 ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc
253 ppMetaExpr opts = \case
254 MetaVar (LMLitVar (LMNullLit _)) -> text "null"
255 MetaStr s -> char '!' <> doubleQuotes (ftext s)
256 MetaNode n -> ppr n
257 MetaVar v -> ppVar opts v
258 MetaStruct es -> char '!' <> braces (ppCommaJoin (map (ppMetaExpr opts) es))
259
260
261 --------------------------------------------------------------------------------
262 -- * Individual print functions
263 --------------------------------------------------------------------------------
264
265 -- | Should always be a function pointer. So a global var of function type
266 -- (since globals are always pointers) or a local var of pointer function type.
267 ppCall :: LlvmOpts -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
268 ppCall opts ct fptr args attrs = case fptr of
269 --
270 -- if local var function pointer, unwrap
271 LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
272
273 -- should be function type otherwise
274 LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d
275
276 -- not pointer or function, so error
277 _other -> error $ "ppCall called with non LMFunction type!\nMust be "
278 ++ " called with either global var of function type or "
279 ++ "local var of pointer function type."
280
281 where
282 ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
283 let tc = if ct == TailCall then text "tail " else empty
284 ppValues = ppCallParams opts (map snd params) args
285 ppArgTy = (ppCommaJoin $ map (ppr . fst) params) <>
286 (case argTy of
287 VarArgs -> text ", ..."
288 FixedArgs -> empty)
289 fnty = space <> lparen <> ppArgTy <> rparen
290 attrDoc = ppSpaceJoin attrs
291 in tc <> text "call" <+> ppr cc <+> ppr ret
292 <> fnty <+> ppName opts fptr <> lparen <+> ppValues
293 <+> rparen <+> attrDoc
294
295 ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
296 ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args
297 where
298 -- Metadata needs to be marked as having the `metadata` type when used
299 -- in a call argument
300 ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs opts v
301 ppCallMetaExpr _ v = text "metadata" <+> ppMetaExpr opts v
302
303
304 ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
305 ppMachOp opts op left right =
306 (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left
307 <> comma <+> ppName opts right
308
309
310 ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
311 ppCmpOp opts op left right =
312 let cmpOp
313 | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
314 | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
315 | otherwise = text "icmp" -- Just continue as its much easier to debug
316 {-
317 | otherwise = error ("can't compare different types, left = "
318 ++ (show $ getVarType left) ++ ", right = "
319 ++ (show $ getVarType right))
320 -}
321 in cmpOp <+> ppr op <+> ppr (getVarType left)
322 <+> ppName opts left <> comma <+> ppName opts right
323
324
325 ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc
326 ppAssignment opts var expr = ppName opts var <+> equals <+> expr
327
328 ppFence :: Bool -> LlvmSyncOrdering -> SDoc
329 ppFence st ord =
330 let singleThread = case st of True -> text "singlethread"
331 False -> empty
332 in text "fence" <+> singleThread <+> ppSyncOrdering ord
333
334 ppSyncOrdering :: LlvmSyncOrdering -> SDoc
335 ppSyncOrdering SyncUnord = text "unordered"
336 ppSyncOrdering SyncMonotonic = text "monotonic"
337 ppSyncOrdering SyncAcquire = text "acquire"
338 ppSyncOrdering SyncRelease = text "release"
339 ppSyncOrdering SyncAcqRel = text "acq_rel"
340 ppSyncOrdering SyncSeqCst = text "seq_cst"
341
342 ppAtomicOp :: LlvmAtomicOp -> SDoc
343 ppAtomicOp LAO_Xchg = text "xchg"
344 ppAtomicOp LAO_Add = text "add"
345 ppAtomicOp LAO_Sub = text "sub"
346 ppAtomicOp LAO_And = text "and"
347 ppAtomicOp LAO_Nand = text "nand"
348 ppAtomicOp LAO_Or = text "or"
349 ppAtomicOp LAO_Xor = text "xor"
350 ppAtomicOp LAO_Max = text "max"
351 ppAtomicOp LAO_Min = text "min"
352 ppAtomicOp LAO_Umax = text "umax"
353 ppAtomicOp LAO_Umin = text "umin"
354
355 ppAtomicRMW :: LlvmOpts -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
356 ppAtomicRMW opts aop tgt src ordering =
357 text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma
358 <+> ppVar opts src <+> ppSyncOrdering ordering
359
360 ppCmpXChg :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar
361 -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
362 ppCmpXChg opts addr old new s_ord f_ord =
363 text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new
364 <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord
365
366 -- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
367 -- we have no way of guaranteeing that this is true with GHC (we would need to
368 -- modify the layout of the stack and closures, change the storage manager,
369 -- etc.). So, we blindly tell LLVM that *any* vector store or load could be
370 -- unaligned. In the future we may be able to guarantee that certain vector
371 -- access patterns are aligned, in which case we will need a more granular way
372 -- of specifying alignment.
373
374 ppLoad :: LlvmOpts -> LlvmVar -> SDoc
375 ppLoad opts var = text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align
376 where
377 derefType = pLower $ getVarType var
378 align | isVector . pLower . getVarType $ var = text ", align 1"
379 | otherwise = empty
380
381 ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
382 ppALoad opts ord st var =
383 let alignment = (llvmWidthInBits (llvmOptsPlatform opts) $ getVarType var) `quot` 8
384 align = text ", align" <+> ppr alignment
385 sThreaded | st = text " singlethread"
386 | otherwise = empty
387 derefType = pLower $ getVarType var
388 in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded
389 <+> ppSyncOrdering ord <> align
390
391 ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
392 ppStore opts val dst
393 | isVecPtrVar dst = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <>
394 comma <+> text "align 1"
395 | otherwise = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst
396 where
397 isVecPtrVar :: LlvmVar -> Bool
398 isVecPtrVar = isVector . pLower . getVarType
399
400
401 ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
402 ppCast opts op from to
403 = ppr op
404 <+> ppr (getVarType from) <+> ppName opts from
405 <+> text "to"
406 <+> ppr to
407
408
409 ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc
410 ppMalloc opts tp amount =
411 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
412 in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount'
413
414
415 ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc
416 ppAlloca opts tp amount =
417 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
418 in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount'
419
420
421 ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc
422 ppGetElementPtr opts inb ptr idx =
423 let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx)
424 inbound = if inb then text "inbounds" else empty
425 derefType = pLower $ getVarType ptr
426 in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppVar opts ptr
427 <> indexes
428
429
430 ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc
431 ppReturn opts (Just var) = text "ret" <+> ppVar opts var
432 ppReturn _ Nothing = text "ret" <+> ppr LMVoid
433
434
435 ppBranch :: LlvmOpts -> LlvmVar -> SDoc
436 ppBranch opts var = text "br" <+> ppVar opts var
437
438
439 ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
440 ppBranchIf opts cond trueT falseT
441 = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT
442
443
444 ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
445 ppPhi opts tp preds =
446 let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label
447 in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)
448
449
450 ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
451 ppSwitch opts scrut dflt targets =
452 let ppTarget (val, lab) = ppVar opts val <> comma <+> ppVar opts lab
453 ppTargets xs = brackets $ vcat (map ppTarget xs)
454 in text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt
455 <+> ppTargets targets
456
457
458 ppAsm :: LlvmOpts -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
459 ppAsm opts asm constraints rty vars sideeffect alignstack =
460 let asm' = doubleQuotes $ ftext asm
461 cons = doubleQuotes $ ftext constraints
462 rty' = ppr rty
463 vars' = lparen <+> ppCommaJoin (map (ppVar opts) vars) <+> rparen
464 side = if sideeffect then text "sideeffect" else empty
465 align = if alignstack then text "alignstack" else empty
466 in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
467 <+> cons <> vars'
468
469 ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
470 ppExtract opts vec idx =
471 text "extractelement"
472 <+> ppr (getVarType vec) <+> ppName opts vec <> comma
473 <+> ppVar opts idx
474
475 ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc
476 ppExtractV opts struct idx =
477 text "extractvalue"
478 <+> ppr (getVarType struct) <+> ppName opts struct <> comma
479 <+> ppr idx
480
481 ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
482 ppInsert opts vec elt idx =
483 text "insertelement"
484 <+> ppr (getVarType vec) <+> ppName opts vec <> comma
485 <+> ppr (getVarType elt) <+> ppName opts elt <> comma
486 <+> ppVar opts idx
487
488
489 ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc
490 ppMetaStatement opts meta stmt =
491 ppLlvmStatement opts stmt <> ppMetaAnnots opts meta
492
493 ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc
494 ppMetaAnnotExpr opts meta expr =
495 ppLlvmExpression opts expr <> ppMetaAnnots opts meta
496
497 ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc
498 ppMetaAnnots opts meta = hcat $ map ppMeta meta
499 where
500 ppMeta (MetaAnnot name e)
501 = comma <+> exclamation <> ftext name <+>
502 case e of
503 MetaNode n -> ppr n
504 MetaStruct ms -> exclamation <> braces (ppCommaJoin (map (ppMetaExpr opts) ms))
505 other -> exclamation <> braces (ppMetaExpr opts other) -- possible?
506
507 -- | Return the variable name or value of the 'LlvmVar'
508 -- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
509 ppName :: LlvmOpts -> LlvmVar -> SDoc
510 ppName opts v = case v of
511 LMGlobalVar {} -> char '@' <> ppPlainName opts v
512 LMLocalVar {} -> char '%' <> ppPlainName opts v
513 LMNLocalVar {} -> char '%' <> ppPlainName opts v
514 LMLitVar {} -> ppPlainName opts v
515
516 -- | Return the variable name or value of the 'LlvmVar'
517 -- in a plain textual representation (e.g. @x@, @y@ or @42@).
518 ppPlainName :: LlvmOpts -> LlvmVar -> SDoc
519 ppPlainName opts v = case v of
520 (LMGlobalVar x _ _ _ _ _) -> ftext x
521 (LMLocalVar x LMLabel ) -> text (show x)
522 (LMLocalVar x _ ) -> text ('l' : show x)
523 (LMNLocalVar x _ ) -> ftext x
524 (LMLitVar x ) -> ppLit opts x
525
526 -- | Print a literal value. No type.
527 ppLit :: LlvmOpts -> LlvmLit -> SDoc
528 ppLit opts l = case l of
529 (LMIntLit i (LMInt 32)) -> ppr (fromInteger i :: Int32)
530 (LMIntLit i (LMInt 64)) -> ppr (fromInteger i :: Int64)
531 (LMIntLit i _ ) -> ppr ((fromInteger i)::Int)
532 (LMFloatLit r LMFloat ) -> ppFloat (llvmOptsPlatform opts) $ narrowFp r
533 (LMFloatLit r LMDouble) -> ppDouble (llvmOptsPlatform opts) r
534 f@(LMFloatLit _ _) -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f)
535 (LMVectorLit ls ) -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>'
536 (LMNullLit _ ) -> text "null"
537 -- #11487 was an issue where we passed undef for some arguments
538 -- that were actually live. By chance the registers holding those
539 -- arguments usually happened to have the right values anyways, but
540 -- that was not guaranteed. To find such bugs reliably, we set the
541 -- flag below when validating, which replaces undef literals (at
542 -- common types) with values that are likely to cause a crash or test
543 -- failure.
544 (LMUndefLit t )
545 | llvmOptsFillUndefWithGarbage opts
546 , Just lit <- garbageLit t -> ppLit opts lit
547 | otherwise -> text "undef"
548
549 ppVar :: LlvmOpts -> LlvmVar -> SDoc
550 ppVar = ppVar' []
551
552 ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc
553 ppVar' attrs opts v = case v of
554 LMLitVar x -> ppTypeLit' attrs opts x
555 x -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x
556
557 ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc
558 ppTypeLit = ppTypeLit' []
559
560 ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc
561 ppTypeLit' attrs opts l = case l of
562 LMVectorLit {} -> ppLit opts l
563 _ -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l
564
565 ppStatic :: LlvmOpts -> LlvmStatic -> SDoc
566 ppStatic opts st = case st of
567 LMComment s -> text "; " <> ftext s
568 LMStaticLit l -> ppTypeLit opts l
569 LMUninitType t -> ppr t <> text " undef"
570 LMStaticStr s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\""
571 LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']'
572 LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>"
573 LMStaticPointer v -> ppVar opts v
574 LMTrunc v t -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
575 LMBitc v t -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
576 LMPtoI v t -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
577 LMAdd s1 s2 -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd")
578 LMSub s1 s2 -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub")
579
580
581 pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc
582 pprSpecialStatic opts stat = case stat of
583 LMBitc v t -> ppr (pLower t)
584 <> text ", bitcast ("
585 <> ppStatic opts v <> text " to " <> ppr t
586 <> char ')'
587 LMStaticPointer x -> ppr (pLower $ getVarType x)
588 <> comma <+> ppStatic opts stat
589 _ -> ppStatic opts stat
590
591
592 pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc
593 -> SDoc -> SDoc
594 pprStaticArith opts s1 s2 int_op float_op op_name =
595 let ty1 = getStatType s1
596 op = if isFloat ty1 then float_op else int_op
597 in if ty1 == getStatType s2
598 then ppr ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen
599 else pprPanic "pprStaticArith" $
600 op_name <> text " with different types! s1: " <> ppStatic opts s1
601 <> text", s2: " <> ppStatic opts s2
602
603
604 --------------------------------------------------------------------------------
605 -- * Misc functions
606 --------------------------------------------------------------------------------
607
608 -- | Blank line.
609 newLine :: SDoc
610 newLine = empty
611
612 -- | Exclamation point.
613 exclamation :: SDoc
614 exclamation = char '!'