diff options
-rw-r--r-- | compiler/llvmGen/Llvm.hs | 1 | ||||
-rw-r--r-- | compiler/llvmGen/Llvm/MetaData.hs | 7 | ||||
-rw-r--r-- | compiler/llvmGen/Llvm/PpLlvm.hs | 19 | ||||
-rw-r--r-- | compiler/llvmGen/LlvmCodeGen.hs | 16 | ||||
-rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Base.hs | 2 | ||||
-rw-r--r-- | compiler/llvmGen/LlvmCodeGen/Ppr.hs | 22 |
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 |