diff --git a/disasm-test/tests/debug-loc.ll b/disasm-test/tests/debug-loc.ll --- a/disasm-test/tests/debug-loc.ll +++ b/disasm-test/tests/debug-loc.ll @@ -1,33 +1,43 @@ ; ModuleID = 'test.c' -target datalayout = "e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64-S128" -target triple = "x86_64-redhat-linux-gnu" +target datalayout = "e-m:o-i64:64-f80:128-n8:16:32:64-S128" +target triple = "x86_64-apple-macosx10.10.0" -define i32 @f(i32 %x) nounwind uwtable { - %1 = alloca i32, align 4 - store i32 %x, i32* %1, align 4 - call void @llvm.dbg.declare(metadata !{i32* %1}, metadata !12), !dbg !13 - %2 = load i32* %1, align 4, !dbg !14 - %3 = add nsw i32 %2, 1, !dbg !14 - ret i32 %3, !dbg !14 +; Function Attrs: nounwind ssp uwtable +define i32 @f(i32 %c) #0 { +entry: + %c.addr = alloca i32, align 4 + store i32 %c, i32* %c.addr, align 4 + call void @llvm.dbg.declare(metadata i32* %c.addr, metadata !13, metadata !14), !dbg !15 + %0 = load i32* %c.addr, align 4, !dbg !16 + %add = add nsw i32 %0, 1, !dbg !16 + ret i32 %add, !dbg !16 } -declare void @llvm.dbg.declare(metadata, metadata) nounwind readnone +; Function Attrs: nounwind readnone +declare void @llvm.dbg.declare(metadata, metadata, metadata) #1 +attributes #0 = { nounwind ssp uwtable "less-precise-fpmad"="false" "no-frame-pointer-elim"="true" "no-frame-pointer-elim-non-leaf" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "stack-protector-buffer-size"="8" "unsafe-fp-math"="false" "use-soft-float"="false" } +attributes #1 = { nounwind readnone } + !llvm.dbg.cu = !{!0} +!llvm.module.flags = !{!9, !10, !11} +!llvm.ident = !{!12} -!0 = metadata !{i32 720913, i32 0, i32 12, metadata !"test.c", metadata !"", metadata !"clang version 3.0 (tags/RELEASE_30/final)", i1 true, i1 false, metadata !"", i32 0, metadata !1, metadata !1, metadata !3, metadata !1} ; [ DW_TAG_compile_unit ] -!1 = metadata !{metadata !2} -!2 = metadata !{i32 0} -!3 = metadata !{metadata !4} -!4 = metadata !{metadata !5} -!5 = metadata !{i32 720942, i32 0, metadata !6, metadata !"f", metadata !"f", metadata !"", metadata !6, i32 2, metadata !7, i1 false, i1 true, i32 0, i32 0, i32 0, i32 256, i1 false, i32 (i32)* @f, null, null, metadata !10} ; [ DW_TAG_subprogram ] -!6 = metadata !{i32 720937, metadata !"test.c", metadata !"", null} ; [ DW_TAG_file_type ] -!7 = metadata !{i32 720917, i32 0, metadata !"", i32 0, i32 0, i64 0, i64 0, i32 0, i32 0, i32 0, metadata !8, i32 0, i32 0} ; [ DW_TAG_subroutine_type ] -!8 = metadata !{metadata !9} -!9 = metadata !{i32 720932, null, metadata !"int", null, i32 0, i64 32, i64 32, i64 0, i32 0, i32 5} ; [ DW_TAG_base_type ] -!10 = metadata !{metadata !11} -!11 = metadata !{i32 720932} ; [ DW_TAG_base_type ] -!12 = metadata !{i32 721153, metadata !5, metadata !"x", metadata !6, i32 16777218, metadata !9, i32 0, i32 0} ; [ DW_TAG_arg_variable ] -!13 = metadata !{i32 2, i32 11, metadata !5, null} -!14 = metadata !{i32 3, i32 2, metadata !15, null} -!15 = metadata !{i32 720907, metadata !5, i32 2, i32 14, metadata !6, i32 0} ; [ DW_TAG_lexical_block ] +!0 = !{!"0x11\0012\00clang version 3.6.1 (tags/RELEASE_361/final)\000\00\000\00\001", !1, !2, !2, !3, !2, !2} ; [ DW_TAG_compile_unit ] [/Users/trevor/Work/verifier/llvm-pretty-bc-parser/test.c] [DW_LANG_C99] +!1 = !{!"test.c", !"/Users/trevor/Work/verifier/llvm-pretty-bc-parser"} +!2 = !{} +!3 = !{!4} +!4 = !{!"0x2e\00f\00f\00\002\000\001\000\000\00256\000\002", !1, !5, !6, null, i32 (i32)* @f, null, null, !2} ; [ DW_TAG_subprogram ] [line 2] [def] [f] +!5 = !{!"0x29", !1} ; [ DW_TAG_file_type ] [/Users/trevor/Work/verifier/llvm-pretty-bc-parser/test.c] +!6 = !{!"0x15\00\000\000\000\000\000\000", null, null, null, !7, null, null, null} ; [ DW_TAG_subroutine_type ] [line 0, size 0, align 0, offset 0] [from ] +!7 = !{!8, !8} +!8 = !{!"0x24\00int\000\0032\0032\000\000\005", null, null} ; [ DW_TAG_base_type ] [int] [line 0, size 32, align 32, offset 0, enc DW_ATE_signed] +!9 = !{i32 2, !"Dwarf Version", i32 2} +!10 = !{i32 2, !"Debug Info Version", i32 2} +!11 = !{i32 1, !"PIC Level", i32 2} +!12 = !{!"clang version 3.6.1 (tags/RELEASE_361/final)"} +!13 = !{!"0x101\00c\0016777218\000", !4, !5, !8} ; [ DW_TAG_arg_variable ] [c] [line 2] +!14 = !{!"0x102"} ; [ DW_TAG_expression ] +!15 = !MDLocation(line: 2, column: 11, scope: !4) +!16 = !MDLocation(line: 3, column: 12, scope: !4) +!17 = !MDLocation(line: 3, column: 5, scope: !4) diff --git a/disasm-test/tests/fn-metadata.ll b/disasm-test/tests/fn-metadata.ll --- a/disasm-test/tests/fn-metadata.ll +++ b/disasm-test/tests/fn-metadata.ll @@ -1,8 +1,9 @@ -declare void @llvm.dbg.declare(metadata, metadata) +declare void @llvm.dbg.declare(metadata, metadata, metadata) define void @f(i32 %x) { %y = add i32 %x, 20 - call void @llvm.dbg.declare( metadata !{ i32 %x }, metadata !{ metadata !"x" } ) + call void @llvm.dbg.declare( metadata i32 %x, metadata !{ !"x" }, metadata !{ +!"0x102" }) ret void } diff --git a/disasm-test/tests/half-float.ll b/disasm-test/tests/half-float.ll new file mode 100644 --- /dev/null +++ b/disasm-test/tests/half-float.ll @@ -0,0 +1,5 @@ + +define half @f(double %x) { + %y = fptrunc double %x to half + ret half %y +} diff --git a/disasm-test/tests/metadata.ll b/disasm-test/tests/metadata.ll --- a/disasm-test/tests/metadata.ll +++ b/disasm-test/tests/metadata.ll @@ -1,8 +1,8 @@ ; Some unnamed metadata nodes, which are referenced by the named metadata. -!0 = metadata !{ metadata !"zero" } -!1 = metadata !{ metadata !{ metadata !"three" }, metadata !2 } -!2 = metadata !{ metadata !"one" } +!0 = !{ !"zero" } +!1 = !{ !{ !"three" }, !2 } +!2 = !{ !"one" } ; A named metadata. !thinger = !{ !0, !1, !2 } diff --git a/disasm-test/tests/simple-metadata.ll b/disasm-test/tests/simple-metadata.ll --- a/disasm-test/tests/simple-metadata.ll +++ b/disasm-test/tests/simple-metadata.ll @@ -1,5 +1,5 @@ -!0 = metadata !{ metadata !"string" } +!0 = !{ !"string" } define void @f() { ret void diff --git a/llvm-pretty-bc-parser.cabal b/llvm-pretty-bc-parser.cabal --- a/llvm-pretty-bc-parser.cabal +++ b/llvm-pretty-bc-parser.cabal @@ -1,5 +1,5 @@ Name: llvm-pretty-bc-parser -Version: 0.1.3.1 +Version: 0.2.0.0 License: BSD3 License-file: LICENSE Author: Trevor Elliott @@ -53,7 +53,7 @@ fgl >= 5.5, cereal >= 0.3.5.2, bytestring >= 0.9.1, - llvm-pretty>= 0.3.0.0 + llvm-pretty>= 0.4.0.0 Executable llvm-disasm Main-is: LLVMDis.hs @@ -69,7 +69,7 @@ fgl >= 5.5, fgl-visualize >= 0.1, cereal >= 0.3.5.2, - llvm-pretty>= 0.3.0.0, + llvm-pretty>= 0.4.0.0, llvm-pretty-bc-parser Test-suite disasm-test @@ -82,5 +82,5 @@ directory, bytestring, filepath, - llvm-pretty>= 0.3.0.0, + llvm-pretty>= 0.4.0.0, llvm-pretty-bc-parser diff --git a/src/Data/LLVM/BitCode/IR/Function.hs b/src/Data/LLVM/BitCode/IR/Function.hs --- a/src/Data/LLVM/BitCode/IR/Function.hs +++ b/src/Data/LLVM/BitCode/IR/Function.hs @@ -654,9 +654,9 @@ _ <- parseMetadataBlock t es return d -parseFunctionBlockEntry _ d (metadataAttachmentBlockId -> Just _) = do - -- skip the metadata attachment block - return d +parseFunctionBlockEntry t d (metadataAttachmentBlockId -> Just es) = do + (_,_,md) <- parseMetadataBlock t es + return d { partialBody = addAttachments md (partialBody d) } parseFunctionBlockEntry _ d (abbrevDef -> Just _) = -- ignore any abbreviation definitions @@ -664,6 +664,30 @@ parseFunctionBlockEntry _ _ e = do fail ("function block: unexpected: " ++ show e) + +addAttachments :: MetadataAttachments -> BlockList -> BlockList +addAttachments atts blocks = go 0 (Map.toList atts) (Seq.viewl blocks) + where + go _ [] (b Seq.:< bs) = b Seq.<| bs + go off mds (b Seq.:< bs) = + b' Seq.<| go (off + numStmts) delay (Seq.viewl bs) + where + numStmts = Seq.length (partialStmts b) + + -- partition the attachments into those that apply to this block, and those + -- that don't + (use,delay) = span applies mds + applies (i,_) = i - off < numStmts + + b' | null use = b + | otherwise = b { partialStmts = foldl addMd (partialStmts b) use } + + addMd stmts (i,md') = Seq.adjust update i stmts + where + update (Result n s md) = Result n s (md ++ md') + update (Effect s md) = Effect s (md ++ md') + + go _ _ Seq.EmptyL = Seq.empty -- [n x operands] parseGEP :: ValueTable -> Bool -> Record -> PartialDefine -> Parse PartialDefine diff --git a/src/Data/LLVM/BitCode/IR/Globals.hs b/src/Data/LLVM/BitCode/IR/Globals.hs --- a/src/Data/LLVM/BitCode/IR/Globals.hs +++ b/src/Data/LLVM/BitCode/IR/Globals.hs @@ -77,6 +77,6 @@ { globalSym = pgSym pg , globalAttrs = pgAttrs pg , globalType = pgType pg - , globalValue = val + , globalValue = Just val , globalAlign = pgAlign pg } diff --git a/src/Data/LLVM/BitCode/IR/Metadata.hs b/src/Data/LLVM/BitCode/IR/Metadata.hs --- a/src/Data/LLVM/BitCode/IR/Metadata.hs +++ b/src/Data/LLVM/BitCode/IR/Metadata.hs @@ -5,6 +5,7 @@ parseMetadataBlock , PartialUnnamedMd(..) , finalizePartialUnnamedMd + , MetadataAttachments ) where import Data.LLVM.BitCode.Bitstream @@ -15,48 +16,18 @@ import Text.LLVM.Labels import Control.Exception (throw) -import Control.Monad (foldM,guard) +import Control.Monad (foldM,guard,mplus,unless,when) import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Traversable as T --- Kind Tables ----------------------------------------------------------------- - -data KindTable = KindTable - { ktNextId :: !Int - , ktNameMap :: Map.Map String Int - } deriving (Show) - -emptyKindTable :: KindTable -emptyKindTable = KindTable - { ktNextId = 5 - , ktNameMap = Map.fromList - [ ("dbg", 0) - , ("tbaa", 1) - , ("prof", 2) - , ("fpmath", 3) - , ("range", 4) - ] - } - -getKindId :: String -> KindTable -> (Int,KindTable) -getKindId str kt = case Map.lookup str (ktNameMap kt) of - Just i -> (i,kt) - Nothing -> (ktNextId kt, kt') - where - kt' = kt - { ktNextId = ktNextId kt + 1 - , ktNameMap = Map.insert str (ktNextId kt) (ktNameMap kt) - } - - -- Parsing State --------------------------------------------------------------- data MetadataTable = MetadataTable { mtEntries :: MdTable , mtNextNode :: !Int - , mtNodes :: Map.Map Int (Bool,Int) + , mtNodes :: Map.Map Int (Bool,Bool,Int) } deriving (Show) emptyMetadataTable :: MdTable -> MetadataTable @@ -74,72 +45,77 @@ where (ix,es') = addValue' (metadata val) (mtEntries mt) -nameNode :: Bool -> Int -> MetadataTable -> MetadataTable -nameNode fnLocal ix mt = mt - { mtNodes = Map.insert ix (fnLocal,mtNextNode mt) (mtNodes mt) +addMdValue :: Typed PValue -> MetadataTable -> MetadataTable +addMdValue tv mt = mt { mtEntries = addValue tv (mtEntries mt) } + +nameNode :: Bool -> Bool -> Int -> MetadataTable -> MetadataTable +nameNode fnLocal isDistinct ix mt = mt + { mtNodes = Map.insert ix (fnLocal,isDistinct,mtNextNode mt) (mtNodes mt) , mtNextNode = mtNextNode mt + 1 } addString :: String -> MetadataTable -> MetadataTable addString str = snd . addMetadata (ValMdString str) -addNode :: Bool -> [Typed PValue] -> MetadataTable -> MetadataTable -addNode fnLocal vals mt = nameNode fnLocal ix mt' +-- | Add a new node, that might be distinct. +addNode :: Bool -> [Maybe PValMd] -> MetadataTable -> MetadataTable +addNode isDistinct vals mt = nameNode False isDistinct ix mt' where (ix,mt') = addMetadata (ValMdNode vals) mt -mdForwardRef :: [String] -> MetadataTable -> Int -> Typed PValue +addOldNode :: Bool -> [Typed PValue] -> MetadataTable -> MetadataTable +addOldNode fnLocal vals mt = nameNode fnLocal False ix mt' + where + (ix,mt') = addMetadata (ValMdNode [ Just (ValMdValue tv) | tv <- vals ]) mt + +mdForwardRef :: [String] -> MetadataTable -> Int -> PValMd mdForwardRef cxt mt ix = fromMaybe fallback nodeRef where - fallback = forwardRef cxt ix (mtEntries mt) - reference = metadata . ValMdRef . snd - nodeRef = reference `fmap` Map.lookup ix (mtNodes mt) + fallback = case forwardRef cxt ix (mtEntries mt) of + Typed { typedValue = ValMd md } -> md + tv -> ValMdValue tv + reference (_,_,r) = ValMdRef r + nodeRef = reference `fmap` Map.lookup ix (mtNodes mt) mdNodeRef :: [String] -> MetadataTable -> Int -> Int mdNodeRef cxt mt ix = - maybe (throw (BadValueRef cxt ix)) snd (Map.lookup ix (mtNodes mt)) + maybe (throw (BadValueRef cxt ix)) prj (Map.lookup ix (mtNodes mt)) + where + prj (_,_,x) = x mkMdRefTable :: MetadataTable -> MdRefTable mkMdRefTable mt = Map.mapMaybe step (mtNodes mt) where - step (fnLocal,ix) = do + step (fnLocal,_,ix) = do guard (not fnLocal) return ix -type KindMap = Map.Map Int Int - data PartialMetadata = PartialMetadata { pmEntries :: MetadataTable , pmNamedEntries :: Map.Map String [Int] - , pmKindMap :: KindMap - , pmKindTable :: KindTable , pmNextName :: Maybe String + , pmAttachments :: MetadataAttachments } deriving (Show) emptyPartialMetadata :: MdTable -> PartialMetadata emptyPartialMetadata es = PartialMetadata { pmEntries = emptyMetadataTable es , pmNamedEntries = Map.empty - , pmKindMap = Map.empty - , pmKindTable = emptyKindTable , pmNextName = Nothing + , pmAttachments = Map.empty } updateMetadataTable :: (MetadataTable -> MetadataTable) -> (PartialMetadata -> PartialMetadata) updateMetadataTable f pm = pm { pmEntries = f (pmEntries pm) } -addKind :: Int -> String -> PartialMetadata -> PartialMetadata -addKind ix str pm = pm - { pmKindMap = Map.insert ix strId (pmKindMap pm) - , pmKindTable = kt' - } - where - (strId,kt') = getKindId str (pmKindTable pm) - setNextName :: String -> PartialMetadata -> PartialMetadata setNextName name pm = pm { pmNextName = Just name } +addAttachment :: Int -> [(String,PValMd)] -> PartialMetadata -> PartialMetadata +addAttachment instr md pm = + pm { pmAttachments = Map.insert instr md (pmAttachments pm) } + nameMetadata :: [Int] -> PartialMetadata -> Parse PartialMetadata nameMetadata val pm = case pmNextName pm of Just name -> return $! pm @@ -155,17 +131,19 @@ data PartialUnnamedMd = PartialUnnamedMd { pumIndex :: Int - , pumValues :: [Typed PValue] + , pumValues :: [Maybe PValMd] + , pumDistinct :: Bool } deriving (Show) finalizePartialUnnamedMd :: PartialUnnamedMd -> Parse UnnamedMd finalizePartialUnnamedMd pum = mkUnnamedMd `fmap` fixLabels (pumValues pum) where -- map through the list and typed PValue to change labels to textual ones - fixLabels = mapM (T.mapM (relabel (const requireBbEntryName))) + fixLabels = T.mapM (T.mapM (relabel (const requireBbEntryName))) mkUnnamedMd vs = UnnamedMd { umIndex = pumIndex pum , umValues = vs + , umDistinct = pumDistinct pum } unnamedEntries :: PartialMetadata -> ([PartialUnnamedMd],[PartialUnnamedMd]) @@ -174,22 +152,24 @@ mt = pmEntries pm es = valueEntries (mtEntries mt) - resolveNode (gs,fs) (ref,(fnLocal,ix)) = case lookupNode ref ix of + resolveNode (gs,fs) (ref,(fnLocal,d,ix)) = case lookupNode ref d ix of Just pum | fnLocal -> (gs,pum:fs) | otherwise -> (pum:gs,fs) Nothing -> (gs,fs) - lookupNode ref ix = do + lookupNode ref d ix = do Typed { typedValue = ValMd (ValMdNode vs) } <- Map.lookup ref es return PartialUnnamedMd { pumIndex = ix , pumValues = vs + , pumDistinct = d } -type ParsedMetadata = ([NamedMd],([PartialUnnamedMd],[PartialUnnamedMd])) +type MetadataAttachments = Map.Map Int [(String,PValMd)] +type ParsedMetadata = ([NamedMd],([PartialUnnamedMd],[PartialUnnamedMd]),MetadataAttachments) parsedMetadata :: PartialMetadata -> ParsedMetadata -parsedMetadata pm = (namedEntries pm, unnamedEntries pm) +parsedMetadata pm = (namedEntries pm, unnamedEntries pm, pmAttachments pm) -- Metadata Parsing ------------------------------------------------------------ @@ -213,33 +193,53 @@ parseMetadataEntry vt mt pm (fromEntry -> Just r) = case recordCode r of -- [values] 1 -> label "METADATA_STRING" $ do - str <- parseFields r 0 char + str <- parseFields r 0 char `mplus` parseField r 0 string return $! updateMetadataTable (addString str) pm - -- 2 is unused. + -- [type num, value num] + 2 -> label "METADATA_VALUE" $ do + unless (length (recordFields r) == 2) + (fail "Invalid record") - -- 3 is unused. + let field = parseField r + ty <- getType =<< field 0 numeric + when (ty == PrimType Metadata || ty == PrimType Void) + (fail "invalid record") + cxt <- getContext + ix <- field 1 numeric + let tv = forwardRef cxt ix vt + + return $! updateMetadataTable (addMdValue tv) pm + + + -- [n x md num] + 3 -> label "METADATA_NODE" (parseMetadataNode False mt r pm) + -- [values] 4 -> label "METADATA_NAME" $ do - name <- parseFields r 0 char + name <- parseFields r 0 char `mplus` parseField r 0 cstring return $! setNextName name pm - -- 5 is unused. + -- [n x md num] + 5 -> label "METADATA_DISTINCT_NODE" (parseMetadataNode True mt r pm) -- [n x [id, name]] 6 -> label "METADATA_KIND" $ do kind <- parseField r 0 numeric name <- parseFields r 1 char - return $! addKind kind name pm + addKind kind name + return pm - -- 7 is unused. + -- [distinct, line, col, scope, inlined-at?] + 7 -> label "METADATA_LOCATION" $ do + fail "not implemented" -- [n x (type num, value num)] - 8 -> label "METADATA_NODE" (parseMetadataNode False vt mt r pm) + 8 -> label "METADATA_OLD_NODE" (parseMetadataOldNode False vt mt r pm) -- [n x (type num, value num)] - 9 -> label "METADATA_FN_NODE" (parseMetadataNode True vt mt r pm) + 9 -> label "METADATA_OLD_FN_NODE" (parseMetadataOldNode True vt mt r pm) -- [n x mdnodes] 10 -> label "METADATA_NAMED_NODE" $ do @@ -250,7 +250,10 @@ -- [m x [value, [n x [id, mdnode]]] 11 -> label "METADATA_ATTACHMENT" $ do - fail "not implemented" + let field = parseField r + inst <- field 0 numeric + md <- parseAttachment r + return $! addAttachment inst md pm code -> fail ("unknown record code: " ++ show code) @@ -261,12 +264,32 @@ fail ("unexpected: " ++ show r) --- | Parse out a metadata node. -parseMetadataNode :: Bool -> ValueTable -> MetadataTable -> Record - -> PartialMetadata -> Parse PartialMetadata -parseMetadataNode fnLocal vt mt r pm = do +parseAttachment :: Record -> Parse [(String,PValMd)] +parseAttachment r = loop (length (recordFields r) - 1) [] + where + loop 0 acc = return acc + loop n acc = do + kind <- getKind =<< parseField r (n - 1) numeric + md <- getMetadata =<< parseField r n numeric + loop (n - 2) ((kind,typedValue md) : acc) + +-- | Parse a metadata node. +parseMetadataNode :: Bool -> MetadataTable -> Record -> PartialMetadata + -> Parse PartialMetadata +parseMetadataNode isDistinct mt r pm = do + ixs <- parseFields r 0 numeric + cxt <- getContext + let lkp ix | ix > 0 = Just (mdForwardRef cxt mt (ix - 1)) + | otherwise = Nothing + return $! updateMetadataTable (addNode isDistinct (map lkp ixs)) pm + + +-- | Parse out a metadata node in the old format. +parseMetadataOldNode :: Bool -> ValueTable -> MetadataTable -> Record + -> PartialMetadata -> Parse PartialMetadata +parseMetadataOldNode fnLocal vt mt r pm = do values <- loop =<< parseFields r 0 numeric - return $! updateMetadataTable (addNode fnLocal values) pm + return $! updateMetadataTable (addOldNode fnLocal values) pm where loop fs = case fs of @@ -274,7 +297,8 @@ cxt <- getContext ty <- getType' tyId val <- case ty of - PrimType Metadata -> return (mdForwardRef cxt mt valId) + PrimType Metadata -> return $ Typed (PrimType Metadata) + (ValMd (mdForwardRef cxt mt valId)) -- XXX need to check for a void type here _ -> return (forwardRef cxt valId vt) diff --git a/src/Data/LLVM/BitCode/IR/Module.hs b/src/Data/LLVM/BitCode/IR/Module.hs --- a/src/Data/LLVM/BitCode/IR/Module.hs +++ b/src/Data/LLVM/BitCode/IR/Module.hs @@ -144,7 +144,7 @@ parseModuleBlockEntry pm (metadataBlockId -> Just es) = do -- METADATA_BLOCK_ID vt <- getValueTable - (ns,(gs,_)) <- parseMetadataBlock vt es + (ns,(gs,_),_) <- parseMetadataBlock vt es return pm { partialNamedMd = partialNamedMd pm ++ ns , partialUnnamedMd = partialUnnamedMd pm ++ gs diff --git a/src/Data/LLVM/BitCode/IR/Types.hs b/src/Data/LLVM/BitCode/IR/Types.hs --- a/src/Data/LLVM/BitCode/IR/Types.hs +++ b/src/Data/LLVM/BitCode/IR/Types.hs @@ -25,12 +25,6 @@ numEntry :: Match Entry Record numEntry = hasRecordCode 1 <=< fromUnabbrev <=< unabbrev -struct :: Match Field ([PType] -> PType) -struct = fmap decode . boolean - where - decode False = Struct - decode True = PackedStruct - resolveTypeDecls :: Parse [TypeDecl] resolveTypeDecls = do symtab <- getTypeSymtab @@ -133,11 +127,7 @@ rty:ptys -> addType (FunTy rty ptys va) _ -> fail "function expects a return type" - 10 -> label "TYPE_CODE_STRUCT_OLD" $ do - let field = parseField r - mkStruct <- field 0 struct - elements <- field 1 (fieldArray typeRef) - addType (mkStruct elements) + 10 -> label "TYPE_CODE_X86_FP80" (addType (PrimType (FloatType Half))) 11 -> label "TYPE_CODE_ARRAY" $ do let field = parseField r diff --git a/src/Data/LLVM/BitCode/Parse.hs b/src/Data/LLVM/BitCode/Parse.hs --- a/src/Data/LLVM/BitCode/Parse.hs +++ b/src/Data/LLVM/BitCode/Parse.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE RecordWildCards #-} module Data.LLVM.BitCode.Parse where @@ -85,6 +86,7 @@ , psTypeName :: Maybe String , psNextTypeId :: !Int , psLastLoc :: Maybe PDebugLoc + , psKinds :: !KindTable } deriving (Show) -- | The initial parsing state. @@ -100,6 +102,7 @@ , psTypeName = Nothing , psNextTypeId = 0 , psLastLoc = Nothing + , psKinds = emptyKindTable } -- | The next implicit result id. @@ -579,3 +582,35 @@ { tsById = Map.insert ix n (tsById ts) , tsByName = Map.insert n ix (tsByName ts) } + + +-- Metadata Kind Table --------------------------------------------------------- + +data KindTable = KindTable + { ktNames :: Map.Map Int String + } deriving (Show) + +emptyKindTable :: KindTable +emptyKindTable = KindTable + { ktNames = Map.fromList + [ (0, "dbg" ) + , (1, "tbaa" ) + , (2, "prof" ) + , (3, "fpmath") + , (4, "range" ) + ] + } + +addKind :: Int -> String -> Parse () +addKind kind name = Parse $ do + ps <- get + let KindTable { .. } = psKinds ps + set $! ps { psKinds = KindTable { ktNames = Map.insert kind name ktNames } } + +getKind :: Int -> Parse String +getKind kind = Parse $ do + ps <- get + let KindTable { .. } = psKinds ps + case Map.lookup kind ktNames of + Just name -> return name + Nothing -> fail ("Unknown kind id: " ++ show kind) diff --git a/src/Data/LLVM/BitCode/Record.hs b/src/Data/LLVM/BitCode/Record.hs --- a/src/Data/LLVM/BitCode/Record.hs +++ b/src/Data/LLVM/BitCode/Record.hs @@ -79,7 +79,7 @@ parseField r n p = case (p <=< fieldAt n) r of Just a -> return a Nothing -> fail $ unwords - [ "unable to parse record field", show n, "of record", show r ] + [ "parseField: unable to parse record field", show n, "of record", show r ] -- | Parse all record fields starting from an index. parseFields :: Record -> Int -> Match Field a -> Parse [a] @@ -93,7 +93,7 @@ case p f of Just a -> (a:) `fmap` loop fs Nothing -> fail $ unwords - ["unable to parse record field", show n, "of record", show r] + ["parseSlice: unable to parse record field", show n, "of record", show r] loop [] = return [] @@ -124,7 +124,7 @@ char = fmap chr . numeric string :: Match Field String -string = fieldArray (fmap chr . numeric) +string = fieldArray char cstring :: Match Field String cstring = fieldArray (fieldChar6 ||| char) diff --git a/src/Data/LLVM/CFG.hs b/src/Data/LLVM/CFG.hs --- a/src/Data/LLVM/CFG.hs +++ b/src/Data/LLVM/CFG.hs @@ -28,8 +28,10 @@ import qualified Data.Graph.Inductive.Query.Dominators as Dom import qualified Data.Graph.Inductive as G import qualified Data.Map as M +import MonadLib (runId) import Text.LLVM hiding (BB) +import qualified Text.LLVM.Labels as L -- import Debug.Trace @@ -132,23 +134,22 @@ -- Graph construction (exit, gr) = stitchDummyExit lab (G.mkGraph nodes' edges') - where lab n = BasicBlock (BBId n, Named $ Ident dummyExitName) + where lab n = BasicBlock (Just (BBId n, Named $ Ident dummyExitName)) [Effect Unreachable []] nodes' = map (nodeId &&& id) bs' edges' = concatMap bbOutEdges bs' + + bbOutEdges :: BB -> [G.LEdge ()] bbOutEdges bb = edgesTo (brTargets bb) where - edgesTo = map (\tgt -> nodeId bb `to` lkup tgt) - lkup x = maybe (err x) id (M.lookup x nodeByName) - err x = error $ "Data.LLVM.CFG internal: " - ++ "failed to find ident " - ++ show (ppLabel x) - ++ " in name map" + srcId = nodeId bb + edgesTo = map (\(BBId tgt,_) -> srcId `to` tgt) -- Relabeling and aux data structures; note that unnamed basic blocks get a -- generated name here so that clients don't have to deal with extraneous -- checks. - (nodeByName, bs', _, _) = foldr relabel (M.empty, [], length bs - 1, 0) bs + bs' :: [BB] + (bbIds, bs', _, _) = foldr relabel (M.empty, [], length bs - 1, 0) bs where relabel (BasicBlock mid stmts) (mp, acc, n, s :: Int) = -- trace ("relabel: mid = " ++ show mid) @@ -156,13 +157,23 @@ let (s', nm) = case mid of Nothing -> (s + 1, Named $ Ident $ "__anon_" ++ show s) Just nm' -> (s, nm') + bbid = (BBId n, nm) in - ( M.insert nm n mp - , BasicBlock (BBId n, nm) stmts : acc + ( M.insert nm bbid mp + , BasicBlock (Just bbid) (fixLabels stmts) : acc , n - 1 , s' ) + nodeByName = fmap (\(BBId n, _) -> n) bbIds + + fixLabels stmts = runId (mapM (L.relabel f) stmts) + where + -- This should be fine, as there shouldn't be references to labels that + -- aren't defined. + f _ lab = return (bbIds M.! lab) + + -------------------------------------------------------------------------------- -- Utility functions @@ -172,11 +183,17 @@ to :: G.Node -> G.Node -> G.LEdge () u `to` v = (u, v, ()) +requireLabel :: BB -> (BBId, BlockLabel) +requireLabel bb = + case bbLabel bb of + Just lab -> lab + Nothing -> error ("requireLabel: basic block without a label\n" ++ show bb) + blockId :: BB -> BBId -blockId = fst . bbLabel +blockId = fst . requireLabel blockName :: BB -> BlockLabel -blockName = snd . bbLabel +blockName = snd . requireLabel nodeId :: BB -> G.Node nodeId = unBBId . blockId @@ -221,34 +238,3 @@ ] instance Show BBId where show (BBId n) = "BB#" ++ show n - --------------------------------------------------------------------------------- --- Debug pretty printing - -ppBBBrief :: BasicBlock' (G.Node, Maybe Ident) -> String -ppBBBrief (BasicBlock (n, mid) _) = - "BB#" - ++ show n - ++ (maybe "" (\ident -> " (" ++ show (ppIdent ident) ++ ")") mid) - -ppCtxBrief :: G.Context (BasicBlock' (G.Node, Maybe Ident)) () -> String -ppCtxBrief (p, n, bb, s) = show (p, n, ppBBBrief bb, s) - --------------------------------------------------------------------------------- --- Testing - -test :: Module -> CFG -test m = buildCFG blks where [defBody -> blks] = modDefines m - --- Very cursory check for now -domSanity :: Module -> Bool -domSanity m = - and $ map (\x -> dom cfg (entryId cfg) (blockId x)) (allBBs cfg) - ++ - map (\x -> pdom cfg (exitId cfg) (blockId x)) (allBBs cfg) - where - cfg = test m - -_nowarn_unused :: forall t. t -_nowarn_unused = undefined - test domSanity ppBBBrief ppCtxBrief