{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE RecordWildCards #-}
module Data.LLVM.BitCode.Parse where
import Text.LLVM.AST
import Text.LLVM.PP
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..), unless)
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail -- makes fail visible for instance
#endif
import Control.Monad.Fix (MonadFix)
import Control.Monad.Except (MonadError(..), Except, runExcept)
import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)
import Control.Monad.State.Strict (MonadState(..), StateT(..)
, gets, modify)
import qualified Data.Foldable as F
import Data.Maybe (fromMaybe)
import Data.Semigroup
import Data.Typeable (Typeable)
import Data.Word ( Word32 )
import qualified Codec.Binary.UTF8.String as UTF8 (decode)
import qualified Control.Exception as X
import qualified Data.ByteString as BS
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Sequence as Seq
import GHC.Stack (HasCallStack, CallStack, callStack, prettyCallStack)
import qualified Text.PrettyPrint.HughesPJ as PP
import qualified Text.PrettyPrint.HughesPJClass as PP
import Prelude
-- Error Collection Parser -----------------------------------------------------
data Error = Error
{ errContext :: [String]
, errMessage :: String
} deriving (Show, Eq, Ord)
formatError :: Error -> String
formatError err
| null (errContext err) = errMessage err
| otherwise = unlines
$ errMessage err
: formatContext (errContext err)
formatContext :: [String] -> [String]
formatContext cxt = "from:" : map ('\t' :) cxt
newtype Parse a = Parse
{ unParse :: ReaderT Env (StateT ParseState (Except Error)) a
} deriving ( Functor, Applicative, MonadFix
, MonadReader Env
, MonadState ParseState
, MonadError Error
)
instance Monad Parse where
#if !MIN_VERSION_base(4,11,0)
{-# INLINE return #-}
return = pure
#endif
{-# INLINE (>>=) #-}
Parse m >>= f = Parse (m >>= unParse . f)
#if !MIN_VERSION_base(4,13,0)
{-# INLINE fail #-}
fail = failWithContext
#endif
instance MonadFail Parse where
{-# INLINE fail #-}
fail = failWithContext
instance Alternative Parse where
{-# INLINE empty #-}
empty = failWithContext "empty"
{-# INLINE (<|>) #-}
a <|> b = Parse $ catchError (unParse a) (const (unParse b))
instance MonadPlus Parse where
{-# INLINE mzero #-}
mzero = failWithContext "mzero"
{-# INLINE mplus #-}
mplus = (<|>)
runParse :: Parse a -> Either Error (a, ParseState)
runParse (Parse m) =
case runExcept (runStateT (runReaderT m emptyEnv) emptyParseState) of
Left err -> Left err
Right res -> Right res
notImplemented :: Parse a
notImplemented = fail "not implemented"
-- Parse State -----------------------------------------------------------------
data ParseState = ParseState
{ psTypeTable :: TypeTable
, psTypeTableSize :: !Int
, psValueTable :: ValueTable
, psStringTable :: Maybe StringTable
, psMdTable :: ValueTable
, psMdRefs :: MdRefTable
, psFunProtos :: Seq.Seq FunProto
, psNextResultId :: !Int
, psTypeName :: Maybe String
, psNextTypeId :: !Int
, psLastLoc :: Maybe PDebugLoc
, psKinds :: !KindTable
, psModVersion :: !Int
, psWarnings :: Seq.Seq ParseWarning
} deriving (Show)
-- | The initial parsing state.
emptyParseState :: ParseState
emptyParseState = ParseState
{ psTypeTable = IntMap.empty
, psTypeTableSize = 0
, psValueTable = emptyValueTable False
, psStringTable = Nothing
, psMdTable = emptyValueTable False
, psMdRefs = IntMap.empty
, psFunProtos = Seq.empty
, psNextResultId = 0
, psTypeName = Nothing
, psNextTypeId = 0
, psLastLoc = Nothing
, psKinds = emptyKindTable
, psModVersion = 0
, psWarnings = Seq.empty
}
-- | The next implicit result id.
nextResultId :: Parse Int
nextResultId = Parse $ do
ps <- get
put ps { psNextResultId = psNextResultId ps + 1 }
return (psNextResultId ps)
type PDebugLoc = DebugLoc' Int
setLastLoc :: PDebugLoc -> Parse ()
setLastLoc loc = Parse $ do
ps <- get
put $! ps { psLastLoc = Just loc }
setRelIds :: Bool -> Parse ()
setRelIds b = Parse $ do
ps <- get
put $! ps { psValueTable = (psValueTable ps) { valueRelIds = b }}
getRelIds :: HasValueTable m => m Bool
getRelIds = valueRelIds <$> getValueTable
getLastLoc :: Parse PDebugLoc
getLastLoc = do
ps <- Parse get
case psLastLoc ps of
Just loc -> return loc
Nothing -> fail "No last location available"
setModVersion :: Int -> Parse ()
setModVersion v = Parse $ do
ps <- get
put $! ps { psModVersion = v }
getModVersion :: Parse Int
getModVersion = Parse (psModVersion <$> get)
-- | Sort of a hack to preserve state between function body parses. It would
-- really be nice to separate this into a different monad, that could just run
-- under the Parse monad, but sort of unnecessary in the long run.
enterFunctionDef :: Parse a -> Parse a
enterFunctionDef m = Parse $ do
ps <- get
put ps
{ psNextResultId = 0
}
res <- unParse m
ps' <- get
put ps'
{ psValueTable = psValueTable ps
, psMdTable = psMdTable ps
, psMdRefs = psMdRefs ps
, psLastLoc = Nothing
}
return res
-- Type Table ------------------------------------------------------------------
type TypeTable = IntMap.IntMap Type
-- | Generate a type table, and a type symbol table.
mkTypeTable :: [Type] -> TypeTable
mkTypeTable = IntMap.fromList . zip [0 ..]
-- | Exceptions contain a callstack, parsing context, explanation, and index
data BadForwardRef
= BadTypeRef CallStack [String] String Int
| BadValueRef CallStack [String] String Int
deriving (Show,Typeable)
instance X.Exception BadForwardRef
badRefError :: BadForwardRef -> Error
badRefError ref =
let (stk, cxt, explanation, i, thing) =
case ref of
BadTypeRef stk' cxt' explanation' i' -> (stk', cxt', explanation', i', "type")
BadValueRef stk' cxt' explanation' i' -> (stk', cxt', explanation', i', "value")
in Error cxt $ unlines ["bad forward reference to " ++ thing ++ ": " ++ show i
, "additional details: "
, explanation
, "with call stack: "
, prettyCallStack stk
]
-- | As type tables are always pre-allocated, looking things up should never
-- fail. As a result, the worst thing that could happen is that the type entry
-- causes a runtime error. This is pretty bad, but it's an acceptable trade-off
-- for the complexity of the forward references in the type table.
lookupTypeRef :: HasCallStack
=> [String] -> Int -> TypeTable -> Type
lookupTypeRef cxt n =
let explanation = "Bad reference into type table"
in fromMaybe (X.throw (BadTypeRef callStack cxt explanation n)) . IntMap.lookup n
setTypeTable :: TypeTable -> Parse ()
setTypeTable table = Parse $ do
ps <- get
put ps { psTypeTable = table }
getTypeTable :: Parse TypeTable
getTypeTable = Parse (psTypeTable <$> get)
setTypeTableSize :: Int -> Parse ()
setTypeTableSize n = Parse $ do
ps <- get
put ps { psTypeTableSize = n }
-- | Retrieve the current type name, failing if it hasn't been set.
getTypeName :: Parse Ident
getTypeName = Parse $ do
ps <- get
str <- case psTypeName ps of
Just tn -> do
put ps { psTypeName = Nothing }
return tn
Nothing -> do
put ps { psNextTypeId = psNextTypeId ps + 1 }
return (show (psNextTypeId ps))
return (Ident str)
setTypeName :: String -> Parse ()
setTypeName name = Parse $ do
ps <- get
put ps { psTypeName = Just name }
-- | Lookup the value of a type; don't attempt to resolve to an alias.
getType' :: Int -> Parse Type
getType' ref = do
ps <- Parse get
unless (ref < psTypeTableSize ps)
(fail ("type reference " ++ show ref ++ " is too large"))
cxt <- getContext
return (lookupTypeRef cxt ref (psTypeTable ps))
-- | Test to see if the type table has been added to already.
isTypeTableEmpty :: Parse Bool
isTypeTableEmpty = Parse (IntMap.null . psTypeTable <$> get)
setStringTable :: StringTable -> Parse ()
setStringTable st = Parse $ do
ps <- get
put ps { psStringTable = Just st }
getStringTable :: Parse (Maybe StringTable)
getStringTable = Parse (psStringTable <$> get)
-- Value Tables ----------------------------------------------------------------
-- | Values that have an identifier instead of a string label
type PValue = Value' Int
type PInstr = Instr' Int
data ValueTable = ValueTable
{ valueNextId :: !Int
, valueEntries :: IntMap.IntMap (Typed PValue)
, strtabEntries :: IntMap.IntMap (Int, Int)
, valueRelIds :: Bool
} deriving (Show)
emptyValueTable :: Bool -> ValueTable
emptyValueTable rel = ValueTable
{ valueNextId = 0
, valueEntries = IntMap.empty
, strtabEntries = IntMap.empty
, valueRelIds = rel
}
addValue :: Typed PValue -> ValueTable -> ValueTable
addValue tv vs = snd (addValue' tv vs)
addValue' :: Typed PValue -> ValueTable -> (Int,ValueTable)
addValue' tv vs = (valueNextId vs,vs')
where
vs' = vs
{ valueNextId = valueNextId vs + 1
, valueEntries = IntMap.insert (valueNextId vs) tv (valueEntries vs)
}
-- | Push a value into the value table, and return its index.
pushValue :: Typed PValue -> Parse Int
pushValue tv = Parse $ do
ps <- get
let vt = psValueTable ps
put ps { psValueTable = addValue tv vt }
return (valueNextId vt)
-- | Get the index for the next value.
nextValueId :: Parse Int
nextValueId = valueNextId <$> getValueTable
-- | Depending on whether or not relative ids are in use, adjust the id.
adjustId :: Int -> Parse Int
adjustId n = do
vt <- getValueTable
return (translateValueId vt n)
-- | Translate an id, relative to the value table it references.
-- NOTE: The relative conversion has to be done on a Word32 to handle overflow
-- when n is large the same way BitcodeReaderMDValueList::getValue does.
translateValueId :: ValueTable -> Int -> Int
translateValueId vt n | valueRelIds vt = fromIntegral adjusted
| otherwise = n
where
adjusted :: Word32
adjusted = fromIntegral (valueNextId vt - n)
-- | Lookup an absolute address in the value table.
lookupValueTableAbs :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs n values = IntMap.lookup n (valueEntries values)
-- | When you know you have an absolute index.
lookupValueAbs :: HasValueTable m => Int -> m (Maybe (Typed PValue))
lookupValueAbs n = lookupValueTableAbs n `fmap` getValueTable
-- | Lookup either a relative id, or an absolute id.
lookupValueTable :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTable n values =
lookupValueTableAbs (translateValueId values n) values
-- | Lookup a value in the value table.
lookupValue :: Int -> Parse (Maybe (Typed PValue))
lookupValue n = lookupValueTable n `fmap` getValueTable
-- | Lookup lazily, hiding an error in the result if the entry doesn't exist by
-- the time it's needed. NOTE: This always looks up an absolute index, never a
-- relative one.
forwardRef :: HasCallStack
=> [String] -> Int -> ValueTable -> Typed PValue
forwardRef cxt n vt =
let explanation = "Bad reference into a value table"
in fromMaybe (X.throw (BadValueRef callStack cxt explanation n)) (lookupValueTableAbs n vt)
-- | Require that a value be present.
requireValue :: Int -> Parse (Typed PValue)
requireValue n = do
mb <- lookupValue n
case mb of
Just tv -> return tv
Nothing -> fail ("value " ++ show n ++ " is not defined")
class Monad m => HasValueTable m where
-- | Get the current value table.
getValueTable :: m ValueTable
instance HasValueTable Parse where
getValueTable = gets psValueTable
-- | Retrieve the name for the next value. Note that this doesn't assume that
-- the name gets used, and doesn't update the next id in the value table.
getNextId :: Parse Int
getNextId = valueNextId <$> getValueTable
-- | Set the current value table.
setValueTable :: ValueTable -> Parse ()
setValueTable vt = Parse $ do
ps <- get
put ps { psValueTable = vt }
-- | Update the value table, giving a lazy reference to the final table.
fixValueTable :: (ValueTable -> Parse (a,[Typed PValue])) -> Parse a
fixValueTable k = do
vt <- getValueTable
rec let vt' = foldr addValue vt vs
(a,vs) <- k vt'
setValueTable vt'
return a
fixValueTable_ :: (ValueTable -> Parse [Typed PValue]) -> Parse ()
fixValueTable_ k = fixValueTable $ \ vt -> do
vs <- k vt
return ((),vs)
type PValMd = ValMd' Int
type MdTable = ValueTable
class Monad m => HasMdTable m where
getMdTable :: m MdTable
instance HasMdTable Parse where
getMdTable = gets psMdTable
setMdTable :: MdTable -> Parse ()
setMdTable md = modify $ \ps -> ps { psMdTable = md }
getMetadata :: Int -> Parse (Typed PValMd)
getMetadata ix = do
ps <- Parse get
case resolveMd ix ps of
Just tv -> case typedValue tv of
ValMd val -> return tv { typedValue = val }
_ -> fail "unexpected non-metadata value in metadata table"
Nothing -> fail ("metadata index " ++ show ix ++ " is not defined")
resolveMd :: Int -> ParseState -> Maybe (Typed PValue)
resolveMd ix ps = nodeRef `mplus` mdValue
where
reference = Typed (PrimType Metadata) . ValMd . ValMdRef
nodeRef = reference `fmap` IntMap.lookup ix (psMdRefs ps)
mdValue = lookupValueTableAbs ix (psMdTable ps)
type MdRefTable = IntMap.IntMap Int
setMdRefs :: MdRefTable -> Parse ()
setMdRefs refs = Parse $ do
ps <- get
put $! ps { psMdRefs = refs `IntMap.union` psMdRefs ps }
-- Function Prototypes ---------------------------------------------------------
data FunProto = FunProto
{ protoType :: Type
, protoLinkage :: Maybe Linkage
, protoVisibility :: Maybe Visibility
, protoGC :: Maybe GC
, protoSym :: Symbol
, protoIndex :: Int
, protoSect :: Maybe String
, protoComdat :: Maybe String
} deriving Show
-- | Push a function prototype on to the prototype stack.
pushFunProto :: FunProto -> Parse ()
pushFunProto p = Parse $ do
ps <- get
put ps { psFunProtos = psFunProtos ps Seq.|> p }
-- | Take a single function prototype off of the prototype stack.
popFunProto :: Parse FunProto
popFunProto = do
ps <- Parse get
case Seq.viewl (psFunProtos ps) of
Seq.EmptyL -> fail "empty function prototype stack"
p Seq.:< ps' -> do
Parse (put ps { psFunProtos = ps' })
return p
-- Parsing Environment ---------------------------------------------------------
-- | The Reader environment information maintained in the 'Parse' monad.
data Env = Env
{ envSymtab :: Symtab -- ^ the global symbol table
, envContext :: [String] -- ^ the stack of "label" strings (a "stacktrace")
} deriving Show
emptyEnv :: Env
emptyEnv = Env
{ envSymtab = mempty
, envContext = mempty
}
-- | Extend the symbol table for an environment, yielding a new environment.
extendSymtab :: Symtab -> Env -> Env
extendSymtab symtab env = env { envSymtab = envSymtab env `mappend` symtab }
-- | Add a label to the context of an environment, yielding a new environment.
addLabel :: String -> Env -> Env
addLabel l env = env { envContext = l : envContext env }
class Monad m => HasParseEnv m where
-- | Gets the "stacktrace" for what is currently being evaluated (as set by the
-- 'label' function, which calls 'addLabel' above). Note that the label
-- referenced here is the parsing processing notation, and NOT the llvm-pretty
-- AST 'lab' type argument which references the Basic Block label and which is
-- set with the 'llvm-pretty.relabel' function... an unfortunate overloading of
-- the term "label".
getContext :: m [String]
-- | Retrieve the value symbol table
getValueSymtab :: m ValueSymtab
instance HasParseEnv Parse where
getContext = asks envContext
getValueSymtab = asks $ symValueSymtab . envSymtab
data Symtab = Symtab
{ symValueSymtab :: ValueSymtab
, symTypeSymtab :: TypeSymtab
} deriving (Show)
instance Semigroup Symtab where
l <> r = Symtab
{ symValueSymtab = symValueSymtab l <> symValueSymtab r
, symTypeSymtab = symTypeSymtab l <> symTypeSymtab r
}
instance Monoid Symtab where
mempty = Symtab
{ symValueSymtab = emptyValueSymtab
, symTypeSymtab = mempty
}
mappend = (<>)
withSymtab :: Symtab -> Parse a -> Parse a
withSymtab symtab body = Parse $ do
local (extendSymtab symtab) (unParse body)
-- | Run a computation with an extended value symbol table.
withValueSymtab :: ValueSymtab -> Parse a -> Parse a
withValueSymtab symtab = withSymtab (mempty { symValueSymtab = symtab })
-- | Run a computation with an extended type symbol table.
withTypeSymtab :: TypeSymtab -> Parse a -> Parse a
withTypeSymtab symtab = withSymtab (mempty { symTypeSymtab = symtab })
-- | Retrieve the type symbol table.
getTypeSymtab :: Parse TypeSymtab
getTypeSymtab = Parse (symTypeSymtab . envSymtab <$> ask)
-- | Label a sub-computation with its context.
label :: String -> Parse a -> Parse a
label l m = Parse $ do
local (addLabel l) (unParse m)
-- | Fail, taking into account the current context.
failWithContext :: String -> Parse a
failWithContext msg = Parse $ do
env <- ask
throwError Error
{ errMessage = msg
, errContext = envContext env
}
-- | Attempt to find the type id in the type symbol table, when that fails,
-- look it up in the type table.
getType :: Int -> Parse Type
getType ref = do
symtab <- getTypeSymtab
case IntMap.lookup ref (tsById symtab) of
Just i -> return (Alias i)
Nothing -> getType' ref
-- | Find the id associated with a type alias.
getTypeId :: Ident -> Parse Int
getTypeId n = do
symtab <- getTypeSymtab
case Map.lookup n (tsByName symtab) of
Just ix -> return ix
Nothing -> fail ("unknown type alias " ++ show (ppLLVM llvmVlatest (llvmPP n)))
-- Value Symbol Table ----------------------------------------------------------
-- | An LLVM Bitcode file, it is comprised of nested Blocks of information,
-- with records available at each block. Different blocks hold different
-- types of information, and the nesting represents program scope and what is
-- defined/accessible at a particular point within the program.
--
-- The `Parse` and `Finalize` monads maintain a set of symbol tables to use
-- for lookups, as stored in the `Env` structure referenced by those monads:
--
-- * `valSymtab` for value references
--
-- * `fnSymtab` for function references
--
-- * `bbSymTab` for basic-block references, either "named" by association
-- with a symbol name (like the function's entry block) or "anonymous",
-- where there is no direct symbol but there may be a block label (like
-- for a goto statement or similar surface language construct.)
--
-- These lookups are necessary to "relabel" values that reference symbol or
-- label addresses in the code with the actual targets as resolved by
-- processing the entirety of the LLVM bitcode file. The
-- llvm-pretty-bc-parser runs in two phases: the initial phase where it
-- processes the LLVM bitcode stream to create "Partial" representations of
-- all of the elements, followed by a "finalization" phase where it performs
-- all of the label references above (via the llvm-pretty `relabel`
-- operation), as well as other fixups to convert the "Partial" data
-- structures into the structures defined by the `llvm-pretty` AST.
data ValueSymtab =
ValueSymtab
{ valSymtab :: IntMap.IntMap SymName
, bbSymtab :: IntMap.IntMap SymName
, fnSymtab :: IntMap.IntMap SymName
} deriving (Show)
type SymName = Either String Int
instance Semigroup ValueSymtab where
l <> r = ValueSymtab
{ valSymtab = valSymtab l `IntMap.union` valSymtab r
, bbSymtab = bbSymtab l `IntMap.union` bbSymtab r
, fnSymtab = fnSymtab l `IntMap.union` fnSymtab r
}
instance Monoid ValueSymtab where
mappend = (<>)
mempty = ValueSymtab
{ valSymtab = IntMap.empty
, bbSymtab = IntMap.empty
, fnSymtab = IntMap.empty
}
renderName :: SymName -> String
renderName = either id show
mkBlockLabel :: SymName -> BlockLabel
mkBlockLabel = either (Named . Ident) Anon
emptyValueSymtab :: ValueSymtab
emptyValueSymtab = mempty
addEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addEntry i n t = t { valSymtab = IntMap.insert i (Left n) (valSymtab t) }
addBBEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addBBEntry i n t = t { bbSymtab = IntMap.insert i (Left n) (bbSymtab t) }
addBBAnon :: Int -> Int -> ValueSymtab -> ValueSymtab
addBBAnon i n t = t { bbSymtab = IntMap.insert i (Right n) (bbSymtab t) }
addFNEntry :: Int -> Int -> String -> ValueSymtab -> ValueSymtab
-- TODO: do we ever need to be able to look up the offset?
addFNEntry i _o n t = t { fnSymtab = IntMap.insert i (Left n) (fnSymtab t) }
addFwdFNEntry :: Int -> Int -> ValueSymtab -> ValueSymtab
addFwdFNEntry i o t = t { fnSymtab = IntMap.insert i (Right o) (fnSymtab t) }
-- | Lookup the name of an entry. Returns @Nothing@ when it's not present.
entryNameMb :: HasParseEnv m => Int -> m (Maybe String)
entryNameMb n = do
symtab <- getValueSymtab
return $! fmap renderName
$ IntMap.lookup n (valSymtab symtab) `mplus`
IntMap.lookup n (fnSymtab symtab)
-- | Lookup the name of an entry.
entryName :: (HasParseEnv m, HasValueTable m, MonadFail m) => Int -> m String
entryName n = do
mentry <- entryNameMb n
case mentry of
Just name -> return name
Nothing ->
do isRel <- getRelIds
symtab <- getValueSymtab
fail $ unlines
[ "entry " ++ show n ++ (if isRel then " (relative)" else "")
++ " is missing from the symbol table"
, show symtab ]
-- | Lookup the name of a basic block.
bbEntryName :: Maybe Symbol -> Int -> Finalize (Maybe BlockLabel)
bbEntryName mbSym n =
fmap mkBlockLabel
<$> case mbSym of
Just fn -> do
-- Lookup entry in a function (Defines) symbol table
funcSyms <- asks parsedFuncSymtabs
return (IntMap.lookup n . bbSymtab =<< Map.lookup fn funcSyms)
Nothing -> do
-- Lookup entry in global (top-level) symbol table
symtab <- getValueSymtab
return (IntMap.lookup n (bbSymtab symtab))
-- | Lookup the name of a basic block.
requireBbEntryName :: Maybe Symbol -> Int -> Finalize BlockLabel
requireBbEntryName mbSym n = do
mb <- bbEntryName mbSym n
case mb of
Just l -> return l
Nothing -> fail ("basic block " ++ show n ++ " / " ++ show mbSym ++ " has no id")
-- Type Symbol Tables ----------------------------------------------------------
data TypeSymtab = TypeSymtab
{ tsById :: IntMap.IntMap Ident
, tsByName :: Map.Map Ident Int
} deriving Show
instance Semigroup TypeSymtab where
l <> r = TypeSymtab
{ tsById = tsById l `IntMap.union` tsById r
, tsByName = tsByName l `Map.union` tsByName r
}
instance Monoid TypeSymtab where
mempty = TypeSymtab
{ tsById = IntMap.empty
, tsByName = Map.empty
}
mappend = (<>)
addTypeSymbol :: Int -> Ident -> TypeSymtab -> TypeSymtab
addTypeSymbol ix n ts = ts
{ tsById = IntMap.insert ix n (tsById ts)
, tsByName = Map.insert n ix (tsByName ts)
}
-- Metadata Kind Table ---------------------------------------------------------
data KindTable = KindTable
{ ktNames :: IntMap.IntMap String
} deriving (Show)
emptyKindTable :: KindTable
emptyKindTable = KindTable
{ ktNames = IntMap.fromList
[ (0, "dbg" )
, (1, "tbaa" )
, (2, "prof" )
, (3, "fpmath")
, (4, "range" )
]
}
addKind :: Int -> String -> Parse ()
addKind kind name = Parse $ do
ps <- get
let KindTable { .. } = psKinds ps
put $! ps { psKinds = KindTable { ktNames = IntMap.insert kind name ktNames } }
getKind :: Int -> Parse String
getKind kind = do
ps <- Parse get
let KindTable { .. } = psKinds ps
case IntMap.lookup kind ktNames of
Just name -> return name
Nothing -> fail ("Unknown kind id: " ++ show kind ++ "\nKind table: " ++ show (psKinds ps))
-- Partial Symbols -------------------------------------------------------------
newtype StringTable = Strtab BS.ByteString
deriving (Show)
--newtype SymbolTable = Symtab BS.ByteString
mkStrtab :: BS.ByteString -> StringTable
mkStrtab = Strtab
--mkSymtab :: BS.ByteString -> SymbolTable
--mkSymtab = Symtab
resolveStrtabSymbol :: StringTable -> Int -> Int -> Symbol
resolveStrtabSymbol (Strtab bs) start len =
Symbol $ UTF8.decode $ BS.unpack $ BS.take len $ BS.drop start bs
-- Parser Warnings -------------------------------------------------------------
-- | Warnings about non-fatal issues that arise during parsing.
data ParseWarning
= -- | The parser encountered a metadata record with an unexpected size.
-- The 'Int' is the actual record size that was encountered, the
-- 'MetadataRecordSizeRange' is the expected range of possible sizes, and
-- the @[String]@ is the stack trace at the point where the warning was
-- emitted.
InvalidMetadataRecordSize !Int !MetadataRecordSizeRange ![String]
deriving Show
-- | The expected size of a metadata record.
data MetadataRecordSizeRange
= -- | The size is expected between a lower bound (the first 'Int') and an
-- upper bound (the second 'Int'), inclusive.
MetadataRecordSizeBetween !Int !Int
| -- | The size is expected to be within a certain list of possible values.
MetadataRecordSizeIn ![Int]
| -- The size is expected to be greater than or equal to a certain value.
MetadataRecordSizeAtLeast !Int
deriving Show
-- | Append a 'ParseWarning' to the end of the currently accumulated warnings.
addParseWarning :: ParseWarning -> Parse ()
addParseWarning pw = Parse $ do
ps <- get
put $! ps { psWarnings = psWarnings ps Seq.|> pw }
-- | Pretty-print a single 'ParseWarning' in a format suitable for user-facing
-- messages. (See also 'ppParseWarnings', which pretty-prints several
-- 'ParseWarnings's in a cohesive way.)
ppParseWarning :: ParseWarning -> PP.Doc
ppParseWarning (InvalidMetadataRecordSize len range cxt) =
PP.vcat $
[ "Invalid record size:" PP.<+> PP.pPrint len
, expectedSizeMsg
] ++ map PP.text (formatContext cxt)
where
expectedSizeMsg :: PP.Doc
expectedSizeMsg =
case range of
MetadataRecordSizeBetween lb ub ->
"Expected size between" PP.<+> PP.pPrint lb
PP.<+> "and" PP.<+> PP.pPrint ub
MetadataRecordSizeIn ns ->
"Expected one of:" PP.<+> PP.pPrint ns
MetadataRecordSizeAtLeast lb ->
"Expected size of" PP.<+> PP.pPrint lb PP.<+> "or greater"
-- | Pretty-print a group of 'ParseWarning's in a format suitable for
-- user-facing messages.
ppParseWarnings :: Seq.Seq ParseWarning -> PP.Doc
ppParseWarnings warnings
| null warnings
= PP.empty
| otherwise
= PP.vcat $
["Encountered the following warnings during parsing:"] ++
map
(\warning ->
PP.nest 4 $ PP.vcat [ppParseWarning warning, ""])
(F.toList warnings) ++
[supportMsg | any isInvalidMetadataRecordSize warnings]
where
isInvalidMetadataRecordSize :: ParseWarning -> Bool
isInvalidMetadataRecordSize (InvalidMetadataRecordSize {}) = True
supportMsg :: PP.Doc
supportMsg =
PP.vcat
[ "Are you sure you're using a supported version of LLVM/Clang?"
, "Check here: https://github.com/GaloisInc/llvm-pretty-bc-parser"
]
-- Finalize Monad --------------------------------------------------------------
-- | During the "finalization" pass, all references should be resolved, including
-- actual Block label value references, which may be to either global or
-- function-local targets. The 'Finalize' Monad provides access to the tables
-- needed to perform this resolution via the 'FinalizeEnv' data in a Reader monad
-- context.
data FinalizeEnv = FinalizeEnv
{ parsedEnv :: Env
, parsedMdTable :: ValueTable
, parsedValueTable :: ValueTable
, parsedFuncSymtabs :: FuncSymTabs
}
type FuncSymTabs = Map.Map Symbol ValueSymtab
newtype Finalize a = Finalize
{ unFinalize :: ReaderT FinalizeEnv (Except Error) a
} deriving (Functor, Applicative, MonadReader FinalizeEnv)
instance Monad Finalize where
#if !MIN_VERSION_base(4,11,0)
{-# INLINE return #-}
return = pure
#endif
{-# INLINE (>>=) #-}
Finalize m >>= f = Finalize (m >>= unFinalize . f)
#if !MIN_VERSION_base(4,13,0)
{-# INLINE fail #-}
fail = failWithContext'
#endif
instance MonadFail Finalize where
{-# INLINE fail #-}
fail = failWithContext'
instance Alternative Finalize where
{-# INLINE empty #-}
empty = failWithContext' "empty"
{-# INLINE (<|>) #-}
a <|> b = Finalize $ catchError (unFinalize a) (const (unFinalize b))
instance MonadPlus Finalize where
{-# INLINE mzero #-}
mzero = failWithContext' "mzero"
{-# INLINE mplus #-}
mplus = (<|>)
instance HasParseEnv Finalize where
getContext = asks $ envContext . parsedEnv
getValueSymtab = asks $ symValueSymtab . envSymtab . parsedEnv
instance HasMdTable Finalize where
getMdTable = asks parsedMdTable
instance HasValueTable Finalize where
getValueTable = asks parsedValueTable
-- | Fail, taking into account the current context.
failWithContext' :: String -> Finalize a
failWithContext' msg =
Finalize $
do env <- asks parsedEnv
throwError Error
{ errMessage = msg
, errContext = envContext env
}
-- | Run a Finalize Monad operation in the context of a Parse monad. The
-- information for the 'FinalizeEnv' is obtained from the Parse monad's 'Env',
-- plus the VALUE_SYMTAB_BLOCK information for each function as mapped by the
-- function's name.
liftFinalize :: FuncSymTabs -> Finalize a -> Parse a
liftFinalize defs (Finalize m) =
do env <- ask
mdt <- getMdTable
valt <- getValueTable
let fenv = FinalizeEnv { parsedEnv = env
, parsedMdTable = mdt
, parsedValueTable = valt
, parsedFuncSymtabs = defs
}
case runExcept (runReaderT m fenv) of
Left err -> throwError err
Right a -> return a