llvmGen: Make metadata ids a newtype

These were previously just represented as Ints which was needlessly
vague.

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,

compiler/llvmGen/Llvm/MetaData.hs

+{-# 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

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?
 

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

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)
 
 -- ----------------------------------------------------------------------------