Rework LLVM metadata representation to be more accurate.

8 files changed, 168 insertions, 85 deletions

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 90a241f8d4..0ef28906e7 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -139,6 +139,7 @@ Library
         Literal
         Llvm
         Llvm.AbsSyn
+        Llvm.MetaData
         Llvm.PpLlvm
         Llvm.Types
         LlvmCodeGen
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index d69b88ce23..32bd35b8e1 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -38,7 +38,7 @@ module Llvm (
         i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
 
         -- ** Metadata types
-        LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData,
+        MetaExpr(..), MetaVal(..), MetaData, MetaDecl(..),
 
         -- ** Operations on the type system.
         isGlobal, getLitType, getLit, getName, getPlainName, getVarType,
@@ -53,6 +53,7 @@ module Llvm (
     ) where
 
 import Llvm.AbsSyn
+import Llvm.MetaData
 import Llvm.PpLlvm
 import Llvm.Types
 
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 1dcd8580c9..00abb71b8c 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -4,6 +4,7 @@
 
 module Llvm.AbsSyn where
 
+import Llvm.MetaData
 import Llvm.Types
 
 import Unique
@@ -32,7 +33,7 @@ data LlvmModule = LlvmModule  {
     modAliases   :: [LlvmAlias],
 
     -- | LLVM meta data.
-    modMeta      :: [LlvmMeta],
+    modMeta      :: [MetaDecl],
 
     -- | Global variables to include in the module.
     modGlobals   :: [LMGlobal],
@@ -169,8 +170,6 @@ data LlvmStatement
 
   deriving (Show, Eq)
 
-type MetaData = (LMString, LlvmMetaUnamed)
-
 
 -- | Llvm Expressions
 data LlvmExpression
@@ -278,7 +277,7 @@ data LlvmExpression
   {- |
     A LLVM expression with metadata attached to it.
   -}
-  | MetaExpr [MetaData] LlvmExpression
+  | MExpr [MetaData] LlvmExpression
 
   deriving (Show, Eq)
 
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
new file mode 100644
index 0000000000..92e8ecdeb4
--- /dev/null
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -0,0 +1,117 @@
+--------------------------------------------------------------------------------
+-- | The LLVM Metadata System.
+--
+-- The LLVM metadata feature is poorly documented but roughly follows the
+-- following design:
+-- * Metadata can be constructed in a few different ways (See below).
+-- * After which it can either be attached to LLVM statements to pass along
+-- extra information to the optimizer and code generator OR specificially named
+-- metadata has an affect on the whole module (i.e., linking behaviour).
+--
+--
+-- # Constructing metadata
+-- Metadata comes largely in three forms:
+--
+-- * Metadata expressions -- these are the raw metadata values that encode
+--   information. They consist of metadata strings, metadata nodes, regular
+--   LLVM values (both literals and references to global variables) and
+--   metadata expressions (i.e., recursive data type). Some examples:
+--     !{ metadata !"hello", metadata !0, i32 0 }
+--     !{ metadata !1, metadata !{ i32 0 } }
+--
+-- * Metadata nodes -- global metadata variables that attach a metadata
+--   expression to a number. For example:
+--     !0 = metadata !{ [<metadata expressions>] !}
+--
+-- * Named metadata -- global metadata variables that attach a metadata nodes
+--   to a name. Used ONLY to communicated module level information to LLVM
+--   through a meaningful name. For example:
+--     !llvm.module.linkage = !{ !0, !1 }
+--
+--
+-- # Using Metadata
+-- Using metadata depends on the form it is in:
+--
+-- * Attach to instructions -- metadata can be attached to LLVM instructions
+--   using a specific reference as follows:
+--     %l = load i32* @glob, !nontemporal !10
+--     %m = load i32* @glob, !nontemporal !{ i32 0, metadata !{ i32 0 } }
+--   Only metadata nodes or expressions can be attached, named metadata cannot.
+--   Refer to LLVM documentation for which instructions take metadata and its
+--   meaning.
+--
+-- * As arguments -- llvm functions can take metadata as arguments, for
+--   example:
+--     call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1)
+--   As with instructions, only metadata nodes or expressions can be attached.
+--
+-- * As a named metadata -- Here the metadata is simply declared in global
+--   scope using a specific name to communicate module level information to LLVM.
+--   For example:
+--     !llvm.module.linkage = !{ !0, !1 }
+--
+module Llvm.MetaData where
+
+import Data.List (intercalate)
+
+import Llvm.Types
+
+import FastString
+
+-- | LLVM metadata expressions ('metadata ...' form).
+data MetaExpr = MetaStr LMString
+              | MetaNode Int
+              | MetaVar LlvmVar
+              | MetaExpr [MetaExpr]
+              deriving (Eq)
+
+-- | LLVM metadata nodes. See [Note: Metadata encoding].
+data MetaVal
+    -- | A literal expression as a metadata value ('!{ ..}' form).
+    = MetaValExpr MetaExpr
+    -- | A metadata node as a metadata value ('!10' form).
+    | MetaValNode Int
+    deriving (Eq)
+
+-- | Associated some metadata with a specific label for attaching to an
+-- instruction.
+type MetaData = (LMString, MetaVal)
+
+-- | Metadata declarations. Metadata can only be declared in global scope.
+data MetaDecl
+    -- | Named metadata. Only used for communicating module information to
+    -- LLVM. ('!name = !{ [!<n>] }' form).
+    = MetaNamed LMString [Int]
+    -- | Metadata node declaration.
+    -- ('!0 = metadata !{ <metadata expression> }' form).
+    | MetaUnamed Int MetaExpr
+
+instance Show MetaExpr where
+  show (MetaStr  s ) = "metadata !\"" ++ unpackFS s ++ "\""
+  show (MetaNode n ) = "metadata !" ++ show n
+  show (MetaVar  v ) = show v
+  show (MetaExpr es) = intercalate ", " $ map show es
+
+instance Show MetaVal where
+  show (MetaValExpr  e) = "!{ " ++ show e ++ "}"
+  show (MetaValNode  n) = "!" ++ show n
+
+{-
+   Note: Metadata encoding
+   ~~~~~~~~~~~~~~~~~~~~~~~
+   The encoding use today has some redundancy in the form of 'MetaValNode'.
+   Instead of the current encoding where MetaExpr is an independent recursive
+   type, the encoding below could be used where MetaExpr and MetaVal are
+   co-recursive. The current encoding was chosen instead as it appears easier
+   to work with and cleaner to separate the two types.
+
+   -- metadata ...
+   data MetaExpr = MetaStr String
+                 | MetaVar LlvmVar
+                 | MetaVal [MetaVal]
+
+   -- !{ .. } | !10
+   data MetaVal = MetaExpr MetaExpr
+                | MetaNode Int
+ -}
+
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index a709a05b7d..33f31fcde1 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -24,6 +24,7 @@ module Llvm.PpLlvm (
 #include "HsVersions.h"
 
 import Llvm.AbsSyn
+import Llvm.MetaData
 import Llvm.Types
 
 import Data.List ( intersperse )
@@ -91,28 +92,27 @@ ppLlvmAlias (name, ty)
 
 
 -- | Print out a list of LLVM metadata.
-ppLlvmMetas :: [LlvmMeta] -> SDoc
+ppLlvmMetas :: [MetaDecl] -> SDoc
 ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
 
 -- | Print out an LLVM metadata definition.
-ppLlvmMeta :: LlvmMeta -> SDoc
-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 "}"
+ppLlvmMeta :: MetaDecl -> SDoc
+ppLlvmMeta (MetaUnamed n m)
+  = exclamation <> int n <> text " = metadata !" <> braces (ppLlvmMetaExpr m)
+
+ppLlvmMeta (MetaNamed n m)
+  = exclamation <> ftext n <> text " = !" <> braces nodes
   where
-    munq = map (\(LMMetaUnamed u) -> u) metas
+    nodes = hcat $ intersperse comma $ map pprNode m
     pprNode n = exclamation <> int n
 
 -- | Print out an LLVM metadata value.
-ppLlvmMetaVal :: LlvmMetaVal -> SDoc
-ppLlvmMetaVal (MetaStr  s) = text "metadata !" <> doubleQuotes (ftext s)
-ppLlvmMetaVal (MetaVar  v) = texts v
-ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
-  = text "metadata !" <> int u
+ppLlvmMetaExpr :: MetaExpr -> SDoc
+ppLlvmMetaExpr (MetaStr  s ) = text "metadata !" <> doubleQuotes (ftext s)
+ppLlvmMetaExpr (MetaNode n ) = text "metadata !" <> int n
+ppLlvmMetaExpr (MetaVar  v ) = texts v
+ppLlvmMetaExpr (MetaExpr es) =
+    hcat $ intersperse (text ", ") $ map ppLlvmMetaExpr es
 
 
 -- | Print out a list of function definitions.
@@ -237,7 +237,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
+        MExpr      meta expr        -> ppMetaExpr meta expr
 
 
 --------------------------------------------------------------------------------
@@ -417,18 +417,20 @@ ppInsert vec elt idx =
     <+> texts (getVarType elt) <+> text (getName elt) <> comma
     <+> texts idx
 
+
 ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc
 ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta
 
-
 ppMetaExpr :: [MetaData] -> LlvmExpression -> SDoc
 ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta
 
-
 ppMetas :: [MetaData] -> SDoc
 ppMetas meta = hcat $ map ppMeta meta
   where
-    ppMeta (name, (LMMetaUnamed n))
+    ppMeta (name, MetaValExpr e)
+        = comma <+> exclamation <> ftext name <+> text "!" <>
+            braces (ppLlvmMetaExpr e)
+    ppMeta (name, MetaValNode n)
         = comma <+> exclamation <> ftext name <+> exclamation <> int n
 
 
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index 8b33c0b9dd..f6385b1189 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -76,43 +76,6 @@ 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
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index d7ddbdd027..d4bfaa3030 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -1320,7 +1320,7 @@ genLoad_fast env e r n ty =
                 case grt == ty' of
                      -- were fine
                      True -> do
-                         (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr)
+                         (var, s3) <- doExpr ty' (MExpr meta $ Load ptr)
                          return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
                                      [])
 
@@ -1328,7 +1328,7 @@ genLoad_fast env e r n ty =
                      False -> do
                          let pty = pLift ty'
                          (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
-                         (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr')
+                         (var, s4) <- doExpr ty' (MExpr meta $ Load ptr')
                          return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
                                     `snocOL` s4, [])
 
@@ -1345,14 +1345,14 @@ genLoad_slow env e ty meta = do
     case getVarType iptr of
          LMPointer _ -> do
                     (dvar, load) <- doExpr (cmmToLlvmType ty)
-                                           (MetaExpr meta $ Load iptr)
+                                           (MExpr meta $ Load iptr)
                     return (env', dvar, stmts `snocOL` load, tops)
 
          i@(LMInt _) | i == llvmWord dflags -> do
                     let pty = LMPointer $ cmmToLlvmType ty
                     (ptr, cast)  <- doExpr pty $ Cast LM_Inttoptr iptr pty
                     (dvar, load) <- doExpr (cmmToLlvmType ty)
-                                           (MetaExpr meta $ Load ptr)
+                                           (MExpr meta $ Load ptr)
                     return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
 
          other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
index 7271c2f3d9..3d9c4b4820 100644
--- a/compiler/llvmGen/LlvmCodeGen/Regs.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -77,37 +77,37 @@ alwaysLive :: [GlobalReg]
 alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]
 
 -- | STG Type Based Alias Analysis metadata
-stgTBAA :: [LlvmMeta]
+stgTBAA :: [MetaDecl]
 stgTBAA
-  = [ MetaUnamed topN   [MetaStr (fsLit "top")]
-    , MetaUnamed stackN [MetaStr (fsLit "stack"), MetaNode topN]
-    , MetaUnamed heapN  [MetaStr (fsLit "heap"),  MetaNode topN]
-    , MetaUnamed rxN    [MetaStr (fsLit "rx"),    MetaNode heapN]
-    , MetaUnamed baseN  [MetaStr (fsLit "base"),  MetaNode topN]
+  = [ MetaUnamed topN   $ MetaStr (fsLit "top")
+    , MetaUnamed stackN $ MetaExpr [MetaStr (fsLit "stack"), MetaNode topN]
+    , MetaUnamed heapN  $ MetaExpr [MetaStr (fsLit "heap"),  MetaNode topN]
+    , MetaUnamed rxN    $ MetaExpr [MetaStr (fsLit "rx"),    MetaNode heapN]
+    , MetaUnamed baseN  $ MetaExpr [MetaStr (fsLit "base"),  MetaNode topN]
     -- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'.
     -- OR I think the big thing is Sp is never aliased, so might want
     -- to change the hieracy to have Sp on its own branch that is never
     -- aliased (e.g never use top as a TBAA node).
-    , MetaUnamed otherN [MetaStr (fsLit "other"), MetaNode topN]
+    , MetaUnamed otherN $ MetaExpr [MetaStr (fsLit "other"), MetaNode topN]
     ]
 
 -- | Id values
-topN, stackN, heapN, rxN, baseN, otherN:: LlvmMetaUnamed
-topN   = LMMetaUnamed 0
-stackN = LMMetaUnamed 1
-heapN  = LMMetaUnamed 2
-rxN    = LMMetaUnamed 3
-baseN  = LMMetaUnamed 4
-otherN = LMMetaUnamed 5
+topN, stackN, heapN, rxN, baseN, otherN:: Int
+topN   = 0
+stackN = 1
+heapN  = 2
+rxN    = 3
+baseN  = 4
+otherN = 5
 
 -- | The various TBAA types
 top, heap, stack, rx, base, other :: MetaData
-top   = (tbaa, topN)
-heap  = (tbaa, heapN)
-stack = (tbaa, stackN)
-rx    = (tbaa, rxN)
-base  = (tbaa, baseN)
-other = (tbaa, otherN)
+top   = (tbaa, MetaValNode topN)
+heap  = (tbaa, MetaValNode heapN)
+stack = (tbaa, MetaValNode stackN)
+rx    = (tbaa, MetaValNode rxN)
+base  = (tbaa, MetaValNode baseN)
+other = (tbaa, MetaValNode otherN)
 
 -- | The TBAA metadata identifier
 tbaa :: LMString