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