Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/0f15f8a76d334becf992a83870d0b327cc3c40b6 >--------------------------------------------------------------- commit 0f15f8a76d334becf992a83870d0b327cc3c40b6 Author: David Terei <[email protected]> Date: Wed Jan 11 18:49:22 2012 -0800 Add Metadata support to LLVM bindings. >--------------------------------------------------------------- compiler/llvmGen/Llvm.hs | 6 +++- compiler/llvmGen/Llvm/AbsSyn.hs | 15 +++++++++ compiler/llvmGen/Llvm/PpLlvm.hs | 61 +++++++++++++++++++++++++++++++++++--- compiler/llvmGen/Llvm/Types.hs | 39 ++++++++++++++++++++++++- 4 files changed, 114 insertions(+), 7 deletions(-) diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index aec492e..b15b6f2 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -34,6 +34,9 @@ module Llvm ( -- ** Some basic types i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, + -- ** Metadata types + LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData, + -- ** Operations on the type system. isGlobal, getLitType, getLit, getName, getPlainName, getVarType, getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower, @@ -42,7 +45,8 @@ module Llvm ( -- * Pretty Printing ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, - ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, llvmSDoc + ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, + llvmSDoc ) where diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index 93bc62c..a28734b 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -31,6 +31,9 @@ data LlvmModule = LlvmModule { -- | LLVM Alias type definitions. modAliases :: [LlvmAlias], + -- | LLVM meta data. + modMeta :: [LlvmMeta], + -- | Global variables to include in the module. modGlobals :: [LMGlobal], @@ -138,8 +141,15 @@ data LlvmStatement -} | Nop + {- | + A LLVM statement with metadata attached to it. + -} + | MetaStmt [MetaData] LlvmStatement + deriving (Show, Eq) +type MetaData = (LMString, LlvmMetaUnamed) + -- | Llvm Expressions data LlvmExpression @@ -229,5 +239,10 @@ data LlvmExpression -} | Asm LMString LMString LlvmType [LlvmVar] Bool Bool + {- | + A LLVM expression with metadata attached to it. + -} + | MetaExpr [MetaData] LlvmExpression + deriving (Show, Eq) diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index ff701eb..2945777 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,9 +40,10 @@ import Unique -- | Print out a whole LLVM module. ppLlvmModule :: LlvmModule -> Doc -ppLlvmModule (LlvmModule comments aliases globals decls funcs) +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 @@ -91,6 +94,31 @@ 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. ppLlvmFunctions :: LlvmFunctions -> Doc ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs @@ -172,6 +200,11 @@ ppLlvmBlock (LlvmBlock blockId stmts) $+$ 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 = @@ -188,10 +221,8 @@ ppLlvmStatement stmt = Expr expr -> ind $ ppLlvmExpression expr Unreachable -> ind $ text "unreachable" Nop -> empty + MetaStmt meta s -> ppMetaStatement meta s --- | Print out an LLVM block label. -ppLlvmBlockLabel :: LlvmBlockId -> Doc -ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon -- | Print out an LLVM expression. ppLlvmExpression :: LlvmExpression -> Doc @@ -207,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 -------------------------------------------------------------------------------- @@ -342,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 -------------------------------------------------------------------------------- @@ -363,3 +410,7 @@ texts = (text . show) newLine :: Doc newLine = text "" +-- | Exclamation point. +exclamation :: Doc +exclamation = text "!" + diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 1013426..07e53fb 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -70,12 +70,49 @@ instance Show LlvmType where show (LMAlias (s,_)) = "%" ++ unpackFS s +-- | LLVM metadata values. Used for representing debug and optimization +-- information. +data LlvmMetaVal + -- | Metadata string + = MetaStr LMString + -- | Metadata node + | MetaNode LlvmMetaUnamed + -- | Normal value type as metadata + | MetaVar LlvmVar + deriving (Eq) + +-- | LLVM metadata nodes. +data LlvmMeta + -- | Unamed metadata + = MetaUnamed LlvmMetaUnamed [LlvmMetaVal] + -- | Named metadata + | MetaNamed LMString [LlvmMetaUnamed] + deriving (Eq) + +-- | Unamed metadata variable. +newtype LlvmMetaUnamed = LMMetaUnamed Int + +instance Eq LlvmMetaUnamed where + (==) (LMMetaUnamed n) (LMMetaUnamed m) = n == m + +instance Show LlvmMetaVal where + show (MetaStr s) = "metadata !\"" ++ unpackFS s ++ "\"" + show (MetaNode n) = "metadata " ++ show n + show (MetaVar v) = show v + +instance Show LlvmMetaUnamed where + show (LMMetaUnamed u) = "!" ++ show u + +instance Show LlvmMeta where + show (MetaUnamed m _) = show m + show (MetaNamed m _) = "!" ++ unpackFS m + -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString type LMAlign = Maybe Int type LMConst = Bool -- ^ is a variable constant or not --- | Llvm Variables +-- | LLVM Variables data LlvmVar -- | Variables with a global scope. = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
