diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index b5892c17d25b..04f810d36952 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -25,7 +25,7 @@ module Llvm ( -- * Call Handling LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..), - LlvmLinkageType(..), LlvmFuncAttr(..), MetaArgs(..), + LlvmLinkageType(..), LlvmFuncAttr(..), -- * Operations and Comparisons LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..), @@ -38,7 +38,7 @@ module Llvm ( i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, -- ** Metadata types - MetaExpr(..), MetaVal(..), MetaData, MetaDecl(..), + MetaExpr(..), MetaAnnot(..), MetaDecl(..), -- ** Operations on the type system. isGlobal, getLitType, getLit, getName, getPlainName, getVarType, diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index 6163fc842cd0..f92bd89c5cd6 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -65,16 +65,6 @@ data LlvmFunction = LlvmFunction { type LlvmFunctions = [LlvmFunction] --- | LLVM function call arguments. -data MetaArgs - = ArgVar LlvmVar -- ^ Regular LLVM variable as argument. - | ArgMeta MetaExpr -- ^ Metadata as argument. - deriving (Eq) - -instance Show MetaArgs where - show (ArgVar v) = show v - show (ArgMeta m) = show m - -- | LLVM ordering types for synchronization purposes. (Introduced in LLVM -- 3.0). Please see the LLVM documentation for a better description. data LlvmSyncOrdering @@ -176,9 +166,9 @@ data LlvmStatement {- | A LLVM statement with metadata attached to it. -} - | MetaStmt [MetaData] LlvmStatement + | MetaStmt [MetaAnnot] LlvmStatement - deriving (Show, Eq) + deriving (Eq) -- | Llvm Expressions @@ -270,7 +260,7 @@ data LlvmExpression * attrs: A list of function attributes for the call. Only NoReturn, NoUnwind, ReadOnly and ReadNone are valid here. -} - | CallM LlvmCallType LlvmVar [MetaArgs] [LlvmFuncAttr] + | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr] {- | Merge variables from different basic blocks which are predecessors of this @@ -298,7 +288,7 @@ data LlvmExpression {- | A LLVM expression with metadata attached to it. -} - | MExpr [MetaData] LlvmExpression + | MExpr [MetaAnnot] LlvmExpression - deriving (Show, Eq) + deriving (Eq) diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs index 0471e59358b8..b81bd8f6e521 100644 --- a/compiler/llvmGen/Llvm/MetaData.hs +++ b/compiler/llvmGen/Llvm/MetaData.hs @@ -58,34 +58,23 @@ import Llvm.Types import FastString --- | LLVM metadata expressions ('metadata ...' form). +-- | LLVM metadata expressions data MetaExpr = MetaStr LMString | MetaNode Int | MetaVar LlvmVar - | MetaExpr [MetaExpr] + | MetaStruct [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) - 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 + show (MetaStr s ) = "metadata !\"" ++ unpackFS s ++ "\"" + show (MetaNode n ) = "metadata !" ++ show n + show (MetaVar v ) = show v + show (MetaStruct es) = "metadata !{ " ++ intercalate ", " (map show es) ++ "}" --- | Associated some metadata with a specific label for attaching to an +-- | Associates some metadata with a specific label for attaching to an -- instruction. -type MetaData = (LMString, MetaVal) +data MetaAnnot = MetaAnnot LMString MetaExpr + deriving (Eq) -- | Metadata declarations. Metadata can only be declared in global scope. data MetaDecl @@ -95,33 +84,3 @@ data MetaDecl -- | Metadata node declaration. -- ('!0 = metadata !{ }' form). | MetaUnamed Int MetaExpr - --- | LLVM function call arguments. -data MetaArgs - = ArgVar LlvmVar -- ^ Regular LLVM variable as argument. - | ArgMeta MetaExpr -- ^ Metadata as argument. - deriving (Eq) - -instance Show MetaArgs where - show (ArgVar v) = show v - show (ArgMeta m) = show m - -{- - 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 3e86cee085c0..b43e44df5234 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -108,11 +108,11 @@ ppLlvmMeta (MetaNamed n m) -- | Print out an LLVM metadata value. 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 +ppLlvmMetaExpr (MetaStr s ) = text "metadata !" <> doubleQuotes (ftext s) +ppLlvmMetaExpr (MetaNode n ) = text "metadata !" <> int n +ppLlvmMetaExpr (MetaVar v ) = texts v +ppLlvmMetaExpr (MetaStruct es) = + text "metadata !{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}' -- | Print out a list of function definitions. @@ -419,20 +419,21 @@ ppInsert vec elt idx = <+> texts idx -ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc -ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta +ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc +ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta -ppMetaExpr :: [MetaData] -> LlvmExpression -> SDoc -ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta +ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc +ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta -ppMetas :: [MetaData] -> SDoc -ppMetas meta = hcat $ map ppMeta meta +ppMetaAnnots :: [MetaAnnot] -> SDoc +ppMetaAnnots meta = hcat $ map ppMeta meta where - ppMeta (name, MetaValExpr e) - = comma <+> exclamation <> ftext name <+> text "!" <> - braces (ppLlvmMetaExpr e) - ppMeta (name, MetaValNode n) - = comma <+> exclamation <> ftext name <+> exclamation <> int n + ppMeta (MetaAnnot name e) + = comma <+> exclamation <> ftext name <+> + case e of + MetaNode n -> exclamation <> int n + MetaStruct ms -> exclamation <> braces (ppCommaJoin ms) + other -> exclamation <> braces (texts other) -- possible? -------------------------------------------------------------------------------- diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index fe77d7580cd9..01c16fa1ad4a 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -324,6 +324,7 @@ llvmWidthInBits _ LMVoid = 0 llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys llvmWidthInBits _ (LMFunction _) = 0 llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t +llvmWidthInBits _ LMMetadata = panic "llvmWidthInBits: Meta-data has no runtime representation!" -- ----------------------------------------------------------------------------- diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index d4bfaa3030f5..bf3b4fefa6f7 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -691,7 +691,7 @@ genStore_fast env addr r n val -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData +genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaAnnot] -> UniqSM StmtData genStore_slow env addr val meta = do (env1, vaddr, stmts1, top1) <- exprToVar env addr (env2, vval, stmts2, top2) <- exprToVar env1 val @@ -1339,7 +1339,7 @@ genLoad_fast env e r n ty = -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData +genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaAnnot] -> UniqSM ExprData genLoad_slow env e ty meta = do (env', iptr, stmts, tops) <- exprToVar env e case getVarType iptr of diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index 3d9c4b482065..dad355d8c50c 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -80,15 +80,15 @@ alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] stgTBAA :: [MetaDecl] stgTBAA = [ 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] + , MetaUnamed stackN $ MetaStruct [MetaStr (fsLit "stack"), MetaNode topN] + , MetaUnamed heapN $ MetaStruct [MetaStr (fsLit "heap"), MetaNode topN] + , MetaUnamed rxN $ MetaStruct [MetaStr (fsLit "rx"), MetaNode heapN] + , MetaUnamed baseN $ MetaStruct [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 $ MetaExpr [MetaStr (fsLit "other"), MetaNode topN] + , MetaUnamed otherN $ MetaStruct [MetaStr (fsLit "other"), MetaNode topN] ] -- | Id values @@ -101,20 +101,20 @@ baseN = 4 otherN = 5 -- | The various TBAA types -top, heap, stack, rx, base, other :: MetaData -top = (tbaa, MetaValNode topN) -heap = (tbaa, MetaValNode heapN) -stack = (tbaa, MetaValNode stackN) -rx = (tbaa, MetaValNode rxN) -base = (tbaa, MetaValNode baseN) -other = (tbaa, MetaValNode otherN) +top, heap, stack, rx, base, other :: MetaAnnot +top = MetaAnnot tbaa (MetaNode topN) +heap = MetaAnnot tbaa (MetaNode heapN) +stack = MetaAnnot tbaa (MetaNode stackN) +rx = MetaAnnot tbaa (MetaNode rxN) +base = MetaAnnot tbaa (MetaNode baseN) +other = MetaAnnot tbaa (MetaNode otherN) -- | The TBAA metadata identifier tbaa :: LMString tbaa = fsLit "tbaa" -- | Get the correct TBAA metadata information for this register type -getTBAA :: GlobalReg -> MetaData +getTBAA :: GlobalReg -> MetaAnnot getTBAA BaseReg = base getTBAA Sp = stack getTBAA Hp = heap