PpLlvm.hs 18.4 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

3 4 5 6 7 8 9 10 11 12 13 14
--------------------------------------------------------------------------------
-- | Pretty print LLVM IR Code.
--

module Llvm.PpLlvm (

    -- * Top level LLVM objects.
    ppLlvmModule,
    ppLlvmComments,
    ppLlvmComment,
    ppLlvmGlobals,
    ppLlvmGlobal,
15
    ppLlvmAliases,
16 17 18
    ppLlvmAlias,
    ppLlvmMetas,
    ppLlvmMeta,
19 20 21 22
    ppLlvmFunctionDecls,
    ppLlvmFunctionDecl,
    ppLlvmFunctions,
    ppLlvmFunction,
dterei's avatar
dterei committed
23

24 25 26 27 28
    ) where

#include "HsVersions.h"

import Llvm.AbsSyn
29
import Llvm.MetaData
30 31 32
import Llvm.Types

import Data.List ( intersperse )
Ian Lynagh's avatar
Ian Lynagh committed
33
import Outputable
34
import Unique
35
import FastString ( sLit )
36 37 38 39 40 41

--------------------------------------------------------------------------------
-- * Top Level Print functions
--------------------------------------------------------------------------------

-- | Print out a whole LLVM module.
Ian Lynagh's avatar
Ian Lynagh committed
42
ppLlvmModule :: LlvmModule -> SDoc
43
ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
44 45
  = ppLlvmComments comments $+$ newLine
    $+$ ppLlvmAliases aliases $+$ newLine
46
    $+$ ppLlvmMetas meta $+$ newLine
47 48
    $+$ ppLlvmGlobals globals $+$ newLine
    $+$ ppLlvmFunctionDecls decls $+$ newLine
49 50 51
    $+$ ppLlvmFunctions funcs

-- | Print out a multi-line comment, can be inside a function or on its own
Ian Lynagh's avatar
Ian Lynagh committed
52
ppLlvmComments :: [LMString] -> SDoc
53 54 55
ppLlvmComments comments = vcat $ map ppLlvmComment comments

-- | Print out a comment, can be inside a function or on its own
Ian Lynagh's avatar
Ian Lynagh committed
56
ppLlvmComment :: LMString -> SDoc
dterei's avatar
dterei committed
57
ppLlvmComment com = semi <+> ftext com
58 59 60


-- | Print out a list of global mutable variable definitions
Ian Lynagh's avatar
Ian Lynagh committed
61
ppLlvmGlobals :: [LMGlobal] -> SDoc
62 63 64
ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls

-- | Print out a global mutable variable definition
Ian Lynagh's avatar
Ian Lynagh committed
65
ppLlvmGlobal :: LMGlobal -> SDoc
Peter Wortmann's avatar
Peter Wortmann committed
66
ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
dterei's avatar
dterei committed
67 68 69 70 71 72 73 74
    let sect = case x of
            Just x' -> text ", section" <+> doubleQuotes (ftext x')
            Nothing -> empty

        align = case a of
            Just a' -> text ", align" <+> int a'
            Nothing -> empty

75
        rhs = case dat of
76 77
            Just stat -> ppr stat
            Nothing   -> ppr (pLower $ getVarType var)
78

Peter Wortmann's avatar
Peter Wortmann committed
79
        -- Position of linkage is different for aliases.
80 81 82 83
        const = case c of
          Global   -> text "global"
          Constant -> text "constant"
          Alias    -> text "alias"
84

85
    in ppAssignment var $ ppr link <+> const <+> rhs <> sect <> align
86
       $+$ newLine
87

Peter Wortmann's avatar
Peter Wortmann committed
88
ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
89 90
  error $ "Non Global var ppr as global! "
          ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val)
91 92 93


-- | Print out a list of LLVM type aliases.
Ian Lynagh's avatar
Ian Lynagh committed
94
ppLlvmAliases :: [LlvmAlias] -> SDoc
95
ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
96 97

-- | Print out an LLVM type alias.
Ian Lynagh's avatar
Ian Lynagh committed
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 106 107
ppLlvmMetas metas = vcat $ map ppLlvmMeta metas

-- | Print out an LLVM metadata definition.
108 109
ppLlvmMeta :: MetaDecl -> SDoc
ppLlvmMeta (MetaUnamed n m)
110
  = exclamation <> int n <> text " = " <> ppLlvmMetaExpr m
111 112 113

ppLlvmMeta (MetaNamed n m)
  = exclamation <> ftext n <> text " = !" <> braces nodes
114
  where
115
    nodes = hcat $ intersperse comma $ map pprNode m
116 117 118
    pprNode n = exclamation <> int n

-- | Print out an LLVM metadata value.
119
ppLlvmMetaExpr :: MetaExpr -> SDoc
120
ppLlvmMetaExpr (MetaVar (LMLitVar (LMNullLit _))) = text "null"
121 122
ppLlvmMetaExpr (MetaStr    s ) = text "!" <> doubleQuotes (ftext s)
ppLlvmMetaExpr (MetaNode   n ) = text "!" <> int n
123
ppLlvmMetaExpr (MetaVar    v ) = ppr v
124
ppLlvmMetaExpr (MetaStruct es) =
125
    text "!{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}'
126 127


128
-- | Print out a list of function definitions.
Ian Lynagh's avatar
Ian Lynagh committed
129
ppLlvmFunctions :: LlvmFunctions -> SDoc
130 131 132
ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs

-- | Print out a function definition.
Ian Lynagh's avatar
Ian Lynagh committed
133
ppLlvmFunction :: LlvmFunction -> SDoc
134 135 136
ppLlvmFunction fun =
    let attrDoc = ppSpaceJoin (funcAttrs fun)
        secDoc = case funcSect fun of
137
                      Just s' -> text "section" <+> (doubleQuotes $ ftext s')
dterei's avatar
dterei committed
138
                      Nothing -> empty
139 140 141 142 143
        prefixDoc = case funcPrefix fun of
                        Just v  -> text "prefix" <+> ppr v
                        Nothing -> empty
    in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
        <+> attrDoc <+> secDoc <+> prefixDoc
144
        $+$ lbrace
145
        $+$ ppLlvmBlocks (funcBody fun)
146
        $+$ rbrace
147 148
        $+$ newLine
        $+$ newLine
149

150
-- | Print out a function defenition header.
Ian Lynagh's avatar
Ian Lynagh committed
151
ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
152
ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
153
  = let varg' = case varg of
154 155 156
                      VarArgs | null p    -> sLit "..."
                              | otherwise -> sLit ", ..."
                      _otherwise          -> sLit ""
157
        align = case a of
158
                     Just a' -> text " align " <> ppr a'
159
                     Nothing -> empty
160
        args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'
161 162
                                    <> ftext n)
                    (zip p args)
163 164
    in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>
        (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align
165

166
-- | Print out a list of function declaration.
Ian Lynagh's avatar
Ian Lynagh committed
167
ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
168 169 170 171 172
ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs

-- | Print out a function declaration.
-- Declarations define the function type but don't define the actual body of
-- the function.
Ian Lynagh's avatar
Ian Lynagh committed
173
ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
174 175
ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
  = let varg' = case varg of
176 177 178
                      VarArgs | null p    -> sLit "..."
                              | otherwise -> sLit ", ..."
                      _otherwise          -> sLit ""
179
        align = case a of
180
                     Just a' -> text " align" <+> ppr a'
181 182
                     Nothing -> empty
        args = hcat $ intersperse (comma <> space) $
183 184 185
                  map (\(t,a) -> ppr t <+> ppSpaceJoin a) p
    in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>
        ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine
186 187 188


-- | Print out a list of LLVM blocks.
Ian Lynagh's avatar
Ian Lynagh committed
189
ppLlvmBlocks :: LlvmBlocks -> SDoc
190 191 192 193
ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks

-- | Print out an LLVM block.
-- It must be part of a function definition.
Ian Lynagh's avatar
Ian Lynagh committed
194
ppLlvmBlock :: LlvmBlock -> SDoc
195 196 197 198 199 200 201 202
ppLlvmBlock (LlvmBlock blockId stmts) =
  let isLabel (MkLabel _) = True
      isLabel _           = False
      (block, rest)       = break isLabel stmts
      ppRest = case rest of
        MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs)
        _             -> empty
  in ppLlvmBlockLabel blockId
203
           $+$ (vcat $ map ppLlvmStatement block)
204 205
           $+$ newLine
           $+$ ppRest
206

207
-- | Print out an LLVM block label.
Ian Lynagh's avatar
Ian Lynagh committed
208 209
ppLlvmBlockLabel :: LlvmBlockId -> SDoc
ppLlvmBlockLabel id = pprUnique id <> colon
210 211


212
-- | Print out an LLVM statement.
Ian Lynagh's avatar
Ian Lynagh committed
213
ppLlvmStatement :: LlvmStatement -> SDoc
214 215 216 217
ppLlvmStatement stmt =
  let ind = (text "  " <>)
  in case stmt of
        Assignment  dst expr      -> ind $ ppAssignment dst (ppLlvmExpression expr)
218
        Fence       st ord        -> ind $ ppFence st ord
219 220 221
        Branch      target        -> ind $ ppBranch target
        BranchIf    cond ifT ifF  -> ind $ ppBranchIf cond ifT ifF
        Comment     comments      -> ind $ ppLlvmComments comments
222
        MkLabel     label         -> ppLlvmBlockLabel label
223 224 225 226 227
        Store       value ptr     -> ind $ ppStore value ptr
        Switch      scrut def tgs -> ind $ ppSwitch scrut def tgs
        Return      result        -> ind $ ppReturn result
        Expr        expr          -> ind $ ppLlvmExpression expr
        Unreachable               -> ind $ text "unreachable"
228
        Nop                       -> empty
229
        MetaStmt    meta s        -> ppMetaStatement meta s
230 231 232


-- | Print out an LLVM expression.
Ian Lynagh's avatar
Ian Lynagh committed
233
ppLlvmExpression :: LlvmExpression -> SDoc
234 235 236 237
ppLlvmExpression expr
  = case expr of
        Alloca     tp amount        -> ppAlloca tp amount
        LlvmOp     op left right    -> ppMachOp op left right
238
        Call       tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs
239
        CallM      tp fp args attrs -> ppCall tp fp args attrs
240 241
        Cast       op from to       -> ppCast op from to
        Compare    op left right    -> ppCmpOp op left right
242
        Extract    vec idx          -> ppExtract vec idx
243
        ExtractV   struct idx       -> ppExtractV struct idx
244
        Insert     vec elt idx      -> ppInsert vec elt idx
245
        GetElemPtr inb ptr indexes  -> ppGetElementPtr inb ptr indexes
246
        Load       ptr              -> ppLoad ptr
247
        ALoad      ord st ptr       -> ppALoad ord st ptr
248
        Malloc     tp amount        -> ppMalloc tp amount
249 250
        AtomicRMW  aop tgt src ordering -> ppAtomicRMW aop tgt src ordering
        CmpXChg    addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord
251
        Phi        tp precessors    -> ppPhi tp precessors
dterei's avatar
dterei committed
252
        Asm        asm c ty v se sk -> ppAsm asm c ty v se sk
253
        MExpr      meta expr        -> ppMetaExpr meta expr
254 255 256 257 258 259 260 261


--------------------------------------------------------------------------------
-- * Individual print functions
--------------------------------------------------------------------------------

-- | Should always be a function pointer. So a global var of function type
-- (since globals are always pointers) or a local var of pointer function type.
262
ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
263
ppCall ct fptr args attrs = case fptr of
264 265 266 267 268
                           --
    -- if local var function pointer, unwrap
    LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d

    -- should be function type otherwise
269
    LMGlobalVar _ (LMFunction d) _ _ _ _    -> ppCall' d
270 271 272 273 274 275 276

    -- not pointer or function, so error
    _other -> error $ "ppCall called with non LMFunction type!\nMust be "
                ++ " called with either global var of function type or "
                ++ "local var of pointer function type."

    where
277
        ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
278
            let tc = if ct == TailCall then text "tail " else empty
279
                ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args
280 281 282 283
                ppArgTy  = (ppCommaJoin $ map fst params) <>
                           (case argTy of
                               VarArgs   -> text ", ..."
                               FixedArgs -> empty)
284
                fnty = space <> lparen <> ppArgTy <> rparen
285
                attrDoc = ppSpaceJoin attrs
286
            in  tc <> text "call" <+> ppr cc <+> ppr ret
287
                    <> fnty <+> ppName fptr <> lparen <+> ppValues
288 289
                    <+> rparen <+> attrDoc

290 291 292 293
        -- Metadata needs to be marked as having the `metadata` type when used
        -- in a call argument
        ppCallMetaExpr (MetaVar v) = ppr v
        ppCallMetaExpr v           = text "metadata" <+> ppr v
294

Ian Lynagh's avatar
Ian Lynagh committed
295
ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
296
ppMachOp op left right =
297 298
  (ppr op) <+> (ppr (getVarType left)) <+> ppName left
        <> comma <+> ppName right
299 300


Ian Lynagh's avatar
Ian Lynagh committed
301
ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
302 303 304 305
ppCmpOp op left right =
  let cmpOp
        | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
        | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
306 307
        | otherwise = text "icmp" -- Just continue as its much easier to debug
        {-
308 309 310
        | otherwise = error ("can't compare different types, left = "
                ++ (show $ getVarType left) ++ ", right = "
                ++ (show $ getVarType right))
311
        -}
312 313
  in cmpOp <+> ppr op <+> ppr (getVarType left)
        <+> ppName left <> comma <+> ppName right
314 315


Ian Lynagh's avatar
Ian Lynagh committed
316
ppAssignment :: LlvmVar -> SDoc -> SDoc
317
ppAssignment var expr = ppName var <+> equals <+> expr
318

Ian Lynagh's avatar
Ian Lynagh committed
319
ppFence :: Bool -> LlvmSyncOrdering -> SDoc
320 321
ppFence st ord =
  let singleThread = case st of True  -> text "singlethread"
322
                                False -> empty
323 324
  in text "fence" <+> singleThread <+> ppSyncOrdering ord

Ian Lynagh's avatar
Ian Lynagh committed
325
ppSyncOrdering :: LlvmSyncOrdering -> SDoc
326 327 328 329 330 331
ppSyncOrdering SyncUnord     = text "unordered"
ppSyncOrdering SyncMonotonic = text "monotonic"
ppSyncOrdering SyncAcquire   = text "acquire"
ppSyncOrdering SyncRelease   = text "release"
ppSyncOrdering SyncAcqRel    = text "acq_rel"
ppSyncOrdering SyncSeqCst    = text "seq_cst"
332

333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
ppAtomicOp :: LlvmAtomicOp -> SDoc
ppAtomicOp LAO_Xchg = text "xchg"
ppAtomicOp LAO_Add  = text "add"
ppAtomicOp LAO_Sub  = text "sub"
ppAtomicOp LAO_And  = text "and"
ppAtomicOp LAO_Nand = text "nand"
ppAtomicOp LAO_Or   = text "or"
ppAtomicOp LAO_Xor  = text "xor"
ppAtomicOp LAO_Max  = text "max"
ppAtomicOp LAO_Min  = text "min"
ppAtomicOp LAO_Umax = text "umax"
ppAtomicOp LAO_Umin = text "umin"

ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
ppAtomicRMW aop tgt src ordering =
  text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma
  <+> ppr src <+> ppSyncOrdering ordering

ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar
          -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
ppCmpXChg addr old new s_ord f_ord =
  text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new
  <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord

357 358 359 360 361 362 363
-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
-- we have no way of guaranteeing that this is true with GHC (we would need to
-- modify the layout of the stack and closures, change the storage manager,
-- etc.). So, we blindly tell LLVM that *any* vector store or load could be
-- unaligned. In the future we may be able to guarantee that certain vector
-- access patterns are aligned, in which case we will need a more granular way
-- of specifying alignment.
364

365
ppLoad :: LlvmVar -> SDoc
366
ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align
367
  where
368
    derefType = pLower $ getVarType var
369 370 371 372 373 374 375 376 377
    align | isVector . pLower . getVarType $ var = text ", align 1"
          | otherwise = empty

ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
ppALoad ord st var = sdocWithDynFlags $ \dflags ->
  let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8
      align     = text ", align" <+> ppr alignment
      sThreaded | st        = text " singlethread"
                | otherwise = empty
378 379 380
      derefType = pLower $ getVarType var
  in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded
            <+> ppSyncOrdering ord <> align
381

Ian Lynagh's avatar
Ian Lynagh committed
382
ppStore :: LlvmVar -> LlvmVar -> SDoc
383
ppStore val dst
384
    | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <>
385
                        comma <+> text "align 1"
386
    | otherwise       = text "store" <+> ppr val <> comma <+> ppr dst
387 388 389
  where
    isVecPtrVar :: LlvmVar -> Bool
    isVecPtrVar = isVector . pLower . getVarType
390 391


Ian Lynagh's avatar
Ian Lynagh committed
392
ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
393 394
ppCast op from to
    =   ppr op
benl's avatar
benl committed
395
    <+> ppr (getVarType from) <+> ppName from
396
    <+> text "to"
benl's avatar
benl committed
397
    <+> ppr to
398 399


Ian Lynagh's avatar
Ian Lynagh committed
400
ppMalloc :: LlvmType -> Int -> SDoc
401 402
ppMalloc tp amount =
  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
403
  in text "malloc" <+> ppr tp <> comma <+> ppr amount'
404 405


Ian Lynagh's avatar
Ian Lynagh committed
406
ppAlloca :: LlvmType -> Int -> SDoc
407 408
ppAlloca tp amount =
  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
409
  in text "alloca" <+> ppr tp <> comma <+> ppr amount'
410 411


Ian Lynagh's avatar
Ian Lynagh committed
412
ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
413
ppGetElementPtr inb ptr idx =
414
  let indexes = comma <+> ppCommaJoin idx
415
      inbound = if inb then text "inbounds" else empty
416 417 418
      derefType = pLower $ getVarType ptr
  in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr
                            <> indexes
419 420


Ian Lynagh's avatar
Ian Lynagh committed
421
ppReturn :: Maybe LlvmVar -> SDoc
422 423
ppReturn (Just var) = text "ret" <+> ppr var
ppReturn Nothing    = text "ret" <+> ppr LMVoid
424 425


Ian Lynagh's avatar
Ian Lynagh committed
426
ppBranch :: LlvmVar -> SDoc
427
ppBranch var = text "br" <+> ppr var
428 429


Ian Lynagh's avatar
Ian Lynagh committed
430
ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
431
ppBranchIf cond trueT falseT
432
  = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT
433 434


Ian Lynagh's avatar
Ian Lynagh committed
435
ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
436
ppPhi tp preds =
437 438
  let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label
  in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)
439 440


Ian Lynagh's avatar
Ian Lynagh committed
441
ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
442
ppSwitch scrut dflt targets =
443
  let ppTarget  (val, lab) = ppr val <> comma <+> ppr lab
444
      ppTargets  xs        = brackets $ vcat (map ppTarget xs)
445
  in text "switch" <+> ppr scrut <> comma <+> ppr dflt
dterei's avatar
dterei committed
446
        <+> ppTargets targets
447 448


Ian Lynagh's avatar
Ian Lynagh committed
449
ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
dterei's avatar
dterei committed
450 451 452
ppAsm asm constraints rty vars sideeffect alignstack =
  let asm'  = doubleQuotes $ ftext asm
      cons  = doubleQuotes $ ftext constraints
453
      rty'  = ppr rty
dterei's avatar
dterei committed
454 455 456 457 458 459
      vars' = lparen <+> ppCommaJoin vars <+> rparen
      side  = if sideeffect then text "sideeffect" else empty
      align = if alignstack then text "alignstack" else empty
  in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
        <+> cons <> vars'

460 461 462
ppExtract :: LlvmVar -> LlvmVar -> SDoc
ppExtract vec idx =
    text "extractelement"
463 464
    <+> ppr (getVarType vec) <+> ppName vec <> comma
    <+> ppr idx
465

466 467 468 469 470 471
ppExtractV :: LlvmVar -> Int -> SDoc
ppExtractV struct idx =
    text "extractvalue"
    <+> ppr (getVarType struct) <+> ppName struct <> comma
    <+> ppr idx

472 473 474
ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert vec elt idx =
    text "insertelement"
475 476 477
    <+> ppr (getVarType vec) <+> ppName vec <> comma
    <+> ppr (getVarType elt) <+> ppName elt <> comma
    <+> ppr idx
dterei's avatar
dterei committed
478

479

480 481
ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc
ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta
482

483 484
ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc
ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta
485

486 487
ppMetaAnnots :: [MetaAnnot] -> SDoc
ppMetaAnnots meta = hcat $ map ppMeta meta
488
  where
489 490 491 492 493
    ppMeta (MetaAnnot name e)
        = comma <+> exclamation <> ftext name <+>
          case e of
            MetaNode n    -> exclamation <> int n
            MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)
494
            other         -> exclamation <> braces (ppr other) -- possible?
495 496


497 498 499 500
--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------

501
-- | Blank line.
Ian Lynagh's avatar
Ian Lynagh committed
502
newLine :: SDoc
503
newLine = empty
504

505
-- | Exclamation point.
Ian Lynagh's avatar
Ian Lynagh committed
506
exclamation :: SDoc
507
exclamation = char '!'