diff options
Diffstat (limited to 'compiler/llvmGen/Llvm/PpLlvm.hs')
| -rw-r--r-- | compiler/llvmGen/Llvm/PpLlvm.hs | 124 |
1 files changed, 97 insertions, 27 deletions
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 217d02debf..2945777f96 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -10,8 +10,10 @@ module Llvm.PpLlvm ( ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, - ppLlvmAlias, ppLlvmAliases, + ppLlvmAlias, + ppLlvmMetas, + ppLlvmMeta, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, @@ -38,15 +40,12 @@ import Unique -- | Print out a whole LLVM module. ppLlvmModule :: LlvmModule -> Doc -ppLlvmModule (LlvmModule comments aliases globals decls funcs) - = ppLlvmComments comments - $+$ empty - $+$ ppLlvmAliases aliases - $+$ empty - $+$ ppLlvmGlobals globals - $+$ empty - $+$ ppLlvmFunctionDecls decls - $+$ empty +ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) + = ppLlvmComments comments $+$ newLine + $+$ ppLlvmAliases aliases $+$ newLine + $+$ ppLlvmMetas meta $+$ newLine + $+$ ppLlvmGlobals globals $+$ newLine + $+$ ppLlvmFunctionDecls decls $+$ newLine $+$ ppLlvmFunctions funcs -- | Print out a multi-line comment, can be inside a function or on its own @@ -80,6 +79,7 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = const' = if c then text "constant" else text "global" in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align + $+$ newLine ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth @@ -90,7 +90,33 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys -- | Print out an LLVM type alias. ppLlvmAlias :: LlvmAlias -> Doc -ppLlvmAlias (name, ty) = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty +ppLlvmAlias (name, ty) + = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty + + +-- | Print out a list of LLVM metadata. +ppLlvmMetas :: [LlvmMeta] -> Doc +ppLlvmMetas metas = vcat $ map ppLlvmMeta metas + +-- | Print out an LLVM metadata definition. +ppLlvmMeta :: LlvmMeta -> Doc +ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas) + = exclamation <> int u <> text " = metadata !{" <> + hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}" + +ppLlvmMeta (MetaNamed n metas) + = exclamation <> ftext n <> text " = !{" <> + hcat (intersperse comma $ map pprNode munq) <> text "}" + where + munq = map (\(LMMetaUnamed u) -> u) metas + pprNode n = exclamation <> int n + +-- | Print out an LLVM metadata value. +ppLlvmMetaVal :: LlvmMetaVal -> Doc +ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s) +ppLlvmMetaVal (MetaVar v) = texts v +ppLlvmMetaVal (MetaNode (LMMetaUnamed u)) + = text "metadata !" <> int u -- | Print out a list of function definitions. @@ -109,6 +135,8 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) = $+$ lbrace $+$ ppLlvmBlocks body $+$ rbrace + $+$ newLine + $+$ newLine -- | Print out a function defenition header. ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc @@ -126,7 +154,6 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align - -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs @@ -146,7 +173,7 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) args = hcat $ intersperse (comma <> space) $ map (\(t,a) -> texts t <+> ppSpaceJoin a) p in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <> - ftext n <> lparen <> args <> varg' <> rparen <> align + ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine -- | Print out a list of LLVM blocks. @@ -157,25 +184,44 @@ ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks -- It must be part of a function definition. ppLlvmBlock :: LlvmBlock -> Doc ppLlvmBlock (LlvmBlock blockId stmts) - = ppLlvmStatement (MkLabel blockId) - $+$ nest 4 (vcat $ map ppLlvmStatement stmts) + = go blockId stmts + where + lbreak acc [] = (Nothing, reverse acc, []) + lbreak acc (MkLabel id:xs) = (Just id, reverse acc, xs) + lbreak acc (x:xs) = lbreak (x:acc) xs + + go id code = + let (id2, block, rest) = lbreak [] code + ppRest = case id2 of + Just id2' -> go id2' rest + Nothing -> empty + in ppLlvmBlockLabel id + $+$ (vcat $ map ppLlvmStatement block) + $+$ newLine + $+$ ppRest + +-- | Print out an LLVM block label. +ppLlvmBlockLabel :: LlvmBlockId -> Doc +ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon -- | Print out an LLVM statement. ppLlvmStatement :: LlvmStatement -> Doc -ppLlvmStatement stmt - = case stmt of - Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr) - Branch target -> ppBranch target - BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF - Comment comments -> ppLlvmComments comments - MkLabel label -> (llvmSDoc $ pprUnique label) <> colon - Store value ptr -> ppStore value ptr - Switch scrut def tgs -> ppSwitch scrut def tgs - Return result -> ppReturn result - Expr expr -> ppLlvmExpression expr - Unreachable -> text "unreachable" +ppLlvmStatement stmt = + let ind = (text " " <>) + in case stmt of + Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) + Branch target -> ind $ ppBranch target + BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF + Comment comments -> ind $ ppLlvmComments comments + MkLabel label -> ppLlvmBlockLabel label + Store value ptr -> ind $ ppStore value ptr + Switch scrut def tgs -> ind $ ppSwitch scrut def tgs + Return result -> ind $ ppReturn result + Expr expr -> ind $ ppLlvmExpression expr + Unreachable -> ind $ text "unreachable" Nop -> empty + MetaStmt meta s -> ppMetaStatement meta s -- | Print out an LLVM expression. @@ -192,6 +238,7 @@ ppLlvmExpression expr Malloc tp amount -> ppMalloc tp amount Phi tp precessors -> ppPhi tp precessors Asm asm c ty v se sk -> ppAsm asm c ty v se sk + MetaExpr meta expr -> ppMetaExpr meta expr -------------------------------------------------------------------------------- @@ -327,6 +374,21 @@ ppAsm asm constraints rty vars sideeffect alignstack = <+> cons <> vars' +ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc +ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta + + +ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc +ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta + + +ppMetas :: [MetaData] -> Doc +ppMetas meta = hcat $ map ppMeta meta + where + ppMeta (name, (LMMetaUnamed n)) + = comma <+> exclamation <> ftext name <+> exclamation <> int n + + -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- @@ -344,3 +406,11 @@ llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d texts :: (Show a) => a -> Doc texts = (text . show) +-- | Blank line. +newLine :: Doc +newLine = text "" + +-- | Exclamation point. +exclamation :: Doc +exclamation = text "!" + |