1 --------------------------------------------------------------------------------
2 -- | Pretty print LLVM IR Code.
7 -- * Top level LLVM objects.
25 #include "HsVersions.h"
30 import Data.List ( intersperse )
32 import qualified Outputable as Outp
35 --------------------------------------------------------------------------------
36 -- * Top Level Print functions
37 --------------------------------------------------------------------------------
39 -- | Print out a whole LLVM module.
40 ppLlvmModule :: LlvmModule -> Doc
41 ppLlvmModule (LlvmModule comments constants globals decls funcs)
42 = ppLlvmComments comments
44 $+$ ppLlvmConstants constants
45 $+$ ppLlvmGlobals globals
47 $+$ ppLlvmFunctionDecls decls
49 $+$ ppLlvmFunctions funcs
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
55 -- | Print out a comment, can be inside a function or on its own
56 ppLlvmComment :: LMString -> Doc
57 ppLlvmComment com = semi <+> (ftext com)
60 -- | Print out a list of global mutable variable definitions
61 ppLlvmGlobals :: [LMGlobal] -> Doc
62 ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
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))
70 ppLlvmGlobal (var@(LMGlobalVar _ _ link), (Just stat)) =
71 ppAssignment var $ text (show link) <+> text "global" <+> text (show stat)
73 ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
76 -- | Print out a list global constant variable
77 ppLlvmConstants :: [LMConstant] -> Doc
78 ppLlvmConstants cons = vcat $ map ppLlvmConstant cons
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)
85 ppLlvmConstant c = error $ "Non global var as constant! " ++ show c
88 -- | Print out a list of LLVM type aliases.
89 ppLlvmTypes :: [LlvmType] -> Doc
90 ppLlvmTypes tys = vcat $ map ppLlvmType tys
92 -- | Print out an LLVM type alias.
93 ppLlvmType :: LlvmType -> Doc
95 ppLlvmType al@(LMAlias _ t)
96 = (text $ show al) <+> equals <+> (text "type") <+> (text $ show t)
98 ppLlvmType (LMFunction t)
99 = ppLlvmFunctionDecl t
104 -- | Print out a list of function definitions.
105 ppLlvmFunctions :: LlvmFunctions -> Doc
106 ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
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)
115 $+$ ppLlvmBlocks body
119 -- | Print out a list of function declaration.
120 ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
121 ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
123 -- | Print out a function declaration.
124 -- Declarations define the function type but don't define the actual body of
126 ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
127 ppLlvmFunctionDecl dec = (text "declare") <+> ppLlvmFuncDecSig dec
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 <>
139 VarArgs -> (text ", ...")
141 in linkDoc <> (text $ show cc) <+> (text $ show retTy)
142 <+> atsym <> (ftext name) <> lparen <+> ppParams <+> rparen
145 -- | Print out a list of LLVM blocks.
146 ppLlvmBlocks :: LlvmBlocks -> Doc
147 ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
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)
157 -- | Print out an LLVM statement.
158 ppLlvmStatement :: LlvmStatement -> Doc
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"
173 -- | Print out an LLVM expression.
174 ppLlvmExpression :: LlvmExpression -> Doc
175 ppLlvmExpression expr
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
188 --------------------------------------------------------------------------------
189 -- * Individual print functions
190 --------------------------------------------------------------------------------
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
197 -- if local var function pointer, unwrap
198 LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
200 -- should be function type otherwise
201 LMGlobalVar _ (LMFunction d) _ -> ppCall' d
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."
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 <>
214 VarArgs -> (text ", ...")
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
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)
229 ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc
230 ppCmpOp op left right =
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)
241 ppAssignment :: LlvmVar -> Doc -> Doc
242 ppAssignment var expr = (text $ getName var) <+> equals <+> expr
245 ppLoad :: LlvmVar -> Doc
246 ppLoad var = (text "load") <+> (text $ show var)
249 ppStore :: LlvmVar -> LlvmVar -> Doc
251 (text "store") <+> (text $ show val) <> comma <+> (text $ show dst)
254 ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
256 let castOp = text $ show op
257 in castOp <+> (text $ show from) <+> (text "to") <+> (text $ show to)
260 ppMalloc :: LlvmType -> Int -> Doc
262 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
263 in (text "malloc") <+> (text $ show tp) <> comma <+> (text $ show amount')
266 ppAlloca :: LlvmType -> Int -> Doc
268 let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
269 in (text "alloca") <+> (text $ show tp) <> comma <+> (text $ show amount')
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
278 ppReturn :: Maybe LlvmVar -> Doc
279 ppReturn (Just var) = (text "ret") <+> (text $ show var)
280 ppReturn Nothing = (text "ret") <+> (text $ show LMVoid)
283 ppBranch :: LlvmVar -> Doc
284 ppBranch var = (text "br") <+> (text $ show var)
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)
293 ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc
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))
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)
309 --------------------------------------------------------------------------------
311 --------------------------------------------------------------------------------
315 ppCommaJoin :: (Show a) => [a] -> Doc
316 ppCommaJoin strs = hcat $ intersperse comma (map (text . show) strs)
318 ppSpaceJoin :: (Show a) => [a] -> Doc
319 ppSpaceJoin strs = hcat $ intersperse space (map (text . show) strs)
321 -- | Convert SDoc to Doc
322 llvmSDoc :: Outp.SDoc -> Doc
324 = Outp.withPprStyleDoc (Outp.mkCodeStyle Outp.CStyle) d