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