Commit 4a0eb925 authored by dterei's avatar dterei
Browse files

Improve style of '-ddump-llvm' output. (#5750)

parent a63c4237
...@@ -39,14 +39,10 @@ import Unique ...@@ -39,14 +39,10 @@ import Unique
-- | Print out a whole LLVM module. -- | Print out a whole LLVM module.
ppLlvmModule :: LlvmModule -> Doc ppLlvmModule :: LlvmModule -> Doc
ppLlvmModule (LlvmModule comments aliases globals decls funcs) ppLlvmModule (LlvmModule comments aliases globals decls funcs)
= ppLlvmComments comments = ppLlvmComments comments $+$ newLine
$+$ empty $+$ ppLlvmAliases aliases $+$ newLine
$+$ ppLlvmAliases aliases $+$ ppLlvmGlobals globals $+$ newLine
$+$ empty $+$ ppLlvmFunctionDecls decls $+$ newLine
$+$ ppLlvmGlobals globals
$+$ empty
$+$ ppLlvmFunctionDecls decls
$+$ empty
$+$ ppLlvmFunctions funcs $+$ ppLlvmFunctions funcs
-- | Print out a multi-line comment, can be inside a function or on its own -- | Print out a multi-line comment, can be inside a function or on its own
...@@ -80,6 +76,7 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = ...@@ -80,6 +76,7 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
const' = if c then text "constant" else text "global" const' = if c then text "constant" else text "global"
in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align
$+$ newLine
ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
...@@ -90,7 +87,8 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys ...@@ -90,7 +87,8 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
-- | Print out an LLVM type alias. -- | Print out an LLVM type alias.
ppLlvmAlias :: LlvmAlias -> Doc 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 $+$ newLine
-- | Print out a list of function definitions. -- | Print out a list of function definitions.
...@@ -109,6 +107,8 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) = ...@@ -109,6 +107,8 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) =
$+$ lbrace $+$ lbrace
$+$ ppLlvmBlocks body $+$ ppLlvmBlocks body
$+$ rbrace $+$ rbrace
$+$ newLine
$+$ newLine
-- | Print out a function defenition header. -- | Print out a function defenition header.
ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc
...@@ -126,7 +126,6 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args ...@@ -126,7 +126,6 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <>
(hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align
-- | Print out a list of function declaration. -- | Print out a list of function declaration.
ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
...@@ -146,7 +145,7 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) ...@@ -146,7 +145,7 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
args = hcat $ intersperse (comma <> space) $ args = hcat $ intersperse (comma <> space) $
map (\(t,a) -> texts t <+> ppSpaceJoin a) p map (\(t,a) -> texts t <+> ppSpaceJoin a) p
in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <> 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. -- | Print out a list of LLVM blocks.
...@@ -157,9 +156,21 @@ ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks ...@@ -157,9 +156,21 @@ ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
-- It must be part of a function definition. -- It must be part of a function definition.
ppLlvmBlock :: LlvmBlock -> Doc ppLlvmBlock :: LlvmBlock -> Doc
ppLlvmBlock (LlvmBlock blockId stmts) ppLlvmBlock (LlvmBlock blockId stmts)
= ppLlvmStatement (MkLabel blockId) = go blockId stmts
$+$ nest 4 (vcat $ map ppLlvmStatement 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
$+$ nest 4 (vcat $ map ppLlvmStatement block)
$+$ newLine
$+$ ppRest
-- | Print out an LLVM statement. -- | Print out an LLVM statement.
ppLlvmStatement :: LlvmStatement -> Doc ppLlvmStatement :: LlvmStatement -> Doc
...@@ -169,7 +180,7 @@ ppLlvmStatement stmt ...@@ -169,7 +180,7 @@ ppLlvmStatement stmt
Branch target -> ppBranch target Branch target -> ppBranch target
BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF
Comment comments -> ppLlvmComments comments Comment comments -> ppLlvmComments comments
MkLabel label -> (llvmSDoc $ pprUnique label) <> colon MkLabel label -> ppLlvmBlockLabel label
Store value ptr -> ppStore value ptr Store value ptr -> ppStore value ptr
Switch scrut def tgs -> ppSwitch scrut def tgs Switch scrut def tgs -> ppSwitch scrut def tgs
Return result -> ppReturn result Return result -> ppReturn result
...@@ -177,6 +188,9 @@ ppLlvmStatement stmt ...@@ -177,6 +188,9 @@ ppLlvmStatement stmt
Unreachable -> text "unreachable" Unreachable -> text "unreachable"
Nop -> empty Nop -> empty
-- | Print out an LLVM block label.
ppLlvmBlockLabel :: LlvmBlockId -> Doc
ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon
-- | Print out an LLVM expression. -- | Print out an LLVM expression.
ppLlvmExpression :: LlvmExpression -> Doc ppLlvmExpression :: LlvmExpression -> Doc
...@@ -344,3 +358,7 @@ llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d ...@@ -344,3 +358,7 @@ llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
texts :: (Show a) => a -> Doc texts :: (Show a) => a -> Doc
texts = (text . show) texts = (text . show)
-- | Blank line.
newLine :: Doc
newLine = text ""
...@@ -48,6 +48,7 @@ llvmCodeGen dflags h us cmms ...@@ -48,6 +48,7 @@ llvmCodeGen dflags h us cmms
in do in do
showPass dflags "LlVM CodeGen" showPass dflags "LlVM CodeGen"
bufh <- newBufHandle h bufh <- newBufHandle h
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc pprLlvmHeader
Prt.bufLeftRender bufh $ pprLlvmHeader Prt.bufLeftRender bufh $ pprLlvmHeader
ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
env' <- {-# SCC "llvm_datas_gen" #-} env' <- {-# SCC "llvm_datas_gen" #-}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment