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