Metadata.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Data.LLVM.BitCode.IR.Metadata (
    parseMetadataBlock
  , parseMetadataKindEntry
  , PartialUnnamedMd(..)
  , finalizePartialUnnamedMd
  , finalizePValMd
  , dedupMetadata
  , InstrMdAttachments
  , PFnMdAttachments
  , PKindMd
  , PGlobalAttachments
  ) where

import           Data.LLVM.BitCode.Bitstream
import           Data.LLVM.BitCode.IR.Constants
import           Data.LLVM.BitCode.Match
import           Data.LLVM.BitCode.Parse
import           Data.LLVM.BitCode.Record
import           Text.LLVM.AST
import           Text.LLVM.Labels

import qualified Codec.Binary.UTF8.String as UTF8 (decode)
import           Control.Applicative ((<|>))
import           Control.Exception (throw)
import           Control.Monad (foldM, guard, mplus, when)
import           Data.Bits (shiftR, testBit, shiftL, (.&.), (.|.), bit, complement)
import           Data.Data (Data)
import           Data.Typeable (Typeable)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as Char8 (unpack)
import           Data.Either (partitionEithers)
import           Data.Generics.Uniplate.Data
import qualified Data.IntMap as IntMap
import           Data.List (mapAccumL, foldl')
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (fromMaybe, mapMaybe)
import qualified Data.Sequence as Seq
import           Data.Sequence (Seq)
import           Data.Word (Word8,Word32,Word64)

import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack, callStack)
import Data.Bifunctor (bimap)



-- Parsing State ---------------------------------------------------------------

data MetadataTable = MetadataTable
  { mtEntries   :: MdTable
  , mtNextNode  :: !Int
  , mtNodes     :: IntMap.IntMap (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     = IntMap.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) }
  where
  -- explicitly make a metadata value out of a normal value
  tv' = Typed { typedType  = PrimType Metadata
              , typedValue = ValMd (ValMdValue tv)
              }

nameNode :: Bool -> Bool -> Int -> MetadataTable -> MetadataTable
nameNode fnLocal isDistinct ix mt = mt
  { mtNodes    = IntMap.insert ix (fnLocal,isDistinct,mtNextNode mt) (mtNodes mt)
  , mtNextNode = mtNextNode mt + 1
  }

addString :: String -> PartialMetadata -> PartialMetadata
addString str pm =
  let (ix, mt) = addMetadata (ValMdString str) (pmEntries pm)
  in pm { pmEntries = mt
        , pmStrings = Map.insert ix str (pmStrings pm)
        }

addStrings :: [String] -> PartialMetadata -> PartialMetadata
addStrings strs pm = foldl' (flip addString) pm 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

-- | A variant of 'addDebugInfo' that only inserts the 'DebugInfo' into the
-- 'mtEntries', not the 'mtNodes'. This has the effect of causing the
-- 'DebugInfo' /not/ to be added to any top-level metadata lists and instead
-- causing it to be printed inline wherever it occurs.
-- See @Note [Printing metadata inline]@.
addInlineDebugInfo :: DebugInfo' Int -> MetadataTable -> MetadataTable
addInlineDebugInfo di mt = mt { mtEntries = addValue tv (mtEntries mt) }
  where
  tv = Typed { typedType  = PrimType Metadata
             , typedValue = ValMd (ValMdDebugInfo di)
             }

-- | 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
  nodeRef           = reference `fmap` IntMap.lookup ix (mtNodes mt)
  fallback          = case forwardRef cxt ix (mtEntries mt) of
                        Typed { typedValue = ValMd md } -> md
                        tv                              -> ValMdValue tv
  reference (False, _, r) = ValMdRef r
  reference (_    , _, r) =
    let explanation = "Illegal forward reference into function-local metadata."
    in throw (BadValueRef callStack cxt explanation r)

mdForwardRefOrNull :: [String] -> MetadataTable -> Int -> Maybe PValMd
mdForwardRefOrNull cxt mt ix | ix > 0 = Just (mdForwardRef cxt mt (ix - 1))
                             | otherwise = Nothing

mdNodeRef :: HasCallStack
          => [String] -> MetadataTable -> Int -> Int
mdNodeRef cxt mt ix = maybe except prj (IntMap.lookup ix (mtNodes mt))
  where explanation   = "Bad forward reference into mtNodes"
        except        = throw (BadValueRef callStack cxt explanation ix)
        prj (_, _, x) = x

mdString :: HasCallStack
         => [String] -> PartialMetadata -> Int -> String
mdString cxt partialMeta ix =
  let explanation = "Null value when metadata string was expected"
  in fromMaybe (throw (BadValueRef callStack cxt explanation ix))
               (mdStringOrNull cxt partialMeta ix)

-- | This preferentially fetches the string from the strict string table
-- (@pmStrings@), but will return a forward reference when it can't find it there.
mdStringOrNull :: HasCallStack
               => [String]
               -> PartialMetadata
               -> Int
               -> Maybe String
mdStringOrNull cxt partialMeta ix =
  Map.lookup (ix - 1) (pmStrings partialMeta) <|>
    case mdForwardRefOrNull cxt (pmEntries partialMeta) ix of
      Nothing                -> Nothing
      Just (ValMdString str) -> Just str
      Just _                 ->
        let explanation = "Non-string metadata when string was expected"
        in throw (BadTypeRef callStack cxt explanation ix)

mdStringOrEmpty :: HasCallStack
                => [String]
                -> PartialMetadata
                -> Int
                -> String
mdStringOrEmpty cxt partialMeta = fromMaybe "" . mdStringOrNull cxt partialMeta

mkMdRefTable :: MetadataTable -> MdRefTable
mkMdRefTable mt = IntMap.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
  , pmGlobalAttachments:: PGlobalAttachments
  , pmStrings          :: Map Int String
  -- ^ Forward references to metadata strings are never actually
  -- forward references, string blocks (@METADATA_STRINGS@) always come first.
  -- So references to them don't need to be inside the @MonadFix@ like
  -- references into other 'pmEntries', allowing them to be strict.
  --
  -- See this comment:
  -- - https://github.com/llvm-mirror/llvm/blob/release_40/lib/Bitcode/Reader/MetadataLoader.cpp#L913
  -- - https://github.com/llvm-mirror/llvm/blob/release_60/lib/Bitcode/Reader/MetadataLoader.cpp#L1017
  } 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
  , pmGlobalAttachments = Map.empty
  , pmStrings           = Map.empty
  }

updateMetadataTable :: (MetadataTable -> MetadataTable)
                    -> (PartialMetadata -> PartialMetadata)
updateMetadataTable f pm = pm { pmEntries = f (pmEntries pm) }

addGlobalAttachments ::
  Symbol {- ^ name of the global to attach to ^ -} ->
  (Map.Map KindMd PValMd) {- ^ metadata references to attach ^ -} ->
  (PartialMetadata -> PartialMetadata)
addGlobalAttachments sym mds pm =
  pm { pmGlobalAttachments = Map.insert sym mds (pmGlobalAttachments 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"

-- De-duplicating ---------------------------------------------------------------

-- | This function generically traverses the given unnamed metadata values.
-- When it encounters one with a 'PValMd' inside of it, it looks up that
-- value in the list. If found, it replaces the value with a reference to it.
--
-- Such de-duplication is necessary because the @fallback@ of
-- 'mdForwardRefOrNull' is often called when it is in fact unnecessary, just
-- because the appropriate references aren't available yet.
--
-- This function is concise at the cost of efficiency: In the worst case, every
-- metadata node contains a reference to every other metadata node, and the
-- cost is O(n^2*log(n)) where
-- * n^2 comes from looking at every 'PValMd' inside every 'PartialUnnamedMd'
-- * log(n) is the cost of looking them up in a 'Map'.
dedupMetadata :: Seq PartialUnnamedMd -> Seq PartialUnnamedMd
dedupMetadata pumd = helper (mkPartialUnnamedMdMap pumd) <$> pumd
  where helper pumdMap pum =
          let pumdMap' = Map.delete (pumValues pum) pumdMap -- don't self-reference
          in pum { pumValues = maybeTransform pumdMap' (pumValues pum) }

        -- | We avoid erroneously recursing into ValMdValues and exit early on
        -- a few other constructors de-duplication wouldn't affect.
        maybeTransform :: Map PValMd Int -> PValMd -> PValMd
        maybeTransform pumdMap v@(ValMdNode _)      = transform (trans pumdMap) v
        maybeTransform pumdMap v@(ValMdLoc _)       = transform (trans pumdMap) v
        maybeTransform pumdMap v@(ValMdDebugInfo _) = transform (trans  pumdMap) v
        maybeTransform _       v                    = v

        trans :: Map PValMd Int -> PValMd -> PValMd
        trans pumdMap v = case Map.lookup v pumdMap of
                            Just idex -> ValMdRef idex
                            Nothing   -> v

        mkPartialUnnamedMdMap :: Seq PartialUnnamedMd -> Map PValMd Int
        mkPartialUnnamedMdMap =
          foldl' (\mp part -> Map.insert (pumValues part) (pumIndex part) mp) Map.empty

-- Finalizing ---------------------------------------------------------------

namedEntries :: PartialMetadata -> Seq NamedMd
namedEntries  = Seq.fromList
              . map (uncurry NamedMd)
              . Map.toList
              . pmNamedEntries

data PartialUnnamedMd = PartialUnnamedMd
  { pumIndex    :: Int
  , pumValues   :: PValMd
  , pumDistinct :: Bool
  } deriving (Data, Eq, Ord, Generic, Show, Typeable)

finalizePartialUnnamedMd :: PartialUnnamedMd -> Finalize UnnamedMd
finalizePartialUnnamedMd pum = mkUnnamedMd `fmap` finalizePValMd (pumValues pum)
  where
  mkUnnamedMd v = UnnamedMd
    { umIndex  = pumIndex pum
    , umValues = v
    , umDistinct = pumDistinct pum
    }

finalizePValMd :: PValMd -> Finalize ValMd
finalizePValMd = relabel requireBbEntryName

-- | Partition unnamed entries into global and function local unnamed entries.
unnamedEntries :: PartialMetadata -> (Seq PartialUnnamedMd, Seq PartialUnnamedMd)
unnamedEntries pm = bimap Seq.fromList Seq.fromList (partitionEithers (mapMaybe resolveNode (IntMap.toList (mtNodes mt))))
  where
  mt = pmEntries pm

  -- TODO: is this silently eating errors with metadata that's not in the
  -- value table (when the lookupValueTableAbs fails)?
  resolveNode :: (Int, (Bool, Bool, Int))
              -> Maybe (Either PartialUnnamedMd PartialUnnamedMd)
  resolveNode (ref,(fnLocal,d,ix)) =
    ((if fnLocal then Right else Left) <$> lookupNode ref d ix)

  lookupNode :: Int -> Bool -> Int -> Maybe PartialUnnamedMd
  lookupNode ref d ix = do
    tv <- lookupValueTableAbs ref (mtEntries mt)
    case tv of
      Typed { typedValue = ValMd v } ->
        pure $! PartialUnnamedMd
          { pumIndex    = ix
          , pumValues   = v
          , pumDistinct = d
          }
      _ -> error "Impossible: Only ValMds are stored in mtEntries"

type InstrMdAttachments = Map.Map Int [(KindMd,PValMd)]

type PKindMd = Int
type PFnMdAttachments = Map.Map PKindMd PValMd
type PGlobalAttachments = Map.Map Symbol (Map.Map KindMd PValMd)

type ParsedMetadata =
  ( Seq NamedMd
  , (Seq PartialUnnamedMd, Seq PartialUnnamedMd)
  , InstrMdAttachments
  , PFnMdAttachments
  , PGlobalAttachments
  )

parsedMetadata :: PartialMetadata -> ParsedMetadata
parsedMetadata pm =
  ( namedEntries pm
  , unnamedEntries pm
  , pmInstrAttachments pm
  , pmFnAttachments pm
  , pmGlobalAttachments 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.
--
-- Based on the function 'parseOneMetadata' in the LLVM source.
parseMetadataEntry :: ValueTable -> MetadataTable -> PartialMetadata -> Entry
                   -> Parse PartialMetadata
parseMetadataEntry vt mt pm (fromEntry -> Just r) =
  let -- The assert* functions below check if a metadata record size matches
      -- what is expected, and if not, emit a warning.
      --
      -- In the past, we made these fatal errors instead of warnings, but we
      -- downgraded them to a warning due to how frequently LLVM adds new
      -- metadata record fields. Moreover, it is usually not a serious problem
      -- for downstream users that llvm-pretty-bc-parser lacks newer metadata
      -- fields, since they usually do not affect the semantics of the overall
      -- LLVM bitcode.
      assertRecordSizeBetween lb ub = do
        cxt <- getContext
        let len = length (recordFields r)
        when (len < lb || ub < len) $
          addParseWarning $
          InvalidMetadataRecordSize len (MetadataRecordSizeBetween lb ub) cxt

      assertRecordSizeIn ns = do
        cxt <- getContext
        let len = length (recordFields r)
        when (not (len `elem` ns)) $
          addParseWarning $
          InvalidMetadataRecordSize len (MetadataRecordSizeIn ns) cxt

      assertRecordSizeAtLeast lb = do
        cxt <- getContext
        let len = length (recordFields r)
        when (len < lb) $
          addParseWarning $
          InvalidMetadataRecordSize len (MetadataRecordSizeAtLeast lb) cxt

      -- Helper for a common pattern which appears below in the parsing
      ron n = do ctx <- getContext
                 mdForwardRefOrNull ctx mt <$> parseField r n numeric

  -- Note: the parsing cases below use a Monadic coding style, as opposed to an
  -- Applicative style (as was originally used) for performance reasons:
  -- Applicative record construction has quadratic size and corresponding
  -- performance impacts (the initial conversion from Applicative to Monadic
  -- saved 11s when parsing a 22MB bitcode file).
  --
  -- Additionally, this module uses RecordWildcards... a pragma that is not
  -- normally advisable but which does work to good effect in this situation to
  -- simplify the following and remove boilerplate intermediary assignments.

  in case recordCode r of
    -- [values]
    1 -> label "METADATA_STRING" $ do
      str <- fmap UTF8.decode (parseFields r 0 char) `mplus` parseField r 0 string
      return $! addString str pm

    -- [type num, value num]
    2 -> label "METADATA_VALUE" $ do
      assertRecordSizeIn [2]
      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 <- fmap UTF8.decode (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 <- UTF8.decode <$> 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/
      assertRecordSizeIn [5, 6]
      let field = parseField r
      cxt        <- getContext
      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
      dlImplicit <- if length (recordFields r) <= 5
                    then pure False
                    else parseField r 5 nonzero
      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")
      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
      assertRecordSizeIn [3, 5]
      field0 <- parseField r 0 unsigned
      let isDistinct = field0 .&. 0 == 1
      -- The format field determines what set of fields are contained in this
      -- record and what their types are (see
      -- https://github.com/llvm/llvm-project/blob/bbe8cd13/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1437-L1444).
      let format = field0 `shiftR` 1
      let asValMdInt64 x = Just $ ValMdValue
                           $ Typed { typedType = PrimType $ Integer 64
                                   , typedValue = ValInteger x
                                   }
      diNode <- case format of
        2 -> do disrCount <- ron 1
                disrLowerBound <- ron 2
                disrUpperBound <- ron 3
                disrStride <- ron 4
                return $ DISubrange {..}
        1 -> do disrCount <- ron 1
                disrLowerBound <- ron 2
                let disrUpperBound = Nothing
                let disrStride = Nothing
                return $ DISubrange {..}
        0 -> do disrCount <- asValMdInt64 <$> parseField r 1 numeric
                disrLowerBound <- asValMdInt64 . fromIntegral <$> parseField r 2 signedInt64
                let disrUpperBound = Nothing
                let disrStride = Nothing
                return $ DISubrange {..}
        _ -> fail $ "Unknown format: " <> show format
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoSubrange diNode)) pm

    -- [isBigInt|isUnsigned|distinct, value, name]
    14 -> label "METADATA_ENUMERATOR" $ do
      assertRecordSizeAtLeast 3
      ctx   <- getContext
      flags <- parseField r 0 numeric
      let isDistinct = testBit (flags :: Int) 0
          isUnsigned = testBit (flags :: Int) 1
          isBigInt   = testBit (flags :: Int) 2
      name  <- mdString ctx pm <$> parseField r 2 numeric
      value <-
        if isBigInt
          -- LLVM 12 or later
          then parseWideInteger r 3
          -- Pre-LLVM 12
          else toInteger <$> parseField r 1 signedInt64
      let diEnum = DebugInfoEnumerator name value isUnsigned
      return $! updateMetadataTable (addDebugInfo isDistinct diEnum) pm

    15 -> label "METADATA_BASIC_TYPE" $ do
      assertRecordSizeIn [6, 7]
      ctx        <- getContext
      isDistinct <- parseField r 0 nonzero
      dibtTag <- parseField r 1 numeric
      dibtName <- mdString ctx pm <$> parseField r 2 numeric
      dibtSize <- parseField r 3 numeric
      dibtAlign <- parseField r 4 numeric
      dibtEncoding <- parseField r 5 numeric
      dibtFlags <- if length (recordFields r) <= 6
                   then pure Nothing
                   else Just <$> parseField r 6 numeric
      let dibt = DIBasicType {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoBasicType dibt)) pm

    -- [distinct, filename, directory]
    16 -> label "METADATA_FILE" $ do
      assertRecordSizeIn [3, 5]
      ctx        <- getContext
      isDistinct <- parseField r 0 nonzero
      difFilename <- mdStringOrEmpty ctx pm <$> parseField r 1 numeric
      difDirectory <- mdStringOrEmpty ctx pm <$> parseField r 2 numeric
      let diFile = DIFile {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoFile diFile)) pm

    17 -> label "METADATA_DERIVED_TYPE" $ do
      -- While upstream LLVM currently imposes a maximum of 14 records per
      -- entry, we raise this to 15 for the sake of parsing Apple LLVM.
      -- See Note [Apple LLVM].
      assertRecordSizeBetween 12 15
      ctx        <- getContext
      isDistinct <- parseField r 0 nonzero
      didtTag <- parseField r 1 numeric
      didtName <- mdStringOrNull ctx pm <$> parseField r 2 numeric
      didtFile <- ron 3
      didtLine <- parseField r 4 numeric
      didtScope <- ron 5
      didtBaseType <- ron 6
      didtSize <- parseField r 7 numeric
      didtAlign <- parseField r 8 numeric
      didtOffset <- parseField r 9 numeric
      didtFlags <- parseField r 10 numeric
      didtExtraData <- ron 11
      didtDwarfAddressSpace <-
        if length (recordFields r) <= 12
        then pure Nothing  -- field not present
        else do v <- parseField r 12 numeric
                -- dwarf address space is encoded in bitcode as +1; a value of
                -- zero means there is no dwarf address space present:
                -- https://github.com/llvm/llvm-project/blob/bbe8cd1/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1544-L1548
                -- The AST representation is the actual address space, or Nothing
                -- if there is no address space (indistinguishable from "field
                -- not present" for LLVM 4 and earlier).
                if v == 0
                  then return Nothing
                  else return $ Just $ v - 1
      didtAnnotations <- if length (recordFields r) <= 13
                         then pure Nothing
                         else ron 13
      let didt = DIDerivedType {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoDerivedType didt)) pm

    18 -> label "METADATA_COMPOSITE_TYPE" $ do
      assertRecordSizeBetween 16 22
      ctx        <- getContext
      isDistinct <- parseField r 0 nonzero
      dictTag <- parseField r 1 numeric
      dictName <- mdStringOrNull ctx pm <$> parseField r 2 numeric
      dictFile <- ron 3
      dictLine <- parseField r 4 numeric
      dictScope <- ron 5
      dictBaseType <- ron 6
      dictSize <- parseField r 7 numeric
      dictAlign <- parseField r 8 numeric
      dictOffset <- parseField r 9 numeric
      dictFlags <- parseField r 10 numeric
      dictElements <- ron 11
      dictRuntimeLang <- parseField r 12 numeric
      dictVTableHolder <- ron 13
      dictTemplateParams <- ron 14
      dictIdentifier <- mdStringOrNull ctx pm <$> parseField r 15 numeric
      dictDiscriminator <- if length (recordFields r) <= 16
                           then pure Nothing
                           else ron 16
      dictDataLocation <- if length (recordFields r) <= 17
                          then pure Nothing
                          else ron 17
      dictAssociated <- if length (recordFields r) <= 18
                        then pure Nothing
                        else ron 18
      dictAllocated <- if length (recordFields r) <= 19
                       then pure Nothing
                       else ron 19
      dictRank <- if length (recordFields r) <= 20
                  then pure Nothing
                  else ron 20
      dictAnnotations <- if length (recordFields r) <= 21
                         then pure Nothing
                         else ron 21
      let dict = DICompositeType {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoCompositeType dict)) pm

    19 -> label "METADATA_SUBROUTINE_TYPE" $ do
      assertRecordSizeBetween 3 4
      isDistinct <- parseField r 0 nonzero
      distFlags <- parseField r 1 numeric
      distTypeArray <- ron 2
      let dist = DISubroutineType {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoSubroutineType dist)) pm

    20 -> label "METADATA_COMPILE_UNIT" $ do
      assertRecordSizeBetween 14 22
      let recordSize = length (recordFields r)
      ctx        <- getContext
      isDistinct <- parseField r 0 nonzero
      dicuLanguage <- parseField r 1 numeric
      dicuFile <- ron 2
      dicuProducer <- mdStringOrNull ctx pm <$> parseField r 3 numeric
      dicuIsOptimized <- parseField r 4 nonzero
      dicuFlags <- mdStringOrNull ctx pm <$> parseField r 5 numeric
      dicuRuntimeVersion <- parseField r 6 numeric
      dicuSplitDebugFilename <- mdStringOrNull ctx pm <$> parseField r 7 numeric
      dicuEmissionKind <- parseField r 8 numeric
      dicuEnums <- ron 9
      dicuRetainedTypes <- ron 10
      dicuSubprograms <- ron 11
      dicuGlobals <- ron 12
      dicuImports <- ron 13
      dicuMacros <- if recordSize <= 15
                    then pure Nothing
                    else ron 15
      dicuDWOId <- if recordSize <= 14
                   then pure 0
                   else parseField r 14 numeric
      dicuSplitDebugInlining <- if recordSize <= 16
                                then pure True
                                else parseField r 16 nonzero
      dicuDebugInfoForProf <- if recordSize <= 17
                              then pure False
                              else parseField r 17 nonzero
      dicuNameTableKind <- if recordSize <= 18
                           then pure 0
                           else parseField r 18 numeric
      dicuRangesBaseAddress <- if recordSize <= 19
                               then pure False
                               else parseField r 19 nonzero
      dicuSysRoot <- if recordSize <= 20
                     then pure Nothing
                     else mdStringOrNull ctx pm <$> parseField r 20 numeric
      dicuSDK <- if recordSize <= 21
                 then pure Nothing
                 else mdStringOrNull ctx pm <$> parseField r 21 numeric
      let dicu = DICompileUnit {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoCompileUnit dicu)) pm


    21 -> label "METADATA_SUBPROGRAM" $ do
      -- this one is a bit funky:
      -- https://github.com/llvm/llvm-project/blob/release/10.x/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1486

      assertRecordSizeBetween 18 21

      -- A "version" is encoded in the high-order bits of the isDistinct field.
      version <- parseField r 0 numeric

      let hasSPFlags = (version .&. (0x4 :: Word64)) /= 0;

      (diFlags0, spFlags0) <-
        if hasSPFlags then
          (,) <$> parseField r 11 numeric <*> parseField r 9 numeric
        else
          (,) <$> parseField r (11 + 2) numeric <*> pure 0

      let diFlagMainSubprogram = bit 21 :: Word32
          hasOldMainSubprogramFlag = (diFlags0 .&. diFlagMainSubprogram) /= 0

          -- CF https://github.com/llvm/llvm-project/blob/release/10.x/llvm/include/llvm/IR/DebugInfoFlags.def
          spFlagIsLocal      = bit 2
          spFlagIsDefinition = bit 3
          spFlagIsOptimized  = bit 4
          spFlagIsMain       = bit 8

          dispFlags :: Word32
          dispFlags
            | hasOldMainSubprogramFlag = diFlags0 .&. complement diFlagMainSubprogram
            | otherwise                = diFlags0

          spFlags :: Word32
          spFlags
            | hasOldMainSubprogramFlag = spFlags0 .|. spFlagIsMain
            | otherwise                = spFlags0

      -- TODO, isMain isn't exposed via DISubprogram
      (dispIsLocal, dispIsDefinition, dispIsOptimized, dispVirtuality, _isMain) <-
        if hasSPFlags then
          let spIsLocal       = spFlags .&. spFlagIsLocal /= 0
              spIsDefinition  = spFlags .&. spFlagIsDefinition /= 0
              spIsOptimized   = spFlags .&. spFlagIsOptimized /= 0
              spIsMain        = spFlags .&. spFlagIsMain /= 0
              spVirtuality :: Word8
              spVirtuality    = fromIntegral (spFlags .&. 0x3)
           in return (spIsLocal, spIsDefinition, spIsOptimized, spVirtuality, spIsMain)
        else
          do spIsLocal <- parseField r 7 nonzero
             spIsDefinition <- parseField r 8 nonzero
             spIsOptimized <- parseField r 14 nonzero
             spVirtuality <- parseField r 11 numeric
             return (spIsLocal, spIsDefinition, spIsOptimized, spVirtuality, hasOldMainSubprogramFlag)

      let recordSize = length (recordFields r)

          isDistinct = (version .&. 0x1 /= 0) || (spFlags .&. spFlagIsDefinition /= 0)

          hasUnit = version .&. 0x2 /= 0

          offsetA
            | not hasSPFlags = 2
            | otherwise      = 0

          offsetB
            | not hasSPFlags && recordSize >= 19 = 3
            | not hasSPFlags                     = 2
            | otherwise                          = 0

          -- this doesn't seem to be used in our parser...
          --hasFn
          --  | not hasSPFlags && recordSize >= 19 = not hasUnit
          --  | otherwise = False

          hasThisAdjustment
            | not hasSPFlags = recordSize >= 20
            | otherwise      = True

          hasThrownTypes
            | not hasSPFlags = recordSize >= 21
            | otherwise      = True

          hasAnnotations
            | not hasSPFlags = False
            | otherwise      = recordSize >= 19

      -- Some additional sanity checking
      when (not hasSPFlags && hasUnit)
           (assertRecordSizeBetween 19 21)

      when (hasSPFlags && not hasUnit)
           (fail "DISubprogram record has subprogram flags, but does not have unit.  Invalid record.")

      ctx <- getContext

      -- Forward references that depend on the 'version'
      let optFwdRef b n =
            if b
            then mdForwardRefOrNull ctx mt <$> parseField r n numeric
            else pure Nothing

      dispScope <- ron 1
      dispName <- mdStringOrNull ctx pm <$> parseField r 2 numeric
      dispLinkageName <- mdStringOrNull ctx pm <$> parseField r 3 numeric
      dispFile <- ron 4
      dispLine <- parseField r 5 numeric
      dispType <- ron 6
      dispScopeLine <- parseField r (7 + offsetA) numeric
      dispContainingType <- ron (8 + offsetA)
      dispVirtualIndex <- parseField r (10 + offsetA) numeric
      dispThisAdjustment <- if hasThisAdjustment
                            then parseField r (16 + offsetB) numeric
                            else return 0
      dispUnit <- optFwdRef hasUnit (12 + offsetB)
      dispTemplateParams <- ron (13 + offsetB)
      dispDeclaration <- ron (14 + offsetB)
      dispRetainedNodes <- ron (15 + offsetB)
      dispThrownTypes <- optFwdRef hasThrownTypes (17 + offsetB)
      dispAnnotations <- optFwdRef hasAnnotations (18 + offsetB)

      let disp = DISubprogram {..}

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

    22 -> label "METADATA_LEXICAL_BLOCK" $ do
      assertRecordSizeIn [5]
      isDistinct <- parseField r 0 nonzero
      dilbScope <- ron 1
      dilbFile <- ron 2
      dilbLine <- parseField r 3 numeric
      dilbColumn <- parseField r 4 numeric
      let dilb = DILexicalBlock {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoLexicalBlock dilb)) pm

    23 -> label "METADATA_LEXICAL_BLOCK_FILE" $ do
      assertRecordSizeIn [4]
      cxt        <- getContext
      isDistinct <- parseField r 0 nonzero
      dilbfScope <- mdForwardRef cxt mt <$> parseField r 1 numeric
      dilbfFile <- ron 2
      dilbfDiscriminator <- parseField r 3 numeric
      let dilbf = DILexicalBlockFile {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoLexicalBlockFile dilbf)) pm

    24 -> label "METADATA_NAMESPACE" $ do
      assertRecordSizeIn [3, 5]
      let isNew = length (recordFields r) == 3
      let nameIdx = if isNew then 2 else 3

      cxt        <- getContext
      isDistinct <- parseField r 0 nonzero
      dinsName <- mdStringOrNull cxt pm <$> parseField r nameIdx numeric
      dinsScope <- mdForwardRef cxt mt <$> parseField r 1 numeric
      dinsFile <- if isNew
                  then return (ValMdString "")
                  else mdForwardRef cxt mt <$> parseField r 2 numeric
      dinsLine <- if isNew then return 0 else parseField r 4 numeric
      let dins = DINameSpace {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoNameSpace dins)) pm

    25 -> label "METADATA_TEMPLATE_TYPE" $ do
      assertRecordSizeIn [3, 4]
      let hasIsDefault = length (recordFields r) == 4
      cxt <- getContext
      isDistinct <- parseField r 0 nonzero
      dittpName <- mdStringOrNull cxt pm <$> parseField r 1 numeric
      dittpType <- ron 2
      dittpIsDefault <- if hasIsDefault
                        then Just <$> parseField r 3 boolean
                        else pure Nothing
      let dittp = DITemplateTypeParameter {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoTemplateTypeParameter dittp)) pm

    26 -> label "METADATA_TEMPLATE_VALUE" $ do
      assertRecordSizeIn [5, 6]
      let hasIsDefault = length (recordFields r) == 6
      cxt        <- getContext
      isDistinct <- parseField r 0 nonzero
      ditvpTag <- parseField r 1 numeric
      ditvpName <- mdStringOrNull cxt pm <$> parseField r 2 numeric
      ditvpType <- ron 3
      ditvpIsDefault <- if hasIsDefault
                        then Just <$> parseField r 4 boolean
                        else pure Nothing
      ditvpValue <- mdForwardRef cxt mt <$> parseField r (if hasIsDefault then 5 else 4) numeric
      let ditvp = DITemplateValueParameter {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoTemplateValueParameter ditvp)) pm

    27 -> label "METADATA_GLOBAL_VAR" $ do
      assertRecordSizeBetween 11 13
      ctx        <- getContext
      field0     <- parseField r 0 numeric
      let isDistinct = testBit field0 0
          _version   = shiftR  field0 1 :: Int

      digvScope <- ron 1
      digvName <- mdStringOrNull ctx pm <$> parseField r 2 numeric
      digvLinkageName <- mdStringOrNull ctx pm <$> parseField r 3 numeric
      digvFile <- ron 4
      digvLine <- parseField r 5 numeric
      digvType <- ron 6
      digvIsLocal <- parseField r 7 nonzero
      digvIsDefinition <- parseField r 8 nonzero
      digvVariable <- ron 9
      digvDeclaration <- ron 10
      digvAlignment <- if length (recordFields r) > 11
                       then Just <$> parseField r 11 numeric
                       else pure Nothing
      digvAnnotations <- if length (recordFields r) > 12
                         then ron 12
                         else pure Nothing
      let digv = DIGlobalVariable {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoGlobalVariable digv)) 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
      assertRecordSizeBetween 8 10
      ctx    <- getContext
      field0 <- parseField r 0 numeric
      let isDistinct   = testBit (field0 :: Word32) 0
          hasAlignment = testBit (field0 :: Word32) 1

          hasTag | not hasAlignment && length (recordFields r) > 8 = 1
                 | otherwise                                       = 0

          adj i = i + hasTag


      dilvScope <- mdForwardRefOrNull ("dilvScope":ctx) mt
                   <$> parseField r (adj 1) numeric
      dilvName <- mdStringOrNull     ("dilvName" :ctx) pm
                  <$> parseField r (adj 2) numeric
      dilvFile <- mdForwardRefOrNull ("dilvFile" :ctx) mt
                  <$> parseField r (adj 3) numeric
      dilvLine <- parseField r (adj 4) numeric
      dilvType <- mdForwardRefOrNull ("dilvType" :ctx) mt
                  <$> parseField r (adj 5) numeric
      dilvArg <- parseField r (adj 6) numeric
      dilvFlags <- parseField r (adj 7) numeric
      dilvAlignment <-
        if hasAlignment
          then do n <- parseField r 8 numeric
                  when ((n :: Word64) > fromIntegral (maxBound :: Word32))
                        (fail "Alignment value is too large")
                  return $ Just (fromIntegral n :: Word32)
          else return Nothing
      dilvAnnotations <- if hasAlignment && length (recordFields r) > 9
                          then ron 9
                          else pure Nothing
      let dilv = DILocalVariable {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoLocalVariable dilv)) pm

    29 -> label "METADATA_EXPRESSION" $ do
      {-
      Although DIExpressions store an `isDistinct` field in LLVM bitcode, it is
      never used in practice. This is because DIExpressions are always printed
      inline in definitions, and since the `distinct` keyword is only printed in
      top-level metadata lists, there is no way for `distinct` to be printed
      before a DIExpression. See also Note [Printing metadata inline].
      -}
      -- isDistinct <- parseField r 0 nonzero
      diExpr     <- DebugInfoExpression . DIExpression <$> parseFields r 1 numeric
      return $! updateMetadataTable (addInlineDebugInfo diExpr) pm

    30 -> label "METADATA_OBJC_PROPERTY" $ do
      -- TODO
      fail "not yet implemented"

    31 -> label "METADATA_IMPORTED_ENTITY" $ do
      assertRecordSizeIn [6, 7]
      cxt        <- getContext
      isDistinct <- parseField r 0 nonzero
      diieTag <- parseField r 1 numeric
      diieScope <- ron 2
      diieEntity <- ron 3
      diieFile <- if length (recordFields r) >= 7
                  then ron 6
                  else pure Nothing
      diieLine <- parseField r 4 numeric
      diieName <- mdStringOrNull cxt pm <$> parseField r 5 numeric
      let diie = DIImportedEntity {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoImportedEntity diie)) pm

    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
      assertRecordSizeIn [3]
      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 $! addStrings strings pm

    -- [ valueid, n x [id, mdnode] ]
    36 -> label "METADATA_GLOBAL_DECL_ATTACHMENT" $ do

      -- the record will always be of odd length
      when (mod (length (recordFields r)) 2 == 0)
          (fail "Invalid record")

      valueId <- parseField r 0 numeric
      sym     <- case lookupValueTableAbs valueId vt of
                  Just (Typed { typedValue = ValSymbol sym }) -> return sym
                  _ -> fail "Non-global referenced"

      refs <- parseGlobalObjectAttachment mt r

      return $! addGlobalAttachments sym refs pm

    37 -> label "METADATA_GLOBAL_VAR_EXPR" $ do
      assertRecordSizeIn [3]
      isDistinct <- parseField r 0 nonzero
      digveVariable <- ron 1
      digveExpression <- ron 2
      let digve = DIGlobalVariableExpression {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoGlobalVariableExpression digve)) pm

    38 -> label "METADATA_INDEX_OFFSET" $ do
      assertRecordSizeIn [2]
      a <- parseField r 0 numeric
      b <- parseField r 1 numeric
      let _offset = a + (b `shiftL` 32) :: Word64

      -- TODO: is it OK to skip this if we always parse everything?
      return pm


    -- In the llvm source, this node is processed when the INDEX_OFFSET record is
    -- found.
    39 -> label "METADATA_INDEX" $ do
      -- TODO: is it OK to skip this if we always parse everything?
      return pm

    40 -> label "METADATA_LABEL" $ do
      assertRecordSizeIn [5]
      cxt        <- getContext
      isDistinct <- parseField r 0 nonzero
      dilScope <- ron 1
      dilName <- mdString cxt pm <$> parseField r 2 numeric
      dilFile <- ron 3
      dilLine <- parseField r 4 numeric
      let dil = DILabel {..}
      return $! updateMetadataTable
        (addDebugInfo isDistinct (DebugInfoLabel dil)) pm

    41 -> label "METADATA_STRING_TYPE" $ do
      notImplemented

    -- Codes 42 and 43 are reserved for Fortran array–specific debug info, see
    -- https://github.com/llvm/llvm-project/blob/4681f6111e655057f5015564a9bf3705f87495bf/llvm/include/llvm/Bitcode/LLVMBitCodes.h#L348-L349

    44 -> label "METADATA_COMMON_BLOCK" $ do
      notImplemented

    45 -> label "METADATA_GENERIC_SUBRANGE" $ do
      notImplemented

    46 -> label "METADATA_ARG_LIST" $ do
      cxt <- getContext
      dial <- DIArgList
        <$> (map (mdForwardRef cxt mt) <$> parseFields r 0 numeric)
      return $! updateMetadataTable
        (addInlineDebugInfo (DebugInfoArgList dial)) pm


    code -> fail ("unknown record code: " ++ show code)

parseMetadataEntry _ _ pm (abbrevDef -> Just _) =
  return pm

parseMetadataEntry _ _ _ r =
  fail ("unexpected metadata entry: " ++ 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)


-- | This is a named version of the metadata list that can show up at the end of
-- a global declaration. It will be of the form @!dbg !2 [!dbg !n, ...]@.
parseGlobalObjectAttachment :: MetadataTable -> Record -> Parse (Map.Map KindMd PValMd)
parseGlobalObjectAttachment mt r = label "parseGlobalObjectAttachment" $
  do cxt <- getContext
     go cxt Map.empty 1
  where
  len = length (recordFields r)

  go cxt acc n | n < len =
    do kind <- getKind =<< parseField r n numeric
       i    <- parseField r (n + 1) numeric
       go cxt (Map.insert kind (mdForwardRef cxt mt i) acc) (n + 2)

  go _ acc _ =
       return 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 (UTF8.decode name)

{-
Note [Apple LLVM]
~~~~~~~~~~~~~~~~~
Apple maintains a fork of LLVM, whose source code can be found at
https://github.com/apple/llvm-project. The version of Clang that is shipped
with Xcode, and thereby the de facto default Clang version on macOS, is based
on this LLVM fork. To distinguish between the two LLVM codebases, we will refer
to "upstream LLVM" and "Apple LLVM" throughout this Note.

One of the more noticeable differences between upstream and Apple LLVM is that
Apple LLVM uses a slightly different bitcode format. In particular, Apple LLVM
has support for pointer authentication
(https://lists.llvm.org/pipermail/llvm-dev/2019-October/136091.html), which
requires adding an extra record to the METADATA_DERIVED_TYPE entry that is not
present in upstream LLVM. This impacts llvm-pretty-bc-parser, as we currently
check that the number of records does not exceed a certain maximum, but this
maximum is different depending on whether we parse upstream or Apple LLVM
bitcode.

For now, we work around this issue by raising the maximum number of
METADATA_DERIVED_TYPE records by one to accommodate Apple LLVM, but we do not
actually parse any information related to pointer authentication. This should
work provided that Apple LLVM continues to encode pointer authentication–related
metadata in the same part of METADATA_DERIVED_TYPE in future releases. If this
assumption does not hold true in the future, we will likely need a more
sophisticated solution that involves parsing the bitcode differently depending
on what Apple LLVM version was used to produce a bitcode file.

Note [Printing metadata inline]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There are some forms of metadata that we should always print inline and never
create entries for in top-level metadata lists (named or otherwise). Currently,
these forms of metadata are:

* DIExpression
* DIArgList

This list is taken from the LLVM source code here:
https://github.com/llvm/llvm-project/blob/65600cb2a7e940babf6c493503b9d3fd19f8cb06/llvm/lib/IR/AsmWriter.cpp#L1242-L1245

Implementation-wise, this is accomplished by using `addInlineDebugInfo`. Unlike
`addDebugInfo`, this inserts the metadata field into a separate `mtEntries` map
that is not used to populate top-level metadata lists when pretty-printing an
LLVM module.
-}