{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ViewPatterns #-}

module Data.LLVM.BitCode.IR.Module where

import Data.LLVM.BitCode.Bitstream
import Data.LLVM.BitCode.IR.Attrs
import Data.LLVM.BitCode.IR.Blocks
import Data.LLVM.BitCode.IR.Constants
import Data.LLVM.BitCode.IR.Function
import Data.LLVM.BitCode.IR.Globals
import Data.LLVM.BitCode.IR.Metadata
import Data.LLVM.BitCode.IR.Types
import Data.LLVM.BitCode.IR.Values
import Data.LLVM.BitCode.Match
import Data.LLVM.BitCode.Parse
import Data.LLVM.BitCode.Record
import Text.LLVM.AST
import Text.LLVM.Triple.AST (TargetTriple)
import Text.LLVM.Triple.Parse (parseTriple)

import qualified Codec.Binary.UTF8.String as UTF8 (decode)
import Control.Monad (foldM,guard,when,forM_)
import Data.List (sortOn)
import qualified Data.Foldable as F
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import qualified Data.Traversable as T


-- Module Block Parsing --------------------------------------------------------

data PartialModule = PartialModule
  { PartialModule -> Int
partialGlobalIx   :: !Int
  , PartialModule -> GlobalList
partialGlobals    :: GlobalList
  , PartialModule -> DefineList
partialDefines    :: DefineList
  , PartialModule -> DeclareList
partialDeclares   :: DeclareList
  , PartialModule -> TargetTriple
partialTriple     :: TargetTriple
  , PartialModule -> DataLayout
partialDataLayout :: DataLayout
  , PartialModule -> InlineAsm
partialInlineAsm  :: InlineAsm
  , PartialModule -> Seq (String, SelectionKind)
partialComdat     :: !(Seq (String,SelectionKind))
  , PartialModule -> Int
partialAliasIx    :: !Int
  , PartialModule -> AliasList
partialAliases    :: AliasList
  , PartialModule -> Seq NamedMd
partialNamedMd    :: !(Seq NamedMd)
  , PartialModule -> Seq PartialUnnamedMd
partialUnnamedMd  :: !(Seq PartialUnnamedMd)
  , PartialModule -> Seq String
partialSections   :: !(Seq String)
  , PartialModule -> Maybe String
partialSourceName :: !(Maybe String)
  }

emptyPartialModule :: PartialModule
emptyPartialModule :: PartialModule
emptyPartialModule  = PartialModule
  { partialGlobalIx :: Int
partialGlobalIx   = Int
0
  , partialGlobals :: GlobalList
partialGlobals    = GlobalList
forall a. Monoid a => a
mempty
  , partialDefines :: DefineList
partialDefines    = DefineList
forall a. Monoid a => a
mempty
  , partialDeclares :: DeclareList
partialDeclares   = DeclareList
forall a. Monoid a => a
mempty
  , partialTriple :: TargetTriple
partialTriple     = TargetTriple
forall a. Monoid a => a
mempty
  , partialDataLayout :: DataLayout
partialDataLayout = DataLayout
forall a. Monoid a => a
mempty
  , partialInlineAsm :: InlineAsm
partialInlineAsm  = InlineAsm
forall a. Monoid a => a
mempty
  , partialAliasIx :: Int
partialAliasIx    = Int
0
  , partialAliases :: AliasList
partialAliases    = AliasList
forall a. Monoid a => a
mempty
  , partialNamedMd :: Seq NamedMd
partialNamedMd    = Seq NamedMd
forall a. Monoid a => a
mempty
  , partialUnnamedMd :: Seq PartialUnnamedMd
partialUnnamedMd  = Seq PartialUnnamedMd
forall a. Monoid a => a
mempty
  , partialSections :: Seq String
partialSections   = Seq String
forall a. Monoid a => a
mempty
  , partialSourceName :: Maybe String
partialSourceName = Maybe String
forall a. Monoid a => a
mempty
  , partialComdat :: Seq (String, SelectionKind)
partialComdat     = Seq (String, SelectionKind)
forall a. Monoid a => a
mempty
  }

-- | Fixup the global variables and declarations, and return the completed
-- module.
finalizeModule :: PartialModule -> Parse Module
finalizeModule :: PartialModule -> Parse Module
finalizeModule PartialModule
pm = String -> Parse Module -> Parse Module
forall a. String -> Parse a -> Parse a
label String
"finalizeModule" (Parse Module -> Parse Module) -> Parse Module -> Parse Module
forall a b. (a -> b) -> a -> b
$ do
  Seq Global
globals  <- (PartialGlobal -> Parse Global) -> GlobalList -> Parse (Seq Global)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
T.mapM PartialGlobal -> Parse Global
finalizeGlobal       (PartialModule -> GlobalList
partialGlobals PartialModule
pm)
  Seq Declare
declares <- (FunProto -> Parse Declare) -> DeclareList -> Parse (Seq Declare)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
T.mapM FunProto -> Parse Declare
finalizeDeclare      (PartialModule -> DeclareList
partialDeclares PartialModule
pm)
  Seq GlobalAlias
aliases  <- (PartialAlias -> Parse GlobalAlias)
-> AliasList -> Parse (Seq GlobalAlias)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
T.mapM PartialAlias -> Parse GlobalAlias
finalizePartialAlias (PartialModule -> AliasList
partialAliases PartialModule
pm)
  Seq UnnamedMd
unnamed  <- Finalize (Seq UnnamedMd) -> Parse (Seq UnnamedMd)
forall a. Finalize a -> Parse a
liftFinalize (Finalize (Seq UnnamedMd) -> Parse (Seq UnnamedMd))
-> Finalize (Seq UnnamedMd) -> Parse (Seq UnnamedMd)
forall a b. (a -> b) -> a -> b
$ (PartialUnnamedMd -> Finalize UnnamedMd)
-> Seq PartialUnnamedMd -> Finalize (Seq UnnamedMd)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
T.mapM PartialUnnamedMd -> Finalize UnnamedMd
finalizePartialUnnamedMd (Seq PartialUnnamedMd -> Seq PartialUnnamedMd
dedupMetadata (PartialModule -> Seq PartialUnnamedMd
partialUnnamedMd PartialModule
pm))
  [TypeDecl]
types    <- Parse [TypeDecl]
resolveTypeDecls
  let lkp :: BlockLookup
lkp = DefineList -> BlockLookup
lookupBlockName (PartialModule -> DefineList
partialDefines PartialModule
pm)
  Seq Define
defines <- (PartialDefine -> Parse Define) -> DefineList -> Parse (Seq Define)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seq a -> m (Seq b)
T.mapM (BlockLookup -> PartialDefine -> Parse Define
finalizePartialDefine BlockLookup
lkp) (PartialModule -> DefineList
partialDefines PartialModule
pm)
  Module -> Parse Module
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Module
emptyModule
    { modSourceName = partialSourceName pm
    , modTriple     = partialTriple pm
    , modDataLayout = partialDataLayout pm
    , modNamedMd    = F.toList (partialNamedMd pm)
    , modUnnamedMd  = sortOn umIndex (F.toList unnamed)
    , modGlobals    = F.toList globals
    , modDefines    = F.toList defines
    , modTypes      = types
    , modDeclares   = F.toList declares
    , modInlineAsm  = partialInlineAsm pm
    , modAliases    = F.toList aliases
    , modComdat     = Map.fromList (F.toList (partialComdat pm))
    }

-- | Parse an LLVM Module out of the top-level block in a Bitstream.
parseModuleBlock :: [Entry] -> Parse Module
parseModuleBlock :: [Entry] -> Parse Module
parseModuleBlock [Entry]
ents = String -> Parse Module -> Parse Module
forall a. String -> Parse a -> Parse a
label String
"MODULE_BLOCK" (Parse Module -> Parse Module) -> Parse Module -> Parse Module
forall a b. (a -> b) -> a -> b
$ do

  -- the explicit type symbol table has been removed in 3.1, so we parse the
  -- type table, and generate the type symbol table from it.
  TypeSymtab
tsymtab <- String -> Parse TypeSymtab -> Parse TypeSymtab
forall a. String -> Parse a -> Parse a
label String
"type symbol table" (Parse TypeSymtab -> Parse TypeSymtab)
-> Parse TypeSymtab -> Parse TypeSymtab
forall a b. (a -> b) -> a -> b
$ do
    Maybe [Entry]
mb <- Match [Entry] (Maybe [Entry]) -> [Entry] -> Parse (Maybe [Entry])
forall i a. Match i a -> i -> Parse a
match (Match Entry [Entry] -> Match [Entry] (Maybe [Entry])
forall a b. Match a b -> Match [a] (Maybe b)
findMatch Match Entry [Entry]
typeBlockIdNew) [Entry]
ents
    case Maybe [Entry]
mb of
      Just [Entry]
es -> [Entry] -> Parse TypeSymtab
parseTypeBlock [Entry]
es
      Maybe [Entry]
Nothing -> TypeSymtab -> Parse TypeSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return TypeSymtab
forall a. Monoid a => a
mempty

  TypeSymtab -> Parse Module -> Parse Module
forall a. TypeSymtab -> Parse a -> Parse a
withTypeSymtab TypeSymtab
tsymtab (Parse Module -> Parse Module) -> Parse Module -> Parse Module
forall a b. (a -> b) -> a -> b
$ String -> Parse Module -> Parse Module
forall a. String -> Parse a -> Parse a
label String
"value symbol table" (Parse Module -> Parse Module) -> Parse Module -> Parse Module
forall a b. (a -> b) -> a -> b
$ do
    -- parse the value symbol table out first, if there is one
    ValueSymtab
symtab <- do
      Maybe [Entry]
mb <- Match [Entry] (Maybe [Entry]) -> [Entry] -> Parse (Maybe [Entry])
forall i a. Match i a -> i -> Parse a
match (Match Entry [Entry] -> Match [Entry] (Maybe [Entry])
forall a b. Match a b -> Match [a] (Maybe b)
findMatch Match Entry [Entry]
valueSymtabBlockId) [Entry]
ents
      case Maybe [Entry]
mb of
        Just [Entry]
es -> [Entry] -> Parse ValueSymtab
parseValueSymbolTableBlock [Entry]
es
        Maybe [Entry]
Nothing -> ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ValueSymtab
emptyValueSymtab

    PartialModule
pm <- ValueSymtab -> Parse PartialModule -> Parse PartialModule
forall a. ValueSymtab -> Parse a -> Parse a
withValueSymtab ValueSymtab
symtab
        (Parse PartialModule -> Parse PartialModule)
-> Parse PartialModule -> Parse PartialModule
forall a b. (a -> b) -> a -> b
$ (PartialModule -> Entry -> Parse PartialModule)
-> PartialModule -> [Entry] -> Parse PartialModule
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM PartialModule -> Entry -> Parse PartialModule
parseModuleBlockEntry PartialModule
emptyPartialModule [Entry]
ents

    PartialModule -> Parse Module
finalizeModule PartialModule
pm


-- | Parse the entries in a module block.
parseModuleBlockEntry :: PartialModule -> Entry -> Parse PartialModule

parseModuleBlockEntry :: PartialModule -> Entry -> Parse PartialModule
parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
blockInfoBlockId -> Just [Entry]
_) =
  -- skip the block info block, as we only use it during Bitstream parsing.
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
typeBlockIdNew -> Just [Entry]
_) = do
  -- TYPE_BLOCK_ID_NEW
  -- this is skipped, as it's parsed before anything else, in parseModuleBlock
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
constantsBlockId -> Just [Entry]
es) = do
  -- CONSTANTS_BLOCK_ID
  [Entry] -> Parse ()
parseConstantsBlock [Entry]
es
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeFunction -> Just Record
r) = do
  -- MODULE_CODE_FUNCTION
  Record -> PartialModule -> Parse PartialModule
parseFunProto Record
r PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
functionBlockId -> Just [Entry]
es) = String -> Parse PartialModule -> Parse PartialModule
forall a. String -> Parse a -> Parse a
label String
"FUNCTION_BLOCK_ID" (Parse PartialModule -> Parse PartialModule)
-> Parse PartialModule -> Parse PartialModule
forall a b. (a -> b) -> a -> b
$ do
  let unnamedGlobalsCount :: Int
unnamedGlobalsCount = Seq PartialUnnamedMd -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PartialModule -> Seq PartialUnnamedMd
partialUnnamedMd PartialModule
pm)
  PartialDefine
def <- Int -> [Entry] -> Parse PartialDefine
parseFunctionBlock Int
unnamedGlobalsCount [Entry]
es
  let def' :: PartialDefine
def' = PartialDefine
def { partialGlobalMd = mempty }
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm { partialDefines = partialDefines pm Seq.|> def'
            , partialUnnamedMd = partialGlobalMd def <> partialUnnamedMd pm
            }

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
paramattrBlockId -> Just [Entry]
_) = do
  -- PARAMATTR_BLOCK_ID
  -- TODO: skip for now
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
paramattrGroupBlockId -> Just [Entry]
_) = do
  -- PARAMATTR_GROUP_BLOCK_ID
  -- TODO: skip for now
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
metadataBlockId -> Just [Entry]
es) = String -> Parse PartialModule -> Parse PartialModule
forall a. String -> Parse a -> Parse a
label String
"METADATA_BLOCK_ID" (Parse PartialModule -> Parse PartialModule)
-> Parse PartialModule -> Parse PartialModule
forall a b. (a -> b) -> a -> b
$ do
  ValueTable
vt <- Parse ValueTable
getValueTable
  let globalsSoFar :: Int
globalsSoFar = Seq PartialUnnamedMd -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PartialModule -> Seq PartialUnnamedMd
partialUnnamedMd PartialModule
pm)
  (Seq NamedMd
ns,(Seq PartialUnnamedMd
gs,Seq PartialUnnamedMd
_),InstrMdAttachments
_,PFnMdAttachments
_,PGlobalAttachments
atts) <- Int
-> ValueTable
-> [Entry]
-> Parse
     (Seq NamedMd, (Seq PartialUnnamedMd, Seq PartialUnnamedMd),
      InstrMdAttachments, PFnMdAttachments, PGlobalAttachments)
parseMetadataBlock Int
globalsSoFar ValueTable
vt [Entry]
es
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (PartialModule -> Parse PartialModule)
-> PartialModule -> Parse PartialModule
forall a b. (a -> b) -> a -> b
$ PGlobalAttachments -> PartialModule -> PartialModule
addGlobalAttachments PGlobalAttachments
atts PartialModule
pm
    { partialNamedMd   = partialNamedMd   pm <> ns
    , partialUnnamedMd = partialUnnamedMd pm <> gs
    }

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
valueSymtabBlockId -> Just [Entry]
_es) = do
  -- VALUE_SYMTAB_BLOCK_ID
  -- NOTE: we parse the value symbol table eagerly at the beginning of the
  -- MODULE_BLOCK
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeTriple -> Just Record
r) = do
  -- MODULE_CODE_TRIPLE
  String
triple <- [Word8] -> String
UTF8.decode ([Word8] -> String) -> Parse [Word8] -> Parse String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Record -> Int -> Match Field Word8 -> Parse [Word8]
forall a. Record -> Int -> Match Field a -> Parse [a]
parseFields Record
r Int
0 Match Field Word8
char
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (PartialModule
pm { partialTriple = parseTriple triple })

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeDatalayout -> Just Record
r) = do
  -- MODULE_CODE_DATALAYOUT
  String
layout <- [Word8] -> String
UTF8.decode ([Word8] -> String) -> Parse [Word8] -> Parse String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Record -> Int -> Match Field Word8 -> Parse [Word8]
forall a. Record -> Int -> Match Field a -> Parse [a]
parseFields Record
r Int
0 Match Field Word8
char
  case String -> Maybe DataLayout
forall (m :: * -> *). MonadPlus m => String -> m DataLayout
parseDataLayout String
layout of
    Maybe DataLayout
Nothing -> String -> Parse PartialModule
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unable to parse data layout: ``" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
layout String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"''")
    Just DataLayout
dl -> PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (PartialModule
pm { partialDataLayout = dl })

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeAsm -> Just Record
r) = do
  -- MODULE_CODE_ASM
  String
asm <- [Word8] -> String
UTF8.decode ([Word8] -> String) -> Parse [Word8] -> Parse String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Record -> Int -> Match Field Word8 -> Parse [Word8]
forall a. Record -> Int -> Match Field a -> Parse [a]
parseFields Record
r Int
0 Match Field Word8
char
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm { partialInlineAsm = lines asm }

parseModuleBlockEntry PartialModule
pm (Match Entry DefineAbbrev
abbrevDef -> Just DefineAbbrev
_) = do
  -- skip abbreviation definitions
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeGlobalvar -> Just Record
r) = do
  -- MODULE_CODE_GLOBALVAR
  PartialGlobal
pg <- Int -> Record -> Parse PartialGlobal
parseGlobalVar (PartialModule -> Int
partialGlobalIx PartialModule
pm) Record
r
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm
    { partialGlobalIx = succ (partialGlobalIx pm)
    , partialGlobals  = partialGlobals pm Seq.|> pg
    }

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeAlias -> Just Record
r) = String -> Parse PartialModule -> Parse PartialModule
forall a. String -> Parse a -> Parse a
label String
"MODULE_CODE_ALIAS_OLD" (Parse PartialModule -> Parse PartialModule)
-> Parse PartialModule -> Parse PartialModule
forall a b. (a -> b) -> a -> b
$ do
  PartialAlias
pa <- Int -> Record -> Parse PartialAlias
parseAliasOld (PartialModule -> Int
partialAliasIx PartialModule
pm) Record
r
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm
    { partialAliasIx = succ (partialAliasIx pm)
    , partialAliases = partialAliases pm Seq.|> pa
    }

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeVersion -> Just Record
r) = do
  -- MODULE_CODE_VERSION

  -- please see:
  -- http://llvm.org/docs/BitCodeFormat.html#module-code-version-record
  Int
version <- Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  Int -> Parse ()
setModVersion Int
version
  case Int
version :: Int of
    Int
0 -> Bool -> Parse ()
setRelIds Bool
False  -- Absolute value ids in LLVM <= 3.2
    Int
1 -> Bool -> Parse ()
setRelIds Bool
True   -- Relative value ids in LLVM >= 3.3
    Int
2 -> Bool -> Parse ()
setRelIds Bool
True   -- Relative value ids in LLVM >= 5.0
    Int
_ -> String -> Parse ()
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unsupported version id: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
version)

  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeSectionname -> Just Record
r) = do
  String
name <- [Word8] -> String
UTF8.decode ([Word8] -> String) -> Parse [Word8] -> Parse String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Record -> Int -> Match Field Word8 -> Parse [Word8]
forall a. Record -> Int -> Match Field a -> Parse [a]
parseFields Record
r Int
0 Match Field Word8
char
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm { partialSections = partialSections pm Seq.|> name }

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeComdat -> Just Record
r) = do
  -- MODULE_CODE_COMDAT
  Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2) (String -> Parse ()
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid record (MODULE_CODE_COMDAT)")
  -- This was last updated in 0fc96d5, but the implementation appeared a bit
  -- buggy for clang++ 3.8. Since no known downstream consumer uses it, it was
  -- removed.
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeVSTOffset -> Just Record
_) = do
  -- MODULE_CODE_VSTOFFSET
  -- TODO: should we handle this?
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeAliasNew -> Just Record
r) = String -> Parse PartialModule -> Parse PartialModule
forall a. String -> Parse a -> Parse a
label String
"MODULE_CODE_ALIAS" (Parse PartialModule -> Parse PartialModule)
-> Parse PartialModule -> Parse PartialModule
forall a b. (a -> b) -> a -> b
$ do
  PartialAlias
pa <- Record -> Parse PartialAlias
parseAlias Record
r
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm
    { partialAliasIx = succ (partialAliasIx pm)
    , partialAliases = partialAliases pm Seq.|> pa
    }

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeMDValsUnused -> Just Record
_) = do
  -- MODULE_CODE_METADATA_VALUES_UNUSED
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeSourceFilename -> Just Record
r) = do
  -- MODULE_CODE_SOURCE_FILENAME
  do String
str <- Record -> LookupField String
forall a. Record -> LookupField a
parseField Record
r Int
0 Match Field String
cstring
     PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm { partialSourceName = Just str }

parseModuleBlockEntry PartialModule
pm (Match Entry Record
moduleCodeHash -> Just Record
_) = do
  -- MODULE_CODE_HASH
  -- It should be safe to ignore this for now.
  --fail "MODULE_CODE_HASH"
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
_ (Match Entry Record
moduleCodeIFunc -> Just Record
_) = do
  -- MODULE_CODE_IFUNC
  String -> Parse PartialModule
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"MODULE_CODE_IFUNC"

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
uselistBlockId -> Just [Entry]
_) = do
  -- USELIST_BLOCK_ID
  -- XXX ?? fail "USELIST_BLOCK_ID"
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
_ (Match Entry [Entry]
moduleStrtabBlockId -> Just [Entry]
_) = do
  -- MODULE_STRTAB_BLOCK_ID
  String -> Parse PartialModule
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"MODULE_STRTAB_BLOCK_ID"

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
globalvalSummaryBlockId -> Just [Entry]
_) = do
  -- GLOBALVAL_SUMMARY_BLOCK_ID
  -- It should be safe to ignore this for now.
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
operandBundleTagsBlockId -> Just [Entry]
_) = do
  -- OPERAND_BUNDLE_TAGS_BLOCK_ID
  -- fail "OPERAND_BUNDLE_TAGS_BLOCK_ID"
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
metadataKindBlockId -> Just [Entry]
es) = String -> Parse PartialModule -> Parse PartialModule
forall a. String -> Parse a -> Parse a
label String
"METADATA_KIND_BLOCK_ID" (Parse PartialModule -> Parse PartialModule)
-> Parse PartialModule -> Parse PartialModule
forall a b. (a -> b) -> a -> b
$ do
  [Entry] -> (Entry -> Parse ()) -> Parse ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Entry]
es ((Entry -> Parse ()) -> Parse ())
-> (Entry -> Parse ()) -> Parse ()
forall a b. (a -> b) -> a -> b
$ \Entry
e ->
    case Match Entry Record
fromEntry Entry
e of
      Just Record
r -> Record -> Parse ()
parseMetadataKindEntry Record
r
      Maybe Record
Nothing -> String -> Parse ()
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't parse metadata kind block entry."
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
strtabBlockId -> Just [Entry]
_) =
  -- Handled already.
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
ltoSummaryBlockId -> Just [Entry]
_) =
  -- It should be safe to ignore this for now.
  --label "FULL_LTO_GLOBALVAL_SUMMARY_BLOCK_ID" $ do
  --  fail "FULL_LTO_GLOBALVAL_SUMMARY_BLOCK_ID unsupported"
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
symtabBlockId -> Just [Match Entry Record
symtabBlobId -> Just Record
_]) =
  -- Handled already
  PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
pm (Match Entry [Entry]
syncScopeNamesBlockId -> Just [Entry]
_) =
  String -> Parse PartialModule -> Parse PartialModule
forall a. String -> Parse a -> Parse a
label String
"SYNC_SCOPE_NAMES_BLOCK_ID" (Parse PartialModule -> Parse PartialModule)
-> Parse PartialModule -> Parse PartialModule
forall a b. (a -> b) -> a -> b
$ do
    -- TODO: record this information somewhere
    PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm

parseModuleBlockEntry PartialModule
_ Entry
e =
  String -> Parse PartialModule
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unexpected module block entry: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Entry -> String
forall a. Show a => a -> String
show Entry
e)

parseFunProto :: Record -> PartialModule -> Parse PartialModule
parseFunProto :: Record -> PartialModule -> Parse PartialModule
parseFunProto Record
r PartialModule
pm = String -> Parse PartialModule -> Parse PartialModule
forall a. String -> Parse a -> Parse a
label String
"FUNCTION" (Parse PartialModule -> Parse PartialModule)
-> Parse PartialModule -> Parse PartialModule
forall a b. (a -> b) -> a -> b
$ do
  Int
ix   <- Parse Int
nextValueId
  (Symbol
name, Int
offset) <- Int -> Record -> Parse (Symbol, Int)
oldOrStrtabName Int
ix Record
r
  let field :: Int -> Match Field a -> Parse a
field Int
i = Record -> Int -> Match Field a -> Parse a
forall a. Record -> LookupField a
parseField Record
r (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset)
  Type
funTy   <- Int -> Parse Type
getType (Int -> Parse Type) -> Parse Int -> Parse Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. Int -> Match Field a -> Parse a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
  let ty :: Type
ty = case Type
funTy of
             PtrTo Type
_  -> Type
funTy
             Type
_        -> Type -> Type
forall ident. Type' ident -> Type' ident
PtrTo Type
funTy

  Int
isProto <-             LookupField Int
forall {a}. Int -> Match Field a -> Parse a
field Int
2 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric

  Linkage
link    <-             Int -> Match Field Linkage -> Parse Linkage
forall {a}. Int -> Match Field a -> Parse a
field Int
3 Match Field Linkage
linkage

  Visibility
vis     <-             Int -> Match Field Visibility -> Parse Visibility
forall {a}. Int -> Match Field a -> Parse a
field Int
7 Match Field Visibility
visibility

  Maybe String
section <-
    if [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6
       then do Int
sid <- LookupField Int
forall {a}. Int -> Match Field a -> Parse a
field Int
6 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
               if Int
sid Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                  then Maybe String -> Parse (Maybe String)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                  else do let sid' :: Int
sid' = Int
sid Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                          Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
sid' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Seq String -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PartialModule -> Seq String
partialSections PartialModule
pm))
                              (String -> Parse ()
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid section name index")
                          Maybe String -> Parse (Maybe String)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just (Seq String -> Int -> String
forall a. Seq a -> Int -> a
Seq.index (PartialModule -> Seq String
partialSections PartialModule
pm) Int
sid'))

       else Maybe String -> Parse (Maybe String)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing

  -- push the function type
  Int
_    <- Typed PValue -> Parse Int
pushValue (Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Symbol -> PValue
forall lab. Symbol -> Value' lab
ValSymbol Symbol
name))
  let lkMb :: Seq a -> Int -> Maybe a
lkMb Seq a
t Int
x
       | Seq a -> Int
forall a. Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq a
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
x = a -> Maybe a
forall a. a -> Maybe a
Just (Seq a -> Int -> a
forall a. Seq a -> Int -> a
Seq.index Seq a
t Int
x)
       | Bool
otherwise        = Maybe a
forall a. Maybe a
Nothing
  Maybe String
comdat <- if [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
12
               then do Int
comdatID <- LookupField Int
forall {a}. Int -> Match Field a -> Parse a
field Int
12 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
                       Maybe String -> Parse (Maybe String)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, SelectionKind) -> String
forall a b. (a, b) -> a
fst ((String, SelectionKind) -> String)
-> Maybe (String, SelectionKind) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PartialModule -> Seq (String, SelectionKind)
partialComdat PartialModule
pm Seq (String, SelectionKind) -> Int -> Maybe (String, SelectionKind)
forall {a}. Seq a -> Int -> Maybe a
`lkMb` Int
comdatID)
               else Maybe String -> Parse (Maybe String)
forall a. a -> Parse a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
  let proto :: FunProto
proto = FunProto
        { protoType :: Type
protoType  = Type
ty
        , protoLinkage :: Maybe Linkage
protoLinkage =
          do -- we emit a Nothing here to maintain output compatibility with
             -- llvm-dis when linkage is External
             Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Linkage
link Linkage -> Linkage -> Bool
forall a. Eq a => a -> a -> Bool
/= Linkage
External)
             Linkage -> Maybe Linkage
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Linkage
link
        , protoVisibility :: Maybe Visibility
protoVisibility = Visibility -> Maybe Visibility
forall a. a -> Maybe a
Just Visibility
vis
        , protoGC :: Maybe GC
protoGC    = Maybe GC
forall a. Maybe a
Nothing
        , protoSym :: Symbol
protoSym   = Symbol
name
        , protoIndex :: Int
protoIndex = Int
ix
        , protoSect :: Maybe String
protoSect  = Maybe String
section
        , protoComdat :: Maybe String
protoComdat = Maybe String
comdat
        }

  if Int
isProto Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
0 :: Int)
     then FunProto -> Parse ()
pushFunProto FunProto
proto Parse () -> Parse PartialModule -> Parse PartialModule
forall a b. Parse a -> Parse b -> Parse b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm
     else PartialModule -> Parse PartialModule
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PartialModule
pm { partialDeclares = partialDeclares pm Seq.|> proto }


addGlobalAttachments :: PGlobalAttachments -> (PartialModule -> PartialModule)
addGlobalAttachments :: PGlobalAttachments -> PartialModule -> PartialModule
addGlobalAttachments PGlobalAttachments
gs0 PartialModule
pm = PartialModule
pm { partialGlobals = go (partialGlobals pm) gs0 }
  where

  go :: GlobalList -> PGlobalAttachments -> GlobalList
go GlobalList
gs PGlobalAttachments
atts | PGlobalAttachments -> Bool
forall k a. Map k a -> Bool
Map.null PGlobalAttachments
atts = GlobalList
gs

  go GlobalList
gs PGlobalAttachments
atts =
    case GlobalList -> ViewL PartialGlobal
forall a. Seq a -> ViewL a
Seq.viewl GlobalList
gs of
      ViewL PartialGlobal
Seq.EmptyL -> GlobalList
forall a. Seq a
Seq.empty

      PartialGlobal
g Seq.:< GlobalList
gs' ->
        let (Maybe (Map String PValMd)
mb,PGlobalAttachments
atts') = (Symbol -> Map String PValMd -> Maybe (Map String PValMd))
-> Symbol
-> PGlobalAttachments
-> (Maybe (Map String PValMd), PGlobalAttachments)
forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
Map.updateLookupWithKey (\Symbol
_ Map String PValMd
_ -> Maybe (Map String PValMd)
forall a. Maybe a
Nothing) (PartialGlobal -> Symbol
pgSym PartialGlobal
g) PGlobalAttachments
atts
         in case Maybe (Map String PValMd)
mb of
              Just Map String PValMd
md -> PartialGlobal
g { pgMd = md } PartialGlobal -> GlobalList -> GlobalList
forall a. a -> Seq a -> Seq a
Seq.<| GlobalList -> PGlobalAttachments -> GlobalList
go GlobalList
gs' PGlobalAttachments
atts'
              Maybe (Map String PValMd)
Nothing -> PartialGlobal
g               PartialGlobal -> GlobalList -> GlobalList
forall a. a -> Seq a -> Seq a
Seq.<| GlobalList -> PGlobalAttachments -> GlobalList
go GlobalList
gs' PGlobalAttachments
atts'