diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 90a241f8d4f4..0ef28906e7b4 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 d69b88ce235e..32bd35b8e140 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 1dcd8580c985..00abb71b8c18 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 000000000000..92e8ecdeb46e --- /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 !{ [] !} +-- +-- * 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 = !{ [!] }' form). + = MetaNamed LMString [Int] + -- | Metadata node declaration. + -- ('!0 = metadata !{ }' 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 a709a05b7d25..33f31fcde139 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 8b33c0b9ddfb..f6385b1189d0 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 d7ddbdd02732..d4bfaa3030f5 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 7271c2f3d9a8..3d9c4b482065 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