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