LLVM: Add alias type defenitions to LlvmModule.
[ghc.git] / 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
165
166 -- | Print out an LLVM expression.
167 ppLlvmExpression :: LlvmExpression -> Doc
168 ppLlvmExpression expr
169 = case expr of
170 Alloca tp amount -> ppAlloca tp amount
171 LlvmOp op left right -> ppMachOp op left right
172 Call tp fp args attrs -> ppCall tp fp args attrs
173 Cast op from to -> ppCast op from to
174 Compare op left right -> ppCmpOp op left right
175 GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes
176 Load ptr -> ppLoad ptr
177 Malloc tp amount -> ppMalloc tp amount
178 Phi tp precessors -> ppPhi tp precessors
179
180
181 --------------------------------------------------------------------------------
182 -- * Individual print functions
183 --------------------------------------------------------------------------------
184
185 -- | Should always be a function pointer. So a global var of function type
186 -- (since globals are always pointers) or a local var of pointer function type.
187 ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> Doc
188 ppCall ct fptr vals attrs = case fptr of
189 --
190 -- if local var function pointer, unwrap
191 LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
192
193 -- should be function type otherwise
194 LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d
195
196 -- not pointer or function, so error
197 _other -> error $ "ppCall called with non LMFunction type!\nMust be "
198 ++ " called with either global var of function type or "
199 ++ "local var of pointer function type."
200
201 where
202 ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
203 let tc = if ct == TailCall then text "tail " else empty
204 ppValues = ppCommaJoin vals
205 ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params
206 ppArgTy = (hcat $ intersperse comma ppParams) <>
207 (case argTy of
208 VarArgs -> text ", ..."
209 FixedArgs -> empty)
210 fnty = space <> lparen <> ppArgTy <> rparen <> text "*"
211 attrDoc = ppSpaceJoin attrs
212 in tc <> text "call" <+> texts cc <+> texts ret
213 <> fnty <+> (text $ getName fptr) <> lparen <+> ppValues
214 <+> rparen <+> attrDoc
215
216
217 ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> Doc
218 ppMachOp op left right =
219 (texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
220 <> comma <+> (text $ getName right)
221
222
223 ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc
224 ppCmpOp op left right =
225 let cmpOp
226 | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
227 | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
228 | otherwise = text "icmp" -- Just continue as its much easier to debug
229 {-
230 | otherwise = error ("can't compare different types, left = "
231 ++ (show $ getVarType left) ++ ", right = "
232 ++ (show $ getVarType right))
233 -}
234 in cmpOp <+> texts op <+> texts (getVarType left)
235 <+> (text $ getName left) <> comma <+> (text $ getName right)
236
237
238 ppAssignment :: LlvmVar -> Doc -> Doc
239 ppAssignment var expr = (text $ getName var) <+> equals <+> expr
240
241
242 ppLoad :: LlvmVar -> Doc
243 ppLoad var = text "load" <+> texts var
244
245
246 ppStore :: LlvmVar -> LlvmVar -> Doc
247 ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
248
249
250 ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
251 ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
252
253
254 ppMalloc :: LlvmType -> Int -> Doc
255 ppMalloc tp amount =
256 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
257 in text "malloc" <+> texts tp <> comma <+> texts amount'
258
259
260 ppAlloca :: LlvmType -> Int -> Doc
261 ppAlloca tp amount =
262 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
263 in text "alloca" <+> texts tp <> comma <+> texts amount'
264
265
266 ppGetElementPtr :: Bool -> LlvmVar -> [Int] -> Doc
267 ppGetElementPtr inb ptr idx =
268 let indexes = hcat $ map ((comma <+> texts i32 <+>) . texts) idx
269 inbound = if inb then text "inbounds" else empty
270 in text "getelementptr" <+> inbound <+> 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