Add Metadata support to LLVM bindings.

4 files changed, 114 insertions, 7 deletions

diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index aec492e151..b15b6f261d 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 93bc62c91f..a28734b152 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 ff701eb287..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,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 101342606d..07e53fb731 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