llvm-pretty-bc-parser-0.3.1.0: src/Data/LLVM/BitCode/IR/Metadata.hs
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecursiveDo #-}
module Data.LLVM.BitCode.IR.Metadata (
parseMetadataBlock
, parseMetadataKindEntry
, PartialUnnamedMd(..)
, finalizePartialUnnamedMd
, finalizePValMd
, InstrMdAttachments
, PFnMdAttachments
, PKindMd
) where
import Data.LLVM.BitCode.Bitstream
import Data.LLVM.BitCode.Match
import Data.LLVM.BitCode.Parse
import Data.LLVM.BitCode.Record
import Text.LLVM.AST
import Text.LLVM.Labels
import Control.Exception (throw)
import Control.Monad (foldM,guard,mplus,unless,when)
import Data.List (mapAccumL)
import Data.Maybe (fromMaybe)
import Data.Bits (shiftR, testBit)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as Char8 (unpack)
import qualified Data.Map as Map
import qualified Data.Traversable as T
-- Parsing State ---------------------------------------------------------------
data MetadataTable = MetadataTable
{ mtEntries :: MdTable
, mtNextNode :: !Int
, mtNodes :: Map.Map Int (Bool,Bool,Int)
-- ^ The entries in the map are: is the entry function local,
-- is the entry distinct, and the implicit id for the node.
} deriving (Show)
emptyMetadataTable ::
Int {- ^ globals seen so far -} ->
MdTable -> MetadataTable
emptyMetadataTable globals es = MetadataTable
{ mtEntries = es
, mtNextNode = globals
, mtNodes = Map.empty
}
metadata :: PValMd -> Typed PValue
metadata = Typed (PrimType Metadata) . ValMd
addMetadata :: PValMd -> MetadataTable -> (Int,MetadataTable)
addMetadata val mt = (ix, mt { mtEntries = es' })
where
(ix,es') = addValue' (metadata val) (mtEntries 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)
addStrings :: [String] -> MetadataTable -> MetadataTable
addStrings strs mt = foldl (flip addString) mt strs
addLoc :: Bool -> PDebugLoc -> MetadataTable -> MetadataTable
addLoc isDistinct loc mt = nameNode False isDistinct ix mt'
where
(ix,mt') = addMetadata (ValMdLoc loc) mt
addDebugInfo
:: Bool
-> DebugInfo' Int
-> MetadataTable
-> MetadataTable
addDebugInfo isDistinct di mt = nameNode False isDistinct ix mt'
where
(ix,mt') = addMetadata (ValMdDebugInfo di) 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
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 = 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)
mdForwardRefOrNull :: [String] -> MetadataTable -> Int -> Maybe PValMd
mdForwardRefOrNull cxt mt ix | ix > 0 = Just (mdForwardRef cxt mt (ix - 1))
| otherwise = Nothing
mdNodeRef :: [String] -> MetadataTable -> Int -> Int
mdNodeRef cxt mt ix =
maybe (throw (BadValueRef cxt ix)) prj (Map.lookup ix (mtNodes mt))
where
prj (_,_,x) = x
mdString :: [String] -> MetadataTable -> Int -> String
mdString cxt mt ix =
fromMaybe (throw (BadValueRef cxt ix)) (mdStringOrNull cxt mt ix)
mdStringOrNull :: [String] -> MetadataTable -> Int -> Maybe String
mdStringOrNull cxt mt ix =
case mdForwardRefOrNull cxt mt ix of
Nothing -> Nothing
Just (ValMdString str) -> Just str
Just _ -> throw (BadTypeRef cxt ix)
mkMdRefTable :: MetadataTable -> MdRefTable
mkMdRefTable mt = Map.mapMaybe step (mtNodes mt)
where
step (fnLocal,_,ix) = do
guard (not fnLocal)
return ix
data PartialMetadata = PartialMetadata
{ pmEntries :: MetadataTable
, pmNamedEntries :: Map.Map String [Int]
, pmNextName :: Maybe String
, pmInstrAttachments :: InstrMdAttachments
, pmFnAttachments :: PFnMdAttachments
} deriving (Show)
emptyPartialMetadata ::
Int {- ^ globals seen so far -} ->
MdTable -> PartialMetadata
emptyPartialMetadata globals es = PartialMetadata
{ pmEntries = emptyMetadataTable globals es
, pmNamedEntries = Map.empty
, pmNextName = Nothing
, pmInstrAttachments = Map.empty
, pmFnAttachments = Map.empty
}
updateMetadataTable :: (MetadataTable -> MetadataTable)
-> (PartialMetadata -> PartialMetadata)
updateMetadataTable f pm = pm { pmEntries = f (pmEntries pm) }
setNextName :: String -> PartialMetadata -> PartialMetadata
setNextName name pm = pm { pmNextName = Just name }
addFnAttachment :: PFnMdAttachments -> PartialMetadata -> PartialMetadata
addFnAttachment att pm =
-- left-biased union, since the parser overwrites metadata as it encounters it
pm { pmFnAttachments = Map.union att (pmFnAttachments pm) }
addInstrAttachment :: Int -> [(KindMd,PValMd)]
-> PartialMetadata -> PartialMetadata
addInstrAttachment instr md pm =
pm { pmInstrAttachments = Map.insert instr md (pmInstrAttachments pm) }
nameMetadata :: [Int] -> PartialMetadata -> Parse PartialMetadata
nameMetadata val pm = case pmNextName pm of
Just name -> return $! pm
{ pmNextName = Nothing
, pmNamedEntries = Map.insert name val (pmNamedEntries pm)
}
Nothing -> fail "Expected a metadata name"
namedEntries :: PartialMetadata -> [NamedMd]
namedEntries = map (uncurry NamedMd)
. Map.toList
. pmNamedEntries
data PartialUnnamedMd = PartialUnnamedMd
{ pumIndex :: Int
, pumValues :: PValMd
, pumDistinct :: Bool
} deriving (Show)
finalizePartialUnnamedMd :: PartialUnnamedMd -> Parse UnnamedMd
finalizePartialUnnamedMd pum = mkUnnamedMd `fmap` finalizePValMd (pumValues pum)
where
mkUnnamedMd v = UnnamedMd
{ umIndex = pumIndex pum
, umValues = v
, umDistinct = pumDistinct pum
}
finalizePValMd :: PValMd -> Parse ValMd
finalizePValMd = relabel (const requireBbEntryName)
-- | Partition unnamed entries into global and function local unnamed entries.
unnamedEntries :: PartialMetadata -> ([PartialUnnamedMd],[PartialUnnamedMd])
unnamedEntries pm = foldl resolveNode ([],[]) (Map.toList (mtNodes mt))
where
mt = pmEntries pm
es = valueEntries (mtEntries mt)
resolveNode (gs,fs) (ref,(fnLocal,d,ix)) = case lookupNode ref d ix of
Just pum | fnLocal -> (gs,pum:fs)
| otherwise -> (pum:gs,fs)
-- TODO: is this silently eating errors with metadata that's not in the
-- value table?
Nothing -> (gs,fs)
lookupNode ref d ix = do
Typed { typedValue = ValMd v } <- Map.lookup ref es
return PartialUnnamedMd
{ pumIndex = ix
, pumValues = v
, pumDistinct = d
}
type InstrMdAttachments = Map.Map Int [(KindMd,PValMd)]
type PKindMd = Int
type PFnMdAttachments = Map.Map PKindMd PValMd
type ParsedMetadata =
( [NamedMd]
, ([PartialUnnamedMd],[PartialUnnamedMd])
, InstrMdAttachments
, PFnMdAttachments
)
parsedMetadata :: PartialMetadata -> ParsedMetadata
parsedMetadata pm =
( namedEntries pm
, unnamedEntries pm
, pmInstrAttachments pm
, pmFnAttachments pm
)
-- Metadata Parsing ------------------------------------------------------------
parseMetadataBlock ::
Int {- ^ globals seen so far -} ->
ValueTable -> [Entry] -> Parse ParsedMetadata
parseMetadataBlock globals vt es = label "METADATA_BLOCK" $ do
ms <- getMdTable
let pm0 = emptyPartialMetadata globals ms
rec pm <- foldM (parseMetadataEntry vt (pmEntries pm)) pm0 es
let entries = pmEntries pm
setMdTable (mtEntries entries)
setMdRefs (mkMdRefTable entries)
return (parsedMetadata pm)
-- | Parse an entry in the metadata block.
--
-- XXX this currently relies on the constant block having been parsed already.
-- Though most bitcode examples I've seen are ordered this way, it would be nice
-- to not have to rely on it.
parseMetadataEntry :: ValueTable -> MetadataTable -> PartialMetadata -> Entry
-> Parse PartialMetadata
parseMetadataEntry vt mt pm (fromEntry -> Just r) =
case recordCode r of
-- [values]
1 -> label "METADATA_STRING" $ do
str <- parseFields r 0 char `mplus` parseField r 0 string
return $! updateMetadataTable (addString str) pm
-- [type num, value num]
2 -> label "METADATA_VALUE" $ do
unless (length (recordFields r) == 2)
(fail "Invalid record")
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 `mplus` parseField r 0 cstring
return $! setNextName name pm
-- [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
addKind kind name
return pm
-- [distinct, line, col, scope, inlined-at?]
7 -> label "METADATA_LOCATION" $ do
-- TODO: broken in 3.7+; needs to be a DILocation rather than an
-- MDLocation, but there appears to be no difference in the
-- bitcode. /sigh/
cxt <- getContext
let field = parseField r
isDistinct <- field 0 nonzero
dlLine <- field 1 numeric
dlCol <- field 2 numeric
dlScope <- mdForwardRef cxt mt <$> field 3 numeric
dlIA <- mdForwardRefOrNull cxt mt <$> field 4 numeric
let loc = DebugLoc { .. }
return $! updateMetadataTable (addLoc isDistinct loc) pm
-- [n x (type num, value num)]
8 -> label "METADATA_OLD_NODE" (parseMetadataOldNode False vt mt r pm)
-- [n x (type num, value num)]
9 -> label "METADATA_OLD_FN_NODE" (parseMetadataOldNode True vt mt r pm)
-- [n x mdnodes]
10 -> label "METADATA_NAMED_NODE" $ do
mdIds <- parseFields r 0 numeric
cxt <- getContext
let ids = map (mdNodeRef cxt mt) mdIds
nameMetadata ids pm
-- [m x [value, [n x [id, mdnode]]]
11 -> label "METADATA_ATTACHMENT" $ do
let recordSize = length (recordFields r)
when (recordSize == 0)
(fail "Invalid record")
ctx <- getContext
if (recordSize `mod` 2 == 0)
then label "function attachment" $ do
att <- Map.fromList <$> parseAttachment r 0
return $! addFnAttachment att pm
else label "instruction attachment" $ do
inst <- parseField r 0 numeric
patt <- parseAttachment r 1
att <- mapM (\(k,md) -> (,md) <$> getKind k) patt
return $! addInstrAttachment inst att pm
12 -> label "METADATA_GENERIC_DEBUG" $ do
isDistinct <- parseField r 0 numeric
tag <- parseField r 1 numeric
version <- parseField r 2 numeric
header <- parseField r 3 string
-- TODO: parse all remaining fields
fail "not yet implemented"
13 -> label "METADATA_SUBRANGE" $ do
isDistinct <- parseField r 0 nonzero
disrCount <- parseField r 1 numeric
disrLowerBound <- parseField r 2 signedInt64
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoSubrange DISubrange{..})) pm
-- [distinct, value, name]
14 -> label "METADATA_ENUMERATOR" $ do
ctx <- getContext
isDistinct <- parseField r 0 nonzero
value <- parseField r 1 signedInt64
name <- mdString ctx mt <$> parseField r 2 numeric
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoEnumerator name value)) pm
15 -> label "METADATA_BASIC_TYPE" $ do
ctx <- getContext
isDistinct <- parseField r 0 nonzero
dibtTag <- parseField r 1 numeric
dibtName <- mdString ctx mt <$> parseField r 2 numeric
dibtSize <- parseField r 3 numeric
dibtAlign <- parseField r 4 numeric
dibtEncoding <- parseField r 5 numeric
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoBasicType DIBasicType{..})) pm
-- [distinct, filename, directory]
16 -> label "METADATA_FILE" $ do
ctx <- getContext
isDistinct <- parseField r 0 nonzero
difFilename <- mdString ctx mt <$> parseField r 1 numeric
difDirectory <- mdString ctx mt <$> parseField r 2 numeric
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoFile DIFile{..})) pm
17 -> label "METADATA_DERIVED_TYPE" $ do
ctx <- getContext
isDistinct <- parseField r 0 nonzero
didtTag <- parseField r 1 numeric
didtName <- mdStringOrNull ctx mt <$> parseField r 2 numeric
didtFile <- mdForwardRefOrNull ctx mt <$> parseField r 3 numeric
didtLine <- parseField r 4 numeric
didtScope <- mdForwardRefOrNull ctx mt <$> parseField r 5 numeric
didtBaseType <- mdForwardRefOrNull ctx mt <$> parseField r 6 numeric
didtSize <- parseField r 7 numeric
didtAlign <- parseField r 8 numeric
didtOffset <- parseField r 9 numeric
didtFlags <- parseField r 10 numeric
didtExtraData <- mdForwardRefOrNull ctx mt <$> parseField r 11 numeric
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoDerivedType DIDerivedType{..})) pm
18 -> label "METADATA_COMPOSITE_TYPE" $ do
ctx <- getContext
isDistinct <- parseField r 0 nonzero
dictTag <- parseField r 1 numeric
dictName <- mdStringOrNull ctx mt <$> parseField r 2 numeric
dictFile <- mdForwardRefOrNull ctx mt <$> parseField r 3 numeric
dictLine <- parseField r 4 numeric
dictScope <- mdForwardRefOrNull ctx mt <$> parseField r 5 numeric
dictBaseType <- mdForwardRefOrNull ctx mt <$> parseField r 6 numeric
dictSize <- parseField r 7 numeric
dictAlign <- parseField r 8 numeric
dictOffset <- parseField r 9 numeric
dictFlags <- parseField r 10 numeric
dictElements <- mdForwardRefOrNull ctx mt <$> parseField r 11 numeric
dictRuntimeLang <- parseField r 12 numeric
dictVTableHolder <- mdForwardRefOrNull ctx mt <$> parseField r 13 numeric
dictTemplateParams <- mdForwardRefOrNull ctx mt <$> parseField r 14 numeric
dictIdentifier <- mdStringOrNull ctx mt <$> parseField r 15 numeric
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoCompositeType DICompositeType{..})) pm
19 -> label "METADATA_SUBROUTINE_TYPE" $ do
ctx <- getContext
isDistinct <- parseField r 0 nonzero
distFlags <- parseField r 1 numeric
distTypeArray <- mdForwardRefOrNull ctx mt <$> parseField r 2 numeric
return $! updateMetadataTable
(addDebugInfo
isDistinct
(DebugInfoSubroutineType DISubroutineType{..}))
pm
20 -> label "METADATA_COMPILE_UNIT" $ do
let recordSize = length (recordFields r)
when (recordSize < 14 || recordSize > 17)
(fail "Invalid record")
ctx <- getContext
isDistinct <- parseField r 0 nonzero
dicuLanguage <- parseField r 1 numeric
dicuFile <-
mdForwardRefOrNull ctx mt <$> parseField r 2 numeric
dicuProducer <- mdStringOrNull ctx mt <$> parseField r 3 numeric
dicuIsOptimized <- parseField r 4 nonzero
dicuFlags <- parseField r 5 numeric
dicuRuntimeVersion <- parseField r 6 numeric
dicuSplitDebugFilename <- mdStringOrNull ctx mt <$> parseField r 7 numeric
dicuEmissionKind <- parseField r 8 numeric
dicuEnums <-
mdForwardRefOrNull ctx mt <$> parseField r 9 numeric
dicuRetainedTypes <-
mdForwardRefOrNull ctx mt <$> parseField r 10 numeric
dicuSubprograms <-
mdForwardRefOrNull ctx mt <$> parseField r 11 numeric
dicuGlobals <-
mdForwardRefOrNull ctx mt <$> parseField r 12 numeric
dicuImports <-
mdForwardRefOrNull ctx mt <$> parseField r 13 numeric
dicuMacros <-
if recordSize <= 15
then pure Nothing
else mdForwardRefOrNull ctx mt <$> parseField r 15 numeric
dicuDWOId <-
if recordSize <= 14
then pure 0
else parseField r 14 numeric
dicuSplitDebugInlining <-
if recordSize <= 16
then pure True
else parseField r 16 nonzero
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoCompileUnit DICompileUnit {..})) pm
21 -> label "METADATA_SUBPROGRAM" $ do
-- this one is a bit funky:
-- https://github.com/llvm-mirror/llvm/blob/release_38/lib/Bitcode/Reader/BitcodeReader.cpp#L2186
let recordSize = length (recordFields r)
adj i | recordSize == 19 = i + 1
| otherwise = i
hasThisAdjustment = recordSize >= 20
unless (18 <= recordSize && recordSize <= 20)
(fail "Invalid record")
ctx <- getContext
isDistinct <- parseField r 0 nonzero
dispScope <- mdForwardRefOrNull ctx mt <$> parseField r 1 numeric
dispName <- mdStringOrNull ctx mt <$> parseField r 2 numeric
dispLinkageName <- mdStringOrNull ctx mt <$> parseField r 3 numeric
dispFile <- mdForwardRefOrNull ctx mt <$> parseField r 4 numeric
dispLine <- parseField r 5 numeric
dispType <- mdForwardRefOrNull ctx mt <$> parseField r 6 numeric
dispIsLocal <- parseField r 7 nonzero
dispIsDefinition <- parseField r 8 nonzero
dispScopeLine <- parseField r 9 numeric
dispContainingType <- mdForwardRefOrNull ctx mt <$> parseField r 10 numeric
dispVirtuality <- parseField r 11 numeric
dispVirtualIndex <- parseField r 12 numeric
dispThisAdjustment <- if hasThisAdjustment
then parseField r 19 numeric
else return 0
dispFlags <- parseField r 13 numeric
dispIsOptimized <- parseField r 14 nonzero
dispTemplateParams <-
mdForwardRefOrNull ctx mt <$> parseField r (adj 15) numeric
dispDeclaration <-
mdForwardRefOrNull ctx mt <$> parseField r (adj 16) numeric
dispVariables <-
mdForwardRefOrNull ctx mt <$> parseField r (adj 17) numeric
-- TODO: in the LLVM parser, it then goes into the metadata table
-- and updates function entries to point to subprograms. Is that
-- neccessary for us?
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoSubprogram DISubprogram{..})) pm
22 -> label "METADATA_LEXICAL_BLOCK" $ do
when (length (recordFields r) /= 5)
(fail "Invalid record")
cxt <- getContext
isDistinct <- parseField r 0 nonzero
dilbScope <- mdForwardRefOrNull cxt mt <$> parseField r 1 numeric
dilbFile <- mdForwardRefOrNull cxt mt <$> parseField r 2 numeric
dilbLine <- parseField r 3 numeric
dilbColumn <- parseField r 4 numeric
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoLexicalBlock DILexicalBlock{..})) pm
23 -> label "METADATA_LEXICAL_BLOCK_FILE" $ do
when (length (recordFields r) /= 4)
(fail "Invalid record")
cxt <- getContext
isDistinct <- parseField r 0 nonzero
dilbfScope <- do
mScope <- mdForwardRefOrNull cxt mt <$> parseField r 1 numeric
maybe (fail "Invalid record: scope field not present") return mScope
dilbfFile <- mdForwardRefOrNull cxt mt <$> parseField r 2 numeric
dilbfDiscriminator <- parseField r 3 numeric
return $! updateMetadataTable
(addDebugInfo
isDistinct
(DebugInfoLexicalBlockFile DILexicalBlockFile{..}))
pm
24 -> label "METADATA_NAMESPACE" $ do
cxt <- getContext
isDistinct <- parseField r 0 numeric
mdForwardRefOrNull cxt mt <$> parseField r 1 numeric
mdForwardRefOrNull cxt mt <$> parseField r 2 numeric
parseField r 3 string
parseField r 4 numeric
-- TODO
fail "not yet implemented"
25 -> label "METADATA_TEMPLATE_TYPE" $ do
isDistinct <- parseField r 0 numeric
parseField r 1 string
-- getDITypeRefOrNull <$> parseField r 2 numeric
-- TODO
fail "not yet implemented"
26 -> label "METADATA_TEMPLATE_VALUE" $ do
cxt <- getContext
isDistinct <- parseField r 0 numeric
parseField r 1 numeric
parseField r 2 string
-- getDITypeRefOrNull cxt mt <$> parseField r 3 numeric
mdForwardRefOrNull cxt mt <$> parseField r 4 numeric
-- TODO
fail "not yet implemented"
27 -> label "METADATA_GLOBAL_VAR" $ do
let len = length (recordFields r)
unless (11 <= len && len <= 12)
(fail "Unexpected number of record fields")
ctx <- getContext
field0 <- parseField r 0 numeric
let isDistinct = testBit field0 0
_version = shiftR field0 1 :: Int
digvScope <- mdForwardRefOrNull ctx mt <$> parseField r 1 numeric
digvName <- mdStringOrNull ctx mt <$> parseField r 2 numeric
digvLinkageName <- mdStringOrNull ctx mt <$> parseField r 3 numeric
digvFile <- mdForwardRefOrNull ctx mt <$> parseField r 4 numeric
digvLine <- parseField r 5 numeric
digvType <- mdForwardRefOrNull ctx mt <$> parseField r 6 numeric
digvIsLocal <- parseField r 7 nonzero
digvIsDefinition <- parseField r 8 nonzero
digvVariable <- mdForwardRefOrNull ctx mt <$> parseField r 9 numeric
digvDeclaration <- mdForwardRefOrNull ctx mt <$> parseField r 10 numeric
digvAlignment <- if len > 11 then Just <$> parseField r 11 numeric
else return Nothing
return $! updateMetadataTable
(addDebugInfo
isDistinct
(DebugInfoGlobalVariable DIGlobalVariable{..})) pm
28 -> label "METADATA_LOCAL_VAR" $ do
-- this one is a bit funky:
-- https://github.com/llvm-mirror/llvm/blob/release_38/lib/Bitcode/Reader/BitcodeReader.cpp#L2308
let recordSize = length (recordFields r)
adj i | recordSize > 8 = i + 1
| otherwise = i
when (recordSize < 8 || recordSize > 10)
(fail "Invalid record")
ctx <- getContext
isDistinct <- parseField r 0 nonzero
dilvScope <- mdForwardRefOrNull ctx mt <$> parseField r (adj 1) numeric
dilvName <- mdStringOrNull ctx mt <$> parseField r (adj 2) numeric
dilvFile <- mdForwardRefOrNull ctx mt <$> parseField r (adj 3) numeric
dilvLine <- parseField r (adj 4) numeric
dilvType <- mdForwardRefOrNull ctx mt <$> parseField r (adj 5) numeric
dilvArg <- parseField r (adj 6) numeric
dilvFlags <- parseField r (adj 7) numeric
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoLocalVariable DILocalVariable{..})) pm
29 -> label "METADATA_EXPRESSION" $ do
let recordSize = length (recordFields r)
when (recordSize < 1)
(fail "Invalid record")
isDistinct <- parseField r 0 nonzero
dieElements <- parseFields r 1 numeric
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoExpression DIExpression{..})) pm
30 -> label "METADATA_OBJC_PROPERTY" $ do
-- TODO
fail "not yet implemented"
31 -> label "METADATA_IMPORTED_ENTITY" $ do
cxt <- getContext
isDistinct <- parseField r 0 numeric
parseField r 1 numeric
mdForwardRefOrNull cxt mt <$> parseField r 2 numeric
-- getDITypeRefOrNull cxt mt <$> parseField r 3 numeric
parseField r 4 numeric
parseField r 5 string
-- TODO
fail "not yet implemented"
32 -> label "METADATA_MODULE" $ do
cxt <- getContext
isDistinct <- parseField r 0 numeric
mdForwardRefOrNull cxt mt <$> parseField r 1 numeric
parseField r 2 string
parseField r 3 string
parseField r 4 string
parseField r 5 string
-- TODO
fail "not yet implemented"
33 -> label "METADATA_MACRO" $ do
isDistinct <- parseField r 0 numeric
parseField r 1 numeric
parseField r 2 numeric
parseField r 3 string
parseField r 4 string
-- TODO
fail "not yet implemented"
34 -> label "METADATA_MACRO_FILE" $ do
cxt <- getContext
isDistinct <- parseField r 0 numeric
parseField r 1 numeric
parseField r 2 numeric
mdForwardRefOrNull cxt mt <$> parseField r 3 numeric
mdForwardRefOrNull cxt mt <$> parseField r 4 numeric
-- TODO
fail "not yet implemented"
35 -> label "METADATA_STRINGS" $ do
when (length (recordFields r) /= 3)
(fail "Invalid record: metadata strings layout")
count <- parseField r 0 numeric
offset <- parseField r 1 numeric
bs <- parseField r 2 fieldBlob
when (count == 0)
(fail "Invalid record: metadata strings with no strings")
when (offset >= S.length bs)
(fail "Invalid record: metadata strings corrupt offset")
let (bsLengths, bsStrings) = S.splitAt offset bs
lengths <- either fail return $ parseMetadataStringLengths count bsLengths
when (sum lengths > S.length bsStrings)
(fail "Invalid record: metadata strings truncated")
let strings = snd (mapAccumL f bsStrings lengths)
where f s i = case S.splitAt i s of
(str,rest) -> (rest, Char8.unpack str)
return $! updateMetadataTable (addStrings strings) pm
36 -> label "METADATA_GLOBAL_DECL_ATTACHMENT" $ do
-- TODO
fail "not yet implemented"
37 -> label "METADATA_GLOBAL_VAR_EXPR" $ do
when (length (recordFields r) /= 3)
(fail "Invalid record: unsupported layout")
cxt <- getContext
isDistinct <- parseField r 0 nonzero
digveVariable <- mdForwardRefOrNull cxt mt <$> parseField r 1 numeric
digveExpression <- mdForwardRefOrNull cxt mt <$> parseField r 2 numeric
return $! updateMetadataTable
(addDebugInfo isDistinct (DebugInfoGlobalVariableExpression DIGlobalVariableExpression{..})) pm
38 -> label "METADATA_INDEX_OFFSET" $ do
-- TODO
fail "not yet implemented"
39 -> label "METADATA_INDEX" $ do
-- TODO
fail "not yet implemented"
code -> fail ("unknown record code: " ++ show code)
parseMetadataEntry _ _ pm (abbrevDef -> Just _) =
return pm
parseMetadataEntry _ _ _ r =
fail ("unexpected: " ++ show r)
parseAttachment :: Record -> Int -> Parse [(PKindMd,PValMd)]
parseAttachment r l = loop (length (recordFields r) - 1) []
where
loop n acc | n < l = return acc
| otherwise = do
kind <- 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 = mdForwardRefOrNull cxt mt
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 (addOldNode fnLocal values) pm
where
loop fs = case fs of
tyId:valId:rest -> do
cxt <- getContext
ty <- getType' tyId
val <- case ty of
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)
vals <- loop rest
return (val:vals)
[] -> return []
_ -> fail "Malformed metadata node"
parseMetadataKindEntry :: Record -> Parse ()
parseMetadataKindEntry r = do
kind <- parseField r 0 numeric
name <- parseFields r 1 char
addKind kind name