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