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     ppLlvmAlias,
  14     ppLlvmAliases,
  15     ppLlvmFunctionDecls,
  16     ppLlvmFunctionDecl,
  17     ppLlvmFunctions,
  18     ppLlvmFunction,
  19
  20     -- * Utility functions
  21     llvmSDoc
  22
  23     ) where
  24
  25 #include "HsVersions.h"
  26
  27 import Llvm.AbsSyn
  28 import Llvm.Types
  29
  30 import Data.List ( intersperse )
  31 import Pretty
  32 import qualified Outputable as Out
  33 import Unique
  34
  35 --------------------------------------------------------------------------------
  36 -- * Top Level Print functions
  37 --------------------------------------------------------------------------------
  38
  39 -- | Print out a whole LLVM module.
  40 ppLlvmModule :: LlvmModule -> Doc
  41 ppLlvmModule (LlvmModule comments aliases globals decls funcs)
  42   = ppLlvmComments comments
  43     $+$ empty
  44     $+$ ppLlvmAliases aliases
  45     $+$ empty
  46     $+$ ppLlvmGlobals globals
  47     $+$ empty
  48     $+$ ppLlvmFunctionDecls decls
  49     $+$ empty
  50     $+$ ppLlvmFunctions funcs
  51
  52 -- | Print out a multi-line comment, can be inside a function or on its own
  53 ppLlvmComments :: [LMString] -> Doc
  54 ppLlvmComments comments = vcat $ map ppLlvmComment comments
  55
  56 -- | Print out a comment, can be inside a function or on its own
  57 ppLlvmComment :: LMString -> Doc
  58 ppLlvmComment com = semi <+> ftext com
  59
  60
  61 -- | Print out a list of global mutable variable definitions
  62 ppLlvmGlobals :: [LMGlobal] -> Doc
  63 ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
  64
  65 -- | Print out a global mutable variable definition
  66 ppLlvmGlobal :: LMGlobal -> Doc
  67 ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
  68     let sect = case x of
  69             Just x' -> text ", section" <+> doubleQuotes (ftext x')
  70             Nothing -> empty
  71
  72         align = case a of
  73             Just a' -> text ", align" <+> int a'
  74             Nothing -> empty
  75
  76         rhs = case dat of
  77             Just stat -> texts stat
  78             Nothing   -> texts (pLower $ getVarType var)
  79
  80         const' = if c then text "constant" else text "global"
  81
  82     in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align
  83
  84 ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
  85
  86
  87 -- | Print out a list of LLVM type aliases.
  88 ppLlvmAliases :: [LlvmAlias] -> Doc
  89 ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
  90
  91 -- | Print out an LLVM type alias.
  92 ppLlvmAlias :: LlvmAlias -> Doc
  93 ppLlvmAlias (name, ty) = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
  94
  95
  96 -- | Print out a list of function definitions.
  97 ppLlvmFunctions :: LlvmFunctions -> Doc
  98 ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
  99
 100 -- | Print out a function definition.
 101 ppLlvmFunction :: LlvmFunction -> Doc
 102 ppLlvmFunction (LlvmFunction dec args attrs sec body) =
 103     let attrDoc = ppSpaceJoin attrs
 104         secDoc = case sec of
 105                       Just s' -> text "section" <+> (doubleQuotes $ ftext s')
 106                       Nothing -> empty
 107     in text "define" <+> ppLlvmFunctionHeader dec args
 108         <+> attrDoc <+> secDoc
 109         $+$ lbrace
 110         $+$ ppLlvmBlocks body
 111         $+$ rbrace
 112
 113 -- | Print out a function defenition header.
 114 ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc
 115 ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
 116   = let varg' = if varg == VarArgs then text ", ..." else empty
 117         align = case a of
 118                      Just a' -> space <> text "align" <+> texts a'
 119                      Nothing -> empty
 120         args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%"
 121                                     <> ftext n)
 122                     (zip p args)
 123     in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <>
 124         (hcat $ intersperse comma args') <> varg' <> rparen <> align
 125
 126
 127 -- | Print out a list of function declaration.
 128 ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
 129 ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
 130
 131 -- | Print out a function declaration.
 132 -- Declarations define the function type but don't define the actual body of
 133 -- the function.
 134 ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
 135 ppLlvmFunctionDecl dec = text "declare" <+> texts dec
 136
 137
 138 -- | Print out a list of LLVM blocks.
 139 ppLlvmBlocks :: LlvmBlocks -> Doc
 140 ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
 141
 142 -- | Print out an LLVM block.
 143 -- It must be part of a function definition.
 144 ppLlvmBlock :: LlvmBlock -> Doc
 145 ppLlvmBlock (LlvmBlock blockId stmts)
 146   = ppLlvmStatement (MkLabel blockId)
 147         $+$ nest 4 (vcat $ map ppLlvmStatement stmts)
 148
 149
 150 -- | Print out an LLVM statement.
 151 ppLlvmStatement :: LlvmStatement -> Doc
 152 ppLlvmStatement stmt
 153   = case stmt of
 154         Assignment  dst expr      -> ppAssignment dst (ppLlvmExpression expr)
 155         Branch      target        -> ppBranch target
 156         BranchIf    cond ifT ifF  -> ppBranchIf cond ifT ifF
 157         Comment     comments      -> ppLlvmComments comments
 158         MkLabel     label         -> (llvmSDoc $ pprUnique label) <> colon
 159         Store       value ptr     -> ppStore value ptr
 160         Switch      scrut def tgs -> ppSwitch scrut def tgs
 161         Return      result        -> ppReturn result
 162         Expr        expr          -> ppLlvmExpression expr
 163         Unreachable               -> text "unreachable"
 164         Nop                       -> empty
 165
 166
 167 -- | Print out an LLVM expression.
 168 ppLlvmExpression :: LlvmExpression -> Doc
 169 ppLlvmExpression expr
 170   = case expr of
 171         Alloca     tp amount        -> ppAlloca tp amount
 172         LlvmOp     op left right    -> ppMachOp op left right
 173         Call       tp fp args attrs -> ppCall tp fp args attrs
 174         Cast       op from to       -> ppCast op from to
 175         Compare    op left right    -> ppCmpOp op left right
 176         GetElemPtr inb ptr indexes  -> ppGetElementPtr inb ptr indexes
 177         Load       ptr              -> ppLoad ptr
 178         Malloc     tp amount        -> ppMalloc tp amount
 179         Phi        tp precessors    -> ppPhi tp precessors
 180         Asm        asm c ty v se sk -> ppAsm asm c ty v se sk
 181
 182
 183 --------------------------------------------------------------------------------
 184 -- * Individual print functions
 185 --------------------------------------------------------------------------------
 186
 187 -- | Should always be a function pointer. So a global var of function type
 188 -- (since globals are always pointers) or a local var of pointer function type.
 189 ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> Doc
 190 ppCall ct fptr vals attrs = case fptr of
 191                            --
 192     -- if local var function pointer, unwrap
 193     LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
 194
 195     -- should be function type otherwise
 196     LMGlobalVar _ (LMFunction d) _ _ _ _    -> ppCall' d
 197
 198     -- not pointer or function, so error
 199     _other -> error $ "ppCall called with non LMFunction type!\nMust be "
 200                 ++ " called with either global var of function type or "
 201                 ++ "local var of pointer function type."
 202
 203     where
 204         ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
 205             let tc = if ct == TailCall then text "tail " else empty
 206                 ppValues = ppCommaJoin vals
 207                 ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params
 208                 ppArgTy  = (hcat $ intersperse comma ppParams) <>
 209                            (case argTy of
 210                                VarArgs   -> text ", ..."
 211                                FixedArgs -> empty)
 212                 fnty = space <> lparen <> ppArgTy <> rparen <> text "*"
 213                 attrDoc = ppSpaceJoin attrs
 214             in  tc <> text "call" <+> texts cc <+> texts ret
 215                     <> fnty <+> (text $ getName fptr) <> lparen <+> ppValues
 216                     <+> rparen <+> attrDoc
 217
 218
 219 ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> Doc
 220 ppMachOp op left right =
 221   (texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
 222         <> comma <+> (text $ getName right)
 223
 224
 225 ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc
 226 ppCmpOp op left right =
 227   let cmpOp
 228         | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
 229         | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
 230         | otherwise = text "icmp" -- Just continue as its much easier to debug
 231         {-
 232         | otherwise = error ("can't compare different types, left = "
 233                 ++ (show $ getVarType left) ++ ", right = "
 234                 ++ (show $ getVarType right))
 235         -}
 236   in cmpOp <+> texts op <+> texts (getVarType left)
 237         <+> (text $ getName left) <> comma <+> (text $ getName right)
 238
 239
 240 ppAssignment :: LlvmVar -> Doc -> Doc
 241 ppAssignment var expr = (text $ getName var) <+> equals <+> expr
 242
 243
 244 ppLoad :: LlvmVar -> Doc
 245 ppLoad var = text "load" <+> texts var
 246
 247
 248 ppStore :: LlvmVar -> LlvmVar -> Doc
 249 ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
 250
 251
 252 ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
 253 ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
 254
 255
 256 ppMalloc :: LlvmType -> Int -> Doc
 257 ppMalloc tp amount =
 258   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
 259   in text "malloc" <+> texts tp <> comma <+> texts amount'
 260
 261
 262 ppAlloca :: LlvmType -> Int -> Doc
 263 ppAlloca tp amount =
 264   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
 265   in text "alloca" <+> texts tp <> comma <+> texts amount'
 266
 267
 268 ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> Doc
 269 ppGetElementPtr inb ptr idx =
 270   let indexes = comma <+> ppCommaJoin idx
 271       inbound = if inb then text "inbounds" else empty
 272   in text "getelementptr" <+> inbound <+> texts ptr <> indexes
 273
 274
 275 ppReturn :: Maybe LlvmVar -> Doc
 276 ppReturn (Just var) = text "ret" <+> texts var
 277 ppReturn Nothing    = text "ret" <+> texts LMVoid
 278
 279
 280 ppBranch :: LlvmVar -> Doc
 281 ppBranch var = text "br" <+> texts var
 282
 283
 284 ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc
 285 ppBranchIf cond trueT falseT
 286   = text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
 287
 288
 289 ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc
 290 ppPhi tp preds =
 291   let ppPreds (val, label) = brackets $ (text $ getName val) <> comma
 292         <+> (text $ getName label)
 293   in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds)
 294
 295
 296 ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> Doc
 297 ppSwitch scrut dflt targets =
 298   let ppTarget  (val, lab) = texts val <> comma <+> texts lab
 299       ppTargets  xs        = brackets $ vcat (map ppTarget xs)
 300   in text "switch" <+> texts scrut <> comma <+> texts dflt
 301         <+> ppTargets targets
 302
 303
 304 ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> Doc
 305 ppAsm asm constraints rty vars sideeffect alignstack =
 306   let asm'  = doubleQuotes $ ftext asm
 307       cons  = doubleQuotes $ ftext constraints
 308       rty'  = texts rty
 309       vars' = lparen <+> ppCommaJoin vars <+> rparen
 310       side  = if sideeffect then text "sideeffect" else empty
 311       align = if alignstack then text "alignstack" else empty
 312   in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
 313         <+> cons <> vars'
 314
 315
 316 --------------------------------------------------------------------------------
 317 -- * Misc functions
 318 --------------------------------------------------------------------------------
 319 ppCommaJoin :: (Show a) => [a] -> Doc
 320 ppCommaJoin strs = hcat $ intersperse comma (map texts strs)
 321
 322 ppSpaceJoin :: (Show a) => [a] -> Doc
 323 ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
 324
 325 -- | Convert SDoc to Doc
 326 llvmSDoc :: Out.SDoc -> Doc
 327 llvmSDoc d
 328         = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
 329
 330 -- | Showable to Doc
 331 texts :: (Show a) => a -> Doc
 332 texts = (text . show)
 333