Fix distinctionwip/llvm-debug-info

6 files changed, 37 insertions, 30 deletions

diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index 8104a3a61e..920affcf4f 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -43,6 +43,7 @@ module Llvm (
 
         -- ** Metadata types
         MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),
+        Distinction(..),
 
         -- ** Operations on the type system.
         isGlobal, getLitType, getVarType,
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
index 8215870a19..049d28733d 100644
--- a/compiler/llvmGen/Llvm/MetaData.hs
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -140,11 +140,14 @@ specialMetadata nodeName fields =
 data MetaAnnot = MetaAnnot LMString MetaExpr
                deriving (Eq)
 
+-- | Is a metadata node @distinct@?
+data Distinction = Distinct | NotDistinct
+
 -- | 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 [MetaId]
+    = MetaNamed !LMString Distinction [MetaId]
     -- | Metadata node declaration.
     -- ('!0 = metadata !{ <metadata expression> }' form).
-    | MetaUnnamed !MetaId !MetaExpr
+    | MetaUnnamed !MetaId Distinction !MetaExpr
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 4a968cca3f..7a6aa631bf 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -106,14 +106,17 @@ ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
 
 -- | Print out an LLVM metadata definition.
 ppLlvmMeta :: MetaDecl -> SDoc
-ppLlvmMeta (MetaUnnamed n m)
-  = ppr n <+> equals <+> ppr m
-
-ppLlvmMeta (MetaNamed n m)
-  = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes
-  where
-    nodes = hcat $ intersperse comma $ map ppr m
-
+ppLlvmMeta meta =
+    case meta of
+      MetaUnnamed n d m -> ppr n <+> equals <+> ppDistinction d <+> ppr m
+      MetaNamed n d m   ->
+          let nodes = hcat $ intersperse comma $ map ppr m
+          in exclamation <> ftext n <+> equals
+             <+> ppDistinction d <+> exclamation <> braces nodes
+
+ppDistinction :: Distinction -> SDoc
+ppDistinction Distinct    = text "distinct"
+ppDistinction NotDistinct = empty
 
 -- | Print out a list of function definitions.
 ppLlvmFunctions :: LlvmFunctions -> SDoc
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 9a4b234c19..e1a4ff3b35 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -113,29 +113,29 @@ debugInfoGen location
         getMetaDecls >>= renderLlvm . ppLlvmMetas
         subprograms <- getSubprograms
         renderLlvm $ ppLlvmMetas
-            [ MetaUnnamed fileMeta $ MetaDIFile
+            [ MetaUnnamed fileMeta NotDistinct $ MetaDIFile
               { difFilename     = fsLit $ fromMaybe "TODO" (ml_hs_file location)
               , difDirectory    = fsLit ""
               }
-            , MetaUnnamed cuMeta $ MetaDICompileUnit
+            , MetaUnnamed cuMeta Distinct $ MetaDICompileUnit
               { dicuLanguage    = fsLit "DW_LANG_Haskell"
               , dicuFile        = fileMeta
               , dicuProducer    = fsLit "ghc"
               , dicuIsOptimized = optLevel dflags > 0
               , dicuSubprograms = MetaStruct $ map MetaNode subprograms
               }
-            , MetaNamed (fsLit "llvm.dbg.cu") [ cuMeta ]
-            , MetaUnnamed subprogramsMeta $ MetaStruct []
-            , MetaNamed (fsLit "llvm.module.flags")
+            , MetaNamed (fsLit "llvm.dbg.cu") NotDistinct [ cuMeta ]
+            , MetaUnnamed subprogramsMeta NotDistinct $ MetaStruct []
+            , MetaNamed (fsLit "llvm.module.flags") NotDistinct
               [ dwarfVersionMeta
               , debugInfoVersionMeta
               ]
-            , MetaUnnamed dwarfVersionMeta $ MetaStruct
+            , MetaUnnamed dwarfVersionMeta NotDistinct $ MetaStruct
               [ MetaVar $ LMLitVar $ LMIntLit 2 i32
               , MetaStr $ fsLit "Dwarf Version"
               , MetaVar $ LMLitVar $ LMIntLit 4 i32
               ]
-            , MetaUnnamed debugInfoVersionMeta $ MetaStruct
+            , MetaUnnamed debugInfoVersionMeta NotDistinct $ MetaStruct
               [ MetaVar $ LMLitVar $ LMIntLit 2 i32
               , MetaStr $ fsLit "Debug Info Version"
               , MetaVar $ LMLitVar $ LMIntLit 3 i32
@@ -252,7 +252,7 @@ cmmMetaLlvmPrelude = do
     setUniqMeta uniq tbaaId
     parentId <- maybe (return Nothing) getUniqMeta parent
     -- Build definition
-    return $ MetaUnnamed tbaaId $ MetaStruct $
+    return $ MetaUnnamed tbaaId NotDistinct $ MetaStruct $
           case parentId of
               Just p  -> [ MetaStr name, MetaNode p ]
               -- As of LLVM 4.0, a node without parents should be rendered as
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 2e62e91a94..079f81606f 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -368,7 +368,7 @@ getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
 addSubprogram :: MetaId -> MetaExpr -> LlvmM ()
 addSubprogram metaId metaExpr = do
     modifyEnv $ \env -> env { envSubprograms = metaId : envSubprograms env }
-    addMetaDecl (MetaUnnamed metaId metaExpr)
+    addMetaDecl (MetaUnnamed metaId Distinct metaExpr)
 
 getSubprograms :: LlvmM [MetaId]
 getSubprograms = LlvmM $ \env -> return (envSubprograms env, env { envSubprograms = [] })
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 31982ef7e0..fe0afadbef 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -83,22 +83,22 @@ pprLlvmCmmDecl debug_map (CmmProc (label, mb_info) entry_lbl live (ListGraph blk
                subprogMeta <- getMetaUniqueId
                fileMeta <- getMetaUniqueId
                typeMeta <- getMetaUniqueId
-               let fileDef = MetaUnnamed fileMeta
+               let fileDef = MetaUnnamed fileMeta NotDistinct
                              $ MetaDIFile { difFilename = srcSpanFile span
-                                           , difDirectory = fsLit "TODO"
-                                           }
+                                          , difDirectory = fsLit "TODO"
+                                          }
                    typeMetaDef =
-                       MetaUnnamed typeMeta
+                       MetaUnnamed typeMeta NotDistinct
                        $ MetaDISubroutineType [MetaVar $ LMLitVar $ LMNullLit i1]
                    subprog =
                        MetaDISubprogram { disName         = fsLit name
-                                       , disLinkageName  = fsLit $ showPpr dflags defName
-                                       , disScope        = fileMeta
-                                       , disFile         = fileMeta
-                                       , disLine         = srcSpanStartLine span
-                                       , disType         = typeMeta
-                                       , disIsDefinition = True
-                                       }
+                                        , disLinkageName  = fsLit $ showPpr dflags defName
+                                        , disScope        = fileMeta
+                                        , disFile         = fileMeta
+                                        , disLine         = srcSpanStartLine span
+                                        , disType         = typeMeta
+                                        , disIsDefinition = True
+                                        }
                addMetaDecl fileDef
                addMetaDecl typeMetaDef
                addSubprogram subprogMeta subprog