llvm-pretty-bc-parser-0.5.0.0: src/Data/LLVM/BitCode/IR/Module.hs
{-# 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
{ partialGlobalIx :: !Int
, partialGlobals :: GlobalList
, partialDefines :: DefineList
, partialDeclares :: DeclareList
, partialTriple :: TargetTriple
, partialDataLayout :: DataLayout
, partialInlineAsm :: InlineAsm
, partialComdat :: !(Seq (String,SelectionKind))
, partialAliasIx :: !Int
, partialAliases :: AliasList
, partialNamedMd :: !(Seq NamedMd)
, partialUnnamedMd :: !(Seq PartialUnnamedMd)
, partialSections :: !(Seq String)
, partialSourceName :: !(Maybe String)
}
emptyPartialModule :: PartialModule
emptyPartialModule = PartialModule
{ partialGlobalIx = 0
, partialGlobals = mempty
, partialDefines = mempty
, partialDeclares = mempty
, partialTriple = mempty
, partialDataLayout = mempty
, partialInlineAsm = mempty
, partialAliasIx = 0
, partialAliases = mempty
, partialNamedMd = mempty
, partialUnnamedMd = mempty
, partialSections = mempty
, partialSourceName = mempty
, partialComdat = mempty
}
-- | Fixup the global variables and declarations, and return the completed
-- module.
finalizeModule :: PartialModule -> Parse Module
finalizeModule pm = label "finalizeModule" $ do
types <- resolveTypeDecls
let defs = Map.fromList [ (partialName d, partialSymtab d)
| d <- F.toList (partialDefines pm) ]
defines <- T.mapM (finalizePartialDefine defs) (partialDefines pm)
liftFinalize defs $ do
globals <- T.mapM finalizeGlobal (partialGlobals pm)
declares <- T.mapM finalizeDeclare (partialDeclares pm)
aliases <- T.mapM finalizePartialAlias (partialAliases pm)
unnamed <- T.mapM finalizePartialUnnamedMd (dedupMetadata (partialUnnamedMd pm))
return 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 ents = label "MODULE_BLOCK" $ 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.
tsymtab <- label "type symbol table" $ do
mb <- match (findMatch typeBlockIdNew) ents
case mb of
Just es -> parseTypeBlock es
Nothing -> return mempty
withTypeSymtab tsymtab $ label "value symbol table" $ do
-- parse the value symbol table out first, if there is one
symtab <- do
mb <- match (findMatch valueSymtabBlockId) ents
case mb of
Just es -> parseValueSymbolTableBlock es
Nothing -> return emptyValueSymtab
pm <- withValueSymtab symtab
$ foldM parseModuleBlockEntry emptyPartialModule ents
finalizeModule pm
-- | Parse the entries in a module block.
parseModuleBlockEntry :: PartialModule -> Entry -> Parse PartialModule
parseModuleBlockEntry pm (blockInfoBlockId -> Just _) =
-- skip the block info block, as we only use it during Bitstream parsing.
return pm
parseModuleBlockEntry pm (typeBlockIdNew -> Just _) = do
-- TYPE_BLOCK_ID_NEW
-- this is skipped, as it's parsed before anything else, in parseModuleBlock
return pm
parseModuleBlockEntry pm (constantsBlockId -> Just es) = do
-- CONSTANTS_BLOCK_ID
parseConstantsBlock es
return pm
parseModuleBlockEntry pm (moduleCodeFunction -> Just r) = do
-- MODULE_CODE_FUNCTION
parseFunProto r pm
parseModuleBlockEntry pm (functionBlockId -> Just es) = label "FUNCTION_BLOCK_ID" $ do
let unnamedGlobalsCount = length (partialUnnamedMd pm)
def <- parseFunctionBlock unnamedGlobalsCount es
let def' = def { partialGlobalMd = mempty }
return pm { partialDefines = partialDefines pm Seq.|> def'
, partialUnnamedMd = partialGlobalMd def <> partialUnnamedMd pm
}
parseModuleBlockEntry pm (paramattrBlockId -> Just _) = do
-- PARAMATTR_BLOCK_ID
-- TODO: skip for now
return pm
parseModuleBlockEntry pm (paramattrGroupBlockId -> Just _) = do
-- PARAMATTR_GROUP_BLOCK_ID
-- TODO: skip for now
return pm
parseModuleBlockEntry pm (metadataBlockId -> Just es) = label "METADATA_BLOCK_ID" $ do
vt <- getValueTable
let globalsSoFar = length (partialUnnamedMd pm)
(ns,(gs,_),_,_,atts) <- parseMetadataBlock globalsSoFar vt es
return $ addGlobalAttachments atts pm
{ partialNamedMd = partialNamedMd pm <> ns
, partialUnnamedMd = partialUnnamedMd pm <> gs
}
parseModuleBlockEntry pm (valueSymtabBlockId -> Just _es) = do
-- VALUE_SYMTAB_BLOCK_ID
-- NOTE: we parse the value symbol table eagerly at the beginning of the
-- MODULE_BLOCK
return pm
parseModuleBlockEntry pm (moduleCodeTriple -> Just r) = do
-- MODULE_CODE_TRIPLE
triple <- UTF8.decode <$> parseFields r 0 char
return (pm { partialTriple = parseTriple triple })
parseModuleBlockEntry pm (moduleCodeDatalayout -> Just r) = do
-- MODULE_CODE_DATALAYOUT
layout <- UTF8.decode <$> parseFields r 0 char
case parseDataLayout layout of
Nothing -> fail ("unable to parse data layout: ``" ++ layout ++ "''")
Just dl -> return (pm { partialDataLayout = dl })
parseModuleBlockEntry pm (moduleCodeAsm -> Just r) = do
-- MODULE_CODE_ASM
asm <- UTF8.decode <$> parseFields r 0 char
return pm { partialInlineAsm = lines asm }
parseModuleBlockEntry pm (abbrevDef -> Just _) = do
-- skip abbreviation definitions
return pm
parseModuleBlockEntry pm (moduleCodeGlobalvar -> Just r) = do
-- MODULE_CODE_GLOBALVAR
pg <- parseGlobalVar (partialGlobalIx pm) r
return pm
{ partialGlobalIx = succ (partialGlobalIx pm)
, partialGlobals = partialGlobals pm Seq.|> pg
}
parseModuleBlockEntry pm (moduleCodeAlias -> Just r) = label "MODULE_CODE_ALIAS_OLD" $ do
pa <- parseAliasOld (partialAliasIx pm) r
return pm
{ partialAliasIx = succ (partialAliasIx pm)
, partialAliases = partialAliases pm Seq.|> pa
}
parseModuleBlockEntry pm (moduleCodeVersion -> Just r) = do
-- MODULE_CODE_VERSION
-- please see:
-- http://llvm.org/docs/BitCodeFormat.html#module-code-version-record
version <- parseField r 0 numeric
setModVersion version
case version :: Int of
0 -> setRelIds False -- Absolute value ids in LLVM <= 3.2
1 -> setRelIds True -- Relative value ids in LLVM >= 3.3
2 -> setRelIds True -- Relative value ids in LLVM >= 5.0
_ -> fail ("unsupported version id: " ++ show version)
return pm
parseModuleBlockEntry pm (moduleCodeSectionname -> Just r) = do
name <- UTF8.decode <$> parseFields r 0 char
return pm { partialSections = partialSections pm Seq.|> name }
parseModuleBlockEntry pm (moduleCodeComdat -> Just r) = do
-- MODULE_CODE_COMDAT
when (length (recordFields r) < 2) (fail "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.
return pm
parseModuleBlockEntry pm (moduleCodeVSTOffset -> Just _) = do
-- MODULE_CODE_VSTOFFSET
-- TODO: should we handle this?
return pm
parseModuleBlockEntry pm (moduleCodeAliasNew -> Just r) = label "MODULE_CODE_ALIAS" $ do
pa <- parseAlias r
return pm
{ partialAliasIx = succ (partialAliasIx pm)
, partialAliases = partialAliases pm Seq.|> pa
}
parseModuleBlockEntry pm (moduleCodeMDValsUnused -> Just _) = do
-- MODULE_CODE_METADATA_VALUES_UNUSED
return pm
parseModuleBlockEntry pm (moduleCodeSourceFilename -> Just r) = do
-- MODULE_CODE_SOURCE_FILENAME
do str <- parseField r 0 cstring
return pm { partialSourceName = Just str }
parseModuleBlockEntry pm (moduleCodeHash -> Just _) = do
-- MODULE_CODE_HASH
-- It should be safe to ignore this for now.
--fail "MODULE_CODE_HASH"
return pm
parseModuleBlockEntry _ (moduleCodeIFunc -> Just _) = do
-- MODULE_CODE_IFUNC
fail "MODULE_CODE_IFUNC"
parseModuleBlockEntry pm (uselistBlockId -> Just _) = do
-- USELIST_BLOCK_ID
-- XXX ?? fail "USELIST_BLOCK_ID"
return pm
parseModuleBlockEntry _ (moduleStrtabBlockId -> Just _) = do
-- MODULE_STRTAB_BLOCK_ID
fail "MODULE_STRTAB_BLOCK_ID"
parseModuleBlockEntry pm (globalvalSummaryBlockId -> Just _) = do
-- GLOBALVAL_SUMMARY_BLOCK_ID
-- It should be safe to ignore this for now.
return pm
parseModuleBlockEntry pm (operandBundleTagsBlockId -> Just _) = do
-- OPERAND_BUNDLE_TAGS_BLOCK_ID
-- fail "OPERAND_BUNDLE_TAGS_BLOCK_ID"
return pm
parseModuleBlockEntry pm (metadataKindBlockId -> Just es) = label "METADATA_KIND_BLOCK_ID" $ do
forM_ es $ \e ->
case fromEntry e of
Just r -> parseMetadataKindEntry r
Nothing -> fail "Can't parse metadata kind block entry."
return pm
parseModuleBlockEntry pm (strtabBlockId -> Just _) =
-- Handled already.
return pm
parseModuleBlockEntry pm (ltoSummaryBlockId -> Just _) =
-- 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"
return pm
parseModuleBlockEntry pm (symtabBlockId -> Just [symtabBlobId -> Just _]) =
-- Handled already
return pm
parseModuleBlockEntry pm (syncScopeNamesBlockId -> Just _) =
label "SYNC_SCOPE_NAMES_BLOCK_ID" $ do
-- TODO: record this information somewhere
return pm
parseModuleBlockEntry _ e =
fail ("unexpected module block entry: " ++ show e)
parseFunProto :: Record -> PartialModule -> Parse PartialModule
parseFunProto r pm = label "FUNCTION" $ do
ix <- nextValueId
(name, offset) <- oldOrStrtabName ix r
let field i = parseField r (i + offset)
funTy <- getType =<< field 0 numeric
let ty = case funTy of
PtrTo _ -> funTy
_ -> PtrTo funTy
isProto <- field 2 numeric
link <- field 3 linkage
vis <- field 7 visibility
section <-
if length (recordFields r) >= 6
then do sid <- field 6 numeric
if sid == 0
then return Nothing
else do let sid' = sid - 1
when (sid' >= length (partialSections pm))
(fail "invalid section name index")
return (Just (Seq.index (partialSections pm) sid'))
else return Nothing
-- push the function type
_ <- pushValue (Typed ty (ValSymbol name))
let lkMb t x
| length t > x = Just (Seq.index t x)
| otherwise = Nothing
comdat <- if length (recordFields r) >= 12
then do comdatID <- field 12 numeric
pure (fst <$> partialComdat pm `lkMb` comdatID)
else pure Nothing
let proto = FunProto
{ protoType = ty
, protoLinkage =
do -- we emit a Nothing here to maintain output compatibility with
-- llvm-dis when linkage is External
guard (link /= External)
return link
, protoVisibility = Just vis
, protoGC = Nothing
, protoSym = name
, protoIndex = ix
, protoSect = section
, protoComdat = comdat
}
if isProto == (0 :: Int)
then pushFunProto proto >> return pm
else return pm { partialDeclares = partialDeclares pm Seq.|> proto }
addGlobalAttachments :: PGlobalAttachments -> (PartialModule -> PartialModule)
addGlobalAttachments gs0 pm = pm { partialGlobals = go (partialGlobals pm) gs0 }
where
go gs atts | Map.null atts = gs
go gs atts =
case Seq.viewl gs of
Seq.EmptyL -> Seq.empty
g Seq.:< gs' ->
let (mb,atts') = Map.updateLookupWithKey (\_ _ -> Nothing) (pgSym g) atts
in case mb of
Just md -> g { pgMd = md } Seq.<| go gs' atts'
Nothing -> g Seq.<| go gs' atts'