[commit: ghc] master: llvmGen: Make metadata ids a newtype (2396d9b)
git at git.haskell.org
git at git.haskell.org
Sat Jun 18 10:39:24 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/2396d9bb76c11775589fc91b362a61c4a92d27fa/ghc
>---------------------------------------------------------------
commit 2396d9bb76c11775589fc91b362a61c4a92d27fa
Author: Ben Gamari <ben at smart-cactus.org>
Date: Fri Jun 17 22:57:38 2016 +0200
llvmGen: Make metadata ids a newtype
These were previously just represented as Ints which was needlessly
vague.
>---------------------------------------------------------------
2396d9bb76c11775589fc91b362a61c4a92d27fa
compiler/llvmGen/Llvm.hs | 2 +-
compiler/llvmGen/Llvm/MetaData.hs | 17 +++++++++++++----
compiler/llvmGen/Llvm/PpLlvm.hs | 11 +++++------
compiler/llvmGen/LlvmCodeGen.hs | 2 +-
compiler/llvmGen/LlvmCodeGen/Base.hs | 18 ++++++++++--------
5 files changed, 30 insertions(+), 20 deletions(-)
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index b245422..8104a3a 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -42,7 +42,7 @@ module Llvm (
i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
-- ** Metadata types
- MetaExpr(..), MetaAnnot(..), MetaDecl(..),
+ MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),
-- ** Operations on the type system.
isGlobal, getLitType, getVarType,
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
index e1e63c9..a50553c 100644
--- a/compiler/llvmGen/Llvm/MetaData.hs
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Llvm.MetaData where
import Llvm.Types
@@ -55,16 +57,23 @@ import Outputable
-- !llvm.module.linkage = !{ !0, !1 }
--
+-- | A reference to an un-named metadata node.
+newtype MetaId = MetaId Int
+ deriving (Eq, Ord, Enum)
+
+instance Outputable MetaId where
+ ppr (MetaId n) = char '!' <> int n
+
-- | LLVM metadata expressions
data MetaExpr = MetaStr LMString
- | MetaNode Int
+ | MetaNode MetaId
| MetaVar LlvmVar
| MetaStruct [MetaExpr]
deriving (Eq)
instance Outputable MetaExpr where
ppr (MetaStr s ) = text "!\"" <> ftext s <> char '"'
- ppr (MetaNode n ) = text "!" <> int n
+ ppr (MetaNode n ) = ppr n
ppr (MetaVar v ) = ppr v
ppr (MetaStruct es) = text "!{ " <> ppCommaJoin es <> char '}'
@@ -77,7 +86,7 @@ data MetaAnnot = MetaAnnot LMString MetaExpr
data MetaDecl
-- | Named metadata. Only used for communicating module information to
-- LLVM. ('!name = !{ [!<n>] }' form).
- = MetaNamed LMString [Int]
+ = MetaNamed LMString [MetaId]
-- | Metadata node declaration.
-- ('!0 = metadata !{ <metadata expression> }' form).
- | MetaUnamed Int MetaExpr
+ | MetaUnnamed MetaId MetaExpr
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index cdaf962..d92e3c0 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -106,20 +106,19 @@ ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
-- | Print out an LLVM metadata definition.
ppLlvmMeta :: MetaDecl -> SDoc
-ppLlvmMeta (MetaUnamed n m)
- = exclamation <> int n <> text " = " <> ppLlvmMetaExpr m
+ppLlvmMeta (MetaUnnamed n m)
+ = ppr n <> text " = " <> ppLlvmMetaExpr m
ppLlvmMeta (MetaNamed n m)
= exclamation <> ftext n <> text " = !" <> braces nodes
where
- nodes = hcat $ intersperse comma $ map pprNode m
- pprNode n = exclamation <> int n
+ nodes = hcat $ intersperse comma $ map ppr m
-- | Print out an LLVM metadata value.
ppLlvmMetaExpr :: MetaExpr -> SDoc
ppLlvmMetaExpr (MetaVar (LMLitVar (LMNullLit _))) = text "null"
ppLlvmMetaExpr (MetaStr s ) = text "!" <> doubleQuotes (ftext s)
-ppLlvmMetaExpr (MetaNode n ) = text "!" <> int n
+ppLlvmMetaExpr (MetaNode n ) = ppr n
ppLlvmMetaExpr (MetaVar v ) = ppr v
ppLlvmMetaExpr (MetaStruct es) =
text "!{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}'
@@ -489,7 +488,7 @@ ppMetaAnnots meta = hcat $ map ppMeta meta
ppMeta (MetaAnnot name e)
= comma <+> exclamation <> ftext name <+>
case e of
- MetaNode n -> exclamation <> int n
+ MetaNode n -> ppr n
MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)
other -> exclamation <> braces (ppr other) -- possible?
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index fd13de6..c240d09 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -188,7 +188,7 @@ cmmMetaLlvmPrelude = do
setUniqMeta uniq tbaaId
parentId <- maybe (return Nothing) getUniqMeta parent
-- Build definition
- return $ MetaUnamed tbaaId $ MetaStruct
+ return $ MetaUnnamed tbaaId $ MetaStruct
[ MetaStr name
, case parentId of
Just p -> MetaNode p
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 3e2b795..392c069 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -44,7 +44,7 @@ import CLabel
import CodeGen.Platform ( activeStgRegs )
import DynFlags
import FastString
-import Cmm
+import Cmm hiding ( succ )
import Outputable as Outp
import qualified Pretty as Prt
import Platform
@@ -193,8 +193,8 @@ data LlvmEnv = LlvmEnv
, envDynFlags :: DynFlags -- ^ Dynamic flags
, envOutput :: BufHandle -- ^ Output buffer
, envUniq :: UniqSupply -- ^ Supply of unique values
- , envFreshMeta :: Int -- ^ Supply of fresh metadata IDs
- , envUniqMeta :: UniqFM Int -- ^ Global metadata nodes
+ , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs
+ , envUniqMeta :: UniqFM MetaId -- ^ Global metadata nodes
, envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
, envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
, envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
@@ -256,7 +256,7 @@ runLlvm dflags ver out us m = do
, envDynFlags = dflags
, envOutput = out
, envUniq = us
- , envFreshMeta = 0
+ , envFreshMeta = MetaId 0
, envUniqMeta = emptyUFM
}
@@ -301,8 +301,9 @@ checkStackReg :: GlobalReg -> LlvmM Bool
checkStackReg r = getEnv ((elem r) . envStackRegs)
-- | Allocate a new global unnamed metadata identifier
-getMetaUniqueId :: LlvmM Int
-getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1})
+getMetaUniqueId :: LlvmM MetaId
+getMetaUniqueId = LlvmM $ \env ->
+ return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env })
-- | Get the LLVM version we are generating code for
getLlvmVer :: LlvmM LlvmVersion
@@ -350,10 +351,11 @@ saveAlias :: LMString -> LlvmM ()
saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
-- | Sets metadata node for a given unique
-setUniqMeta :: Unique -> Int -> LlvmM ()
+setUniqMeta :: Unique -> MetaId -> LlvmM ()
setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
+
-- | Gets metadata node for given unique
-getUniqMeta :: Unique -> LlvmM (Maybe Int)
+getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
-- ----------------------------------------------------------------------------
More information about the ghc-commits
mailing list