{-# 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
  { Error -> [[Char]]
errContext :: [String]
  , Error -> [Char]
errMessage :: String
  } deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> [Char]
(Int -> Error -> ShowS)
-> (Error -> [Char]) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> [Char]
show :: Error -> [Char]
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show, Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
/= :: Error -> Error -> Bool
Eq, Eq Error
Eq Error =>
(Error -> Error -> Ordering)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Bool)
-> (Error -> Error -> Error)
-> (Error -> Error -> Error)
-> Ord Error
Error -> Error -> Bool
Error -> Error -> Ordering
Error -> Error -> Error
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Error -> Error -> Ordering
compare :: Error -> Error -> Ordering
$c< :: Error -> Error -> Bool
< :: Error -> Error -> Bool
$c<= :: Error -> Error -> Bool
<= :: Error -> Error -> Bool
$c> :: Error -> Error -> Bool
> :: Error -> Error -> Bool
$c>= :: Error -> Error -> Bool
>= :: Error -> Error -> Bool
$cmax :: Error -> Error -> Error
max :: Error -> Error -> Error
$cmin :: Error -> Error -> Error
min :: Error -> Error -> Error
Ord)

formatError :: Error -> String
formatError :: Error -> [Char]
formatError Error
err
  | [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Error -> [[Char]]
errContext Error
err) = Error -> [Char]
errMessage Error
err
  | Bool
otherwise             = [[Char]] -> [Char]
unlines
                          ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ Error -> [Char]
errMessage Error
err
                          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
formatContext (Error -> [[Char]]
errContext Error
err)

formatContext :: [String] -> [String]
formatContext :: [[Char]] -> [[Char]]
formatContext [[Char]]
cxt = [Char]
"from:" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: ShowS -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'\t' Char -> ShowS
forall a. a -> [a] -> [a]
:) [[Char]]
cxt

newtype Parse a = Parse
  { forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse :: ReaderT Env (StateT ParseState (Except Error)) a
  } deriving ( (forall a b. (a -> b) -> Parse a -> Parse b)
-> (forall a b. a -> Parse b -> Parse a) -> Functor Parse
forall a b. a -> Parse b -> Parse a
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Parse a -> Parse b
fmap :: forall a b. (a -> b) -> Parse a -> Parse b
$c<$ :: forall a b. a -> Parse b -> Parse a
<$ :: forall a b. a -> Parse b -> Parse a
Functor, Functor Parse
Functor Parse =>
(forall a. a -> Parse a)
-> (forall a b. Parse (a -> b) -> Parse a -> Parse b)
-> (forall a b c. (a -> b -> c) -> Parse a -> Parse b -> Parse c)
-> (forall a b. Parse a -> Parse b -> Parse b)
-> (forall a b. Parse a -> Parse b -> Parse a)
-> Applicative Parse
forall a. a -> Parse a
forall a b. Parse a -> Parse b -> Parse a
forall a b. Parse a -> Parse b -> Parse b
forall a b. Parse (a -> b) -> Parse a -> Parse b
forall a b c. (a -> b -> c) -> Parse a -> Parse b -> Parse c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Parse a
pure :: forall a. a -> Parse a
$c<*> :: forall a b. Parse (a -> b) -> Parse a -> Parse b
<*> :: forall a b. Parse (a -> b) -> Parse a -> Parse b
$cliftA2 :: forall a b c. (a -> b -> c) -> Parse a -> Parse b -> Parse c
liftA2 :: forall a b c. (a -> b -> c) -> Parse a -> Parse b -> Parse c
$c*> :: forall a b. Parse a -> Parse b -> Parse b
*> :: forall a b. Parse a -> Parse b -> Parse b
$c<* :: forall a b. Parse a -> Parse b -> Parse a
<* :: forall a b. Parse a -> Parse b -> Parse a
Applicative, Monad Parse
Monad Parse =>
(forall a. (a -> Parse a) -> Parse a) -> MonadFix Parse
forall a. (a -> Parse a) -> Parse a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall a. (a -> Parse a) -> Parse a
mfix :: forall a. (a -> Parse a) -> Parse a
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 ReaderT Env (StateT ParseState (Except Error)) a
m >>= :: forall a b. Parse a -> (a -> Parse b) -> Parse b
>>= a -> Parse b
f = ReaderT Env (StateT ParseState (Except Error)) b -> Parse b
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a
m ReaderT Env (StateT ParseState (Except Error)) a
-> (a -> ReaderT Env (StateT ParseState (Except Error)) b)
-> ReaderT Env (StateT ParseState (Except Error)) b
forall a b.
ReaderT Env (StateT ParseState (Except Error)) a
-> (a -> ReaderT Env (StateT ParseState (Except Error)) b)
-> ReaderT Env (StateT ParseState (Except Error)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parse b -> ReaderT Env (StateT ParseState (Except Error)) b
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse (Parse b -> ReaderT Env (StateT ParseState (Except Error)) b)
-> (a -> Parse b)
-> a
-> ReaderT Env (StateT ParseState (Except Error)) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Parse b
f)

#if !MIN_VERSION_base(4,13,0)
  {-# INLINE fail #-}
  fail = failWithContext
#endif

instance MonadFail Parse where
  {-# INLINE fail #-}
  fail :: forall a. [Char] -> Parse a
fail = [Char] -> Parse a
forall a. [Char] -> Parse a
failWithContext

instance Alternative Parse where
  {-# INLINE empty #-}
  empty :: forall a. Parse a
empty = [Char] -> Parse a
forall a. [Char] -> Parse a
failWithContext [Char]
"empty"

  {-# INLINE (<|>) #-}
  Parse a
a <|> :: forall a. Parse a -> Parse a -> Parse a
<|> Parse a
b = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ ReaderT Env (StateT ParseState (Except Error)) a
-> (Error -> ReaderT Env (StateT ParseState (Except Error)) a)
-> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a
-> (Error -> ReaderT Env (StateT ParseState (Except Error)) a)
-> ReaderT Env (StateT ParseState (Except Error)) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
a) (ReaderT Env (StateT ParseState (Except Error)) a
-> Error -> ReaderT Env (StateT ParseState (Except Error)) a
forall a b. a -> b -> a
const (Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
b))

instance MonadPlus Parse where
  {-# INLINE mzero #-}
  mzero :: forall a. Parse a
mzero = [Char] -> Parse a
forall a. [Char] -> Parse a
failWithContext [Char]
"mzero"

  {-# INLINE mplus #-}
  mplus :: forall a. Parse a -> Parse a -> Parse a
mplus = Parse a -> Parse a -> Parse a
forall a. Parse a -> Parse a -> Parse a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

runParse :: Parse a -> Either Error (a, ParseState)
runParse :: forall a. Parse a -> Either Error (a, ParseState)
runParse (Parse ReaderT Env (StateT ParseState (Except Error)) a
m) =
  case Except Error (a, ParseState) -> Either Error (a, ParseState)
forall e a. Except e a -> Either e a
runExcept (StateT ParseState (Except Error) a
-> ParseState -> Except Error (a, ParseState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT Env (StateT ParseState (Except Error)) a
-> Env -> StateT ParseState (Except Error) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Env (StateT ParseState (Except Error)) a
m Env
emptyEnv) ParseState
emptyParseState) of
    Left Error
err  -> Error -> Either Error (a, ParseState)
forall a b. a -> Either a b
Left Error
err
    Right (a, ParseState)
res -> (a, ParseState) -> Either Error (a, ParseState)
forall a b. b -> Either a b
Right (a, ParseState)
res

notImplemented :: Parse a
notImplemented :: forall a. Parse a
notImplemented  = [Char] -> Parse a
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"not implemented"

-- Parse State -----------------------------------------------------------------

data ParseState = ParseState
  { ParseState -> TypeTable
psTypeTable     :: TypeTable
  , ParseState -> Int
psTypeTableSize :: !Int
  , ParseState -> ValueTable
psValueTable    :: ValueTable
  , ParseState -> Maybe StringTable
psStringTable   :: Maybe StringTable
  , ParseState -> ValueTable
psMdTable       :: ValueTable
  , ParseState -> MdRefTable
psMdRefs        :: MdRefTable
  , ParseState -> Seq FunProto
psFunProtos     :: Seq.Seq FunProto
  , ParseState -> Int
psNextResultId  :: !Int
  , ParseState -> Maybe [Char]
psTypeName      :: Maybe String
  , ParseState -> Int
psNextTypeId    :: !Int
  , ParseState -> Maybe PDebugLoc
psLastLoc       :: Maybe PDebugLoc
  , ParseState -> KindTable
psKinds         :: !KindTable
  , ParseState -> Int
psModVersion    :: !Int
  , ParseState -> Seq ParseWarning
psWarnings      :: Seq.Seq ParseWarning
  } deriving (Int -> ParseState -> ShowS
[ParseState] -> ShowS
ParseState -> [Char]
(Int -> ParseState -> ShowS)
-> (ParseState -> [Char])
-> ([ParseState] -> ShowS)
-> Show ParseState
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseState -> ShowS
showsPrec :: Int -> ParseState -> ShowS
$cshow :: ParseState -> [Char]
show :: ParseState -> [Char]
$cshowList :: [ParseState] -> ShowS
showList :: [ParseState] -> ShowS
Show)

-- | The initial parsing state.
emptyParseState :: ParseState
emptyParseState :: ParseState
emptyParseState  = ParseState
  { psTypeTable :: TypeTable
psTypeTable     = TypeTable
forall a. IntMap a
IntMap.empty
  , psTypeTableSize :: Int
psTypeTableSize = Int
0
  , psValueTable :: ValueTable
psValueTable    = Bool -> ValueTable
emptyValueTable Bool
False
  , psStringTable :: Maybe StringTable
psStringTable   = Maybe StringTable
forall a. Maybe a
Nothing
  , psMdTable :: ValueTable
psMdTable       = Bool -> ValueTable
emptyValueTable Bool
False
  , psMdRefs :: MdRefTable
psMdRefs        = MdRefTable
forall a. IntMap a
IntMap.empty
  , psFunProtos :: Seq FunProto
psFunProtos     = Seq FunProto
forall a. Seq a
Seq.empty
  , psNextResultId :: Int
psNextResultId  = Int
0
  , psTypeName :: Maybe [Char]
psTypeName      = Maybe [Char]
forall a. Maybe a
Nothing
  , psNextTypeId :: Int
psNextTypeId    = Int
0
  , psLastLoc :: Maybe PDebugLoc
psLastLoc       = Maybe PDebugLoc
forall a. Maybe a
Nothing
  , psKinds :: KindTable
psKinds         = KindTable
emptyKindTable
  , psModVersion :: Int
psModVersion    = Int
0
  , psWarnings :: Seq ParseWarning
psWarnings      = Seq ParseWarning
forall a. Seq a
Seq.empty
  }

-- | The next implicit result id.
nextResultId :: Parse Int
nextResultId :: Parse Int
nextResultId  = ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int)
-> ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psNextResultId = psNextResultId ps + 1 }
  Int -> ReaderT Env (StateT ParseState (Except Error)) Int
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseState -> Int
psNextResultId ParseState
ps)

type PDebugLoc = DebugLoc' Int

setLastLoc :: PDebugLoc -> Parse ()
setLastLoc :: PDebugLoc -> Parse ()
setLastLoc PDebugLoc
loc = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psLastLoc = Just loc }

setRelIds :: Bool -> Parse ()
setRelIds :: Bool -> Parse ()
setRelIds Bool
b = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psValueTable = (psValueTable ps) { valueRelIds = b }}

getRelIds :: HasValueTable m => m Bool
getRelIds :: forall (m :: * -> *). HasValueTable m => m Bool
getRelIds  = ValueTable -> Bool
valueRelIds (ValueTable -> Bool) -> m ValueTable -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m ValueTable
forall (m :: * -> *). HasValueTable m => m ValueTable
getValueTable

getLastLoc :: Parse PDebugLoc
getLastLoc :: Parse PDebugLoc
getLastLoc  = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  case ParseState -> Maybe PDebugLoc
psLastLoc ParseState
ps of
    Just PDebugLoc
loc -> PDebugLoc -> Parse PDebugLoc
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return PDebugLoc
loc
    Maybe PDebugLoc
Nothing  -> [Char] -> Parse PDebugLoc
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"No last location available"

setModVersion :: Int -> Parse ()
setModVersion :: Int -> Parse ()
setModVersion Int
v = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psModVersion = v }

getModVersion :: Parse Int
getModVersion :: Parse Int
getModVersion = ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> Int
psModVersion (ParseState -> Int)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
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 :: forall a. Parse a -> Parse a
enterFunctionDef Parse a
m = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps  <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps
    { psNextResultId = 0
    }
  a
res <- Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
m
  ParseState
ps' <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps'
    { psValueTable = psValueTable ps
    , psMdTable    = psMdTable ps
    , psMdRefs     = psMdRefs ps
    , psLastLoc    = Nothing
    }
  a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res


-- Type Table ------------------------------------------------------------------

type TypeTable = IntMap.IntMap Type

-- | Generate a type table, and a type symbol table.
mkTypeTable :: [Type] -> TypeTable
mkTypeTable :: [Type' Ident] -> TypeTable
mkTypeTable  = [(Int, Type' Ident)] -> TypeTable
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, Type' Ident)] -> TypeTable)
-> ([Type' Ident] -> [(Int, Type' Ident)])
-> [Type' Ident]
-> TypeTable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Type' Ident] -> [(Int, Type' Ident)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..]

-- | Exceptions contain a callstack, parsing context, explanation, and index
data BadForwardRef
  = BadTypeRef  CallStack [String] String Int
  | BadValueRef CallStack [String] String Int
    deriving (Int -> BadForwardRef -> ShowS
[BadForwardRef] -> ShowS
BadForwardRef -> [Char]
(Int -> BadForwardRef -> ShowS)
-> (BadForwardRef -> [Char])
-> ([BadForwardRef] -> ShowS)
-> Show BadForwardRef
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BadForwardRef -> ShowS
showsPrec :: Int -> BadForwardRef -> ShowS
$cshow :: BadForwardRef -> [Char]
show :: BadForwardRef -> [Char]
$cshowList :: [BadForwardRef] -> ShowS
showList :: [BadForwardRef] -> ShowS
Show,Typeable)

instance X.Exception BadForwardRef

badRefError :: BadForwardRef -> Error
badRefError :: BadForwardRef -> Error
badRefError BadForwardRef
ref =
  let (CallStack
stk, [[Char]]
cxt, [Char]
explanation, Int
i, [Char]
thing) =
        case BadForwardRef
ref of
          BadTypeRef  CallStack
stk' [[Char]]
cxt' [Char]
explanation' Int
i' -> (CallStack
stk', [[Char]]
cxt', [Char]
explanation', Int
i', [Char]
"type")
          BadValueRef CallStack
stk' [[Char]]
cxt' [Char]
explanation' Int
i' -> (CallStack
stk', [[Char]]
cxt', [Char]
explanation', Int
i', [Char]
"value")
  in [[Char]] -> [Char] -> Error
Error [[Char]]
cxt ([Char] -> Error) -> [Char] -> Error
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines [[Char]
"bad forward reference to " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
thing [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
                         , [Char]
"additional details: "
                         , [Char]
explanation
                         , [Char]
"with call stack: "
                         , CallStack -> [Char]
prettyCallStack CallStack
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 :: HasCallStack => [[Char]] -> Int -> TypeTable -> Type' Ident
lookupTypeRef [[Char]]
cxt Int
n =
  let explanation :: [Char]
explanation = [Char]
"Bad reference into type table"
  in Type' Ident -> Maybe (Type' Ident) -> Type' Ident
forall a. a -> Maybe a -> a
fromMaybe (BadForwardRef -> Type' Ident
forall a e. Exception e => e -> a
X.throw (CallStack -> [[Char]] -> [Char] -> Int -> BadForwardRef
BadTypeRef CallStack
HasCallStack => CallStack
callStack [[Char]]
cxt [Char]
explanation Int
n)) (Maybe (Type' Ident) -> Type' Ident)
-> (TypeTable -> Maybe (Type' Ident)) -> TypeTable -> Type' Ident
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TypeTable -> Maybe (Type' Ident)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n

setTypeTable :: TypeTable -> Parse ()
setTypeTable :: TypeTable -> Parse ()
setTypeTable TypeTable
table = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psTypeTable = table }

getTypeTable :: Parse TypeTable
getTypeTable :: Parse TypeTable
getTypeTable  = ReaderT Env (StateT ParseState (Except Error)) TypeTable
-> Parse TypeTable
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> TypeTable
psTypeTable (ParseState -> TypeTable)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) TypeTable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

setTypeTableSize :: Int -> Parse ()
setTypeTableSize :: Int -> Parse ()
setTypeTableSize Int
n = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psTypeTableSize = n }

-- | Retrieve the current type name, failing if it hasn't been set.
getTypeName :: Parse Ident
getTypeName :: Parse Ident
getTypeName  = ReaderT Env (StateT ParseState (Except Error)) Ident -> Parse Ident
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) Ident
 -> Parse Ident)
-> ReaderT Env (StateT ParseState (Except Error)) Ident
-> Parse Ident
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps  <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  [Char]
str <- case ParseState -> Maybe [Char]
psTypeName ParseState
ps of
    Just [Char]
tn -> do
      ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psTypeName = Nothing }
      [Char] -> ReaderT Env (StateT ParseState (Except Error)) [Char]
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
tn
    Maybe [Char]
Nothing -> do
      ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psNextTypeId = psNextTypeId ps + 1 }
      [Char] -> ReaderT Env (StateT ParseState (Except Error)) [Char]
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> [Char]
forall a. Show a => a -> [Char]
show (ParseState -> Int
psNextTypeId ParseState
ps))
  Ident -> ReaderT Env (StateT ParseState (Except Error)) Ident
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Ident
Ident [Char]
str)

setTypeName :: String -> Parse ()
setTypeName :: [Char] -> Parse ()
setTypeName [Char]
name = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psTypeName = Just name }

-- | Lookup the value of a type; don't attempt to resolve to an alias.
getType' :: Int -> Parse Type
getType' :: Int -> Parse (Type' Ident)
getType' Int
ref = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
ref Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ParseState -> Int
psTypeTableSize ParseState
ps)
    ([Char] -> Parse ()
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"type reference " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ref [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is too large"))
  [[Char]]
cxt <- Parse [[Char]]
forall (m :: * -> *). HasParseEnv m => m [[Char]]
getContext
  Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => [[Char]] -> Int -> TypeTable -> Type' Ident
[[Char]] -> Int -> TypeTable -> Type' Ident
lookupTypeRef [[Char]]
cxt Int
ref (ParseState -> TypeTable
psTypeTable ParseState
ps))

-- | Test to see if the type table has been added to already.
isTypeTableEmpty :: Parse Bool
isTypeTableEmpty :: Parse Bool
isTypeTableEmpty  = ReaderT Env (StateT ParseState (Except Error)) Bool -> Parse Bool
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (TypeTable -> Bool
forall a. IntMap a -> Bool
IntMap.null (TypeTable -> Bool)
-> (ParseState -> TypeTable) -> ParseState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState -> TypeTable
psTypeTable (ParseState -> Bool)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

setStringTable :: StringTable -> Parse ()
setStringTable :: StringTable -> Parse ()
setStringTable StringTable
st = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psStringTable = Just st }

getStringTable :: Parse (Maybe StringTable)
getStringTable :: Parse (Maybe StringTable)
getStringTable = ReaderT Env (StateT ParseState (Except Error)) (Maybe StringTable)
-> Parse (Maybe StringTable)
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> Maybe StringTable
psStringTable (ParseState -> Maybe StringTable)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT
     Env (StateT ParseState (Except Error)) (Maybe StringTable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get)

-- Value Tables ----------------------------------------------------------------

-- | Values that have an identifier instead of a string label
type PValue = Value' Int

type PInstr = Instr' Int

data ValueTable = ValueTable
  { ValueTable -> Int
valueNextId  :: !Int
  , ValueTable -> IntMap (Typed PValue)
valueEntries :: IntMap.IntMap (Typed PValue)
  , ValueTable -> IntMap (Int, Int)
strtabEntries :: IntMap.IntMap (Int, Int)
  , ValueTable -> Bool
valueRelIds  :: Bool
  } deriving (Int -> ValueTable -> ShowS
[ValueTable] -> ShowS
ValueTable -> [Char]
(Int -> ValueTable -> ShowS)
-> (ValueTable -> [Char])
-> ([ValueTable] -> ShowS)
-> Show ValueTable
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueTable -> ShowS
showsPrec :: Int -> ValueTable -> ShowS
$cshow :: ValueTable -> [Char]
show :: ValueTable -> [Char]
$cshowList :: [ValueTable] -> ShowS
showList :: [ValueTable] -> ShowS
Show)

emptyValueTable :: Bool -> ValueTable
emptyValueTable :: Bool -> ValueTable
emptyValueTable Bool
rel = ValueTable
  { valueNextId :: Int
valueNextId  = Int
0
  , valueEntries :: IntMap (Typed PValue)
valueEntries = IntMap (Typed PValue)
forall a. IntMap a
IntMap.empty
  , strtabEntries :: IntMap (Int, Int)
strtabEntries = IntMap (Int, Int)
forall a. IntMap a
IntMap.empty
  , valueRelIds :: Bool
valueRelIds  = Bool
rel
  }

addValue :: Typed PValue -> ValueTable -> ValueTable
addValue :: Typed PValue -> ValueTable -> ValueTable
addValue Typed PValue
tv ValueTable
vs = (Int, ValueTable) -> ValueTable
forall a b. (a, b) -> b
snd (Typed PValue -> ValueTable -> (Int, ValueTable)
addValue' Typed PValue
tv ValueTable
vs)

addValue' :: Typed PValue -> ValueTable -> (Int,ValueTable)
addValue' :: Typed PValue -> ValueTable -> (Int, ValueTable)
addValue' Typed PValue
tv ValueTable
vs = (ValueTable -> Int
valueNextId ValueTable
vs,ValueTable
vs')
  where
  vs' :: ValueTable
vs' = ValueTable
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 :: Typed PValue -> Parse Int
pushValue Typed PValue
tv = ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int)
-> ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  let vt :: ValueTable
vt = ParseState -> ValueTable
psValueTable ParseState
ps
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psValueTable = addValue tv vt }
  Int -> ReaderT Env (StateT ParseState (Except Error)) Int
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValueTable -> Int
valueNextId ValueTable
vt)

-- | Get the index for the next value.
nextValueId :: Parse Int
nextValueId :: Parse Int
nextValueId = ValueTable -> Int
valueNextId (ValueTable -> Int) -> Parse ValueTable -> Parse Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse ValueTable
forall (m :: * -> *). HasValueTable m => m ValueTable
getValueTable

-- | Depending on whether or not relative ids are in use, adjust the id.
adjustId :: Int -> Parse Int
adjustId :: Int -> Parse Int
adjustId Int
n = do
  ValueTable
vt <- Parse ValueTable
forall (m :: * -> *). HasValueTable m => m ValueTable
getValueTable
  Int -> Parse Int
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValueTable -> Int -> Int
translateValueId ValueTable
vt Int
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 :: ValueTable -> Int -> Int
translateValueId ValueTable
vt Int
n | ValueTable -> Bool
valueRelIds ValueTable
vt = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
adjusted
                      | Bool
otherwise      = Int
n
  where
  adjusted :: Word32
  adjusted :: Word32
adjusted  = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ValueTable -> Int
valueNextId ValueTable
vt Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n)

-- | Lookup an absolute address in the value table.
lookupValueTableAbs :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs Int
n ValueTable
values = Int -> IntMap (Typed PValue) -> Maybe (Typed PValue)
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (ValueTable -> IntMap (Typed PValue)
valueEntries ValueTable
values)

-- | When you know you have an absolute index.
lookupValueAbs :: HasValueTable m => Int -> m (Maybe (Typed PValue))
lookupValueAbs :: forall (m :: * -> *).
HasValueTable m =>
Int -> m (Maybe (Typed PValue))
lookupValueAbs Int
n = Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs Int
n (ValueTable -> Maybe (Typed PValue))
-> m ValueTable -> m (Maybe (Typed PValue))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` m ValueTable
forall (m :: * -> *). HasValueTable m => m ValueTable
getValueTable

-- | Lookup either a relative id, or an absolute id.
lookupValueTable :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTable :: Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTable Int
n ValueTable
values =
  Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs (ValueTable -> Int -> Int
translateValueId ValueTable
values Int
n) ValueTable
values

-- | Lookup a value in the value table.
lookupValue :: Int -> Parse (Maybe (Typed PValue))
lookupValue :: Int -> Parse (Maybe (Typed PValue))
lookupValue Int
n = Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTable Int
n (ValueTable -> Maybe (Typed PValue))
-> Parse ValueTable -> Parse (Maybe (Typed PValue))
forall a b. (a -> b) -> Parse a -> Parse b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parse ValueTable
forall (m :: * -> *). HasValueTable m => m ValueTable
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 :: HasCallStack => [[Char]] -> Int -> ValueTable -> Typed PValue
forwardRef [[Char]]
cxt Int
n ValueTable
vt =
  let explanation :: [Char]
explanation = [Char]
"Bad reference into a value table"
  in Typed PValue -> Maybe (Typed PValue) -> Typed PValue
forall a. a -> Maybe a -> a
fromMaybe (BadForwardRef -> Typed PValue
forall a e. Exception e => e -> a
X.throw (CallStack -> [[Char]] -> [Char] -> Int -> BadForwardRef
BadValueRef CallStack
HasCallStack => CallStack
callStack [[Char]]
cxt [Char]
explanation Int
n)) (Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs Int
n ValueTable
vt)

-- | Require that a value be present.
requireValue :: Int -> Parse (Typed PValue)
requireValue :: Int -> Parse (Typed PValue)
requireValue Int
n = do
  Maybe (Typed PValue)
mb <- Int -> Parse (Maybe (Typed PValue))
lookupValue Int
n
  case Maybe (Typed PValue)
mb of
    Just Typed PValue
tv -> Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Typed PValue
tv
    Maybe (Typed PValue)
Nothing -> [Char] -> Parse (Typed PValue)
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"value " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is not defined")

class Monad m => HasValueTable m where
  -- | Get the current value table.
  getValueTable :: m ValueTable

instance HasValueTable Parse where
  getValueTable :: Parse ValueTable
getValueTable  = (ParseState -> ValueTable) -> Parse ValueTable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ParseState -> ValueTable
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 :: Parse Int
getNextId  = ValueTable -> Int
valueNextId (ValueTable -> Int) -> Parse ValueTable -> Parse Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse ValueTable
forall (m :: * -> *). HasValueTable m => m ValueTable
getValueTable

-- | Set the current value table.
setValueTable :: ValueTable -> Parse ()
setValueTable :: ValueTable -> Parse ()
setValueTable ValueTable
vt = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psValueTable = vt }

-- | Update the value table, giving a lazy reference to the final table.
fixValueTable :: (ValueTable -> Parse (a,[Typed PValue])) -> Parse a
fixValueTable :: forall a. (ValueTable -> Parse (a, [Typed PValue])) -> Parse a
fixValueTable ValueTable -> Parse (a, [Typed PValue])
k = do
  ValueTable
vt <- Parse ValueTable
forall (m :: * -> *). HasValueTable m => m ValueTable
getValueTable
  rec let vt' :: ValueTable
vt' = (Typed PValue -> ValueTable -> ValueTable)
-> ValueTable -> [Typed PValue] -> ValueTable
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Typed PValue -> ValueTable -> ValueTable
addValue ValueTable
vt [Typed PValue]
vs
      (a
a,[Typed PValue]
vs) <- ValueTable -> Parse (a, [Typed PValue])
k ValueTable
vt'
  ValueTable -> Parse ()
setValueTable ValueTable
vt'
  a -> Parse a
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

fixValueTable_ :: (ValueTable -> Parse [Typed PValue]) -> Parse ()
fixValueTable_ :: (ValueTable -> Parse [Typed PValue]) -> Parse ()
fixValueTable_ ValueTable -> Parse [Typed PValue]
k = (ValueTable -> Parse ((), [Typed PValue])) -> Parse ()
forall a. (ValueTable -> Parse (a, [Typed PValue])) -> Parse a
fixValueTable ((ValueTable -> Parse ((), [Typed PValue])) -> Parse ())
-> (ValueTable -> Parse ((), [Typed PValue])) -> Parse ()
forall a b. (a -> b) -> a -> b
$ \ ValueTable
vt -> do
  [Typed PValue]
vs <- ValueTable -> Parse [Typed PValue]
k ValueTable
vt
  ((), [Typed PValue]) -> Parse ((), [Typed PValue])
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ((),[Typed PValue]
vs)


type PValMd = ValMd' Int

type MdTable = ValueTable

class Monad m => HasMdTable m where
  getMdTable :: m MdTable

instance HasMdTable Parse where
  getMdTable :: Parse ValueTable
getMdTable = (ParseState -> ValueTable) -> Parse ValueTable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ParseState -> ValueTable
psMdTable

setMdTable :: MdTable -> Parse ()
setMdTable :: ValueTable -> Parse ()
setMdTable ValueTable
md = (ParseState -> ParseState) -> Parse ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ParseState -> ParseState) -> Parse ())
-> (ParseState -> ParseState) -> Parse ()
forall a b. (a -> b) -> a -> b
$ \ParseState
ps -> ParseState
ps { psMdTable = md }

getMetadata :: Int -> Parse (Typed PValMd)
getMetadata :: Int -> Parse (Typed PValMd)
getMetadata Int
ix = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  case Int -> ParseState -> Maybe (Typed PValue)
resolveMd Int
ix ParseState
ps of
    Just Typed PValue
tv -> case Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
tv of
      ValMd PValMd
val -> Typed PValMd -> Parse (Typed PValMd)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Typed PValue
tv { typedValue = val }
      PValue
_         -> [Char] -> Parse (Typed PValMd)
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"unexpected non-metadata value in metadata table"
    Maybe (Typed PValue)
Nothing -> [Char] -> Parse (Typed PValMd)
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"metadata index " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ix [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is not defined")

resolveMd :: Int -> ParseState -> Maybe (Typed PValue)
resolveMd :: Int -> ParseState -> Maybe (Typed PValue)
resolveMd Int
ix ParseState
ps = Maybe (Typed PValue)
forall {lab}. Maybe (Typed (Value' lab))
nodeRef Maybe (Typed PValue)
-> Maybe (Typed PValue) -> Maybe (Typed PValue)
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe (Typed PValue)
mdValue
  where
  reference :: Int -> Typed (Value' lab)
reference = Type' Ident -> Value' lab -> Typed (Value' lab)
forall a. Type' Ident -> a -> Typed a
Typed (PrimType -> Type' Ident
forall ident. PrimType -> Type' ident
PrimType PrimType
Metadata) (Value' lab -> Typed (Value' lab))
-> (Int -> Value' lab) -> Int -> Typed (Value' lab)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValMd' lab -> Value' lab
forall lab. ValMd' lab -> Value' lab
ValMd (ValMd' lab -> Value' lab)
-> (Int -> ValMd' lab) -> Int -> Value' lab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ValMd' lab
forall lab. Int -> ValMd' lab
ValMdRef
  nodeRef :: Maybe (Typed (Value' lab))
nodeRef   = Int -> Typed (Value' lab)
forall {lab}. Int -> Typed (Value' lab)
reference (Int -> Typed (Value' lab))
-> Maybe Int -> Maybe (Typed (Value' lab))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> MdRefTable -> Maybe Int
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
ix (ParseState -> MdRefTable
psMdRefs ParseState
ps)
  mdValue :: Maybe (Typed PValue)
mdValue   = Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs Int
ix (ParseState -> ValueTable
psMdTable ParseState
ps)


type MdRefTable = IntMap.IntMap Int

setMdRefs :: MdRefTable -> Parse ()
setMdRefs :: MdRefTable -> Parse ()
setMdRefs MdRefTable
refs = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psMdRefs = refs `IntMap.union` psMdRefs ps }


-- Function Prototypes ---------------------------------------------------------

data FunProto = FunProto
  { FunProto -> Type' Ident
protoType       :: Type
  , FunProto -> Maybe Linkage
protoLinkage    :: Maybe Linkage
  , FunProto -> Maybe Visibility
protoVisibility :: Maybe Visibility
  , FunProto -> Maybe GC
protoGC         :: Maybe GC
  , FunProto -> Symbol
protoSym        :: Symbol
  , FunProto -> Int
protoIndex      :: Int
  , FunProto -> Maybe [Char]
protoSect       :: Maybe String
  , FunProto -> Maybe [Char]
protoComdat     :: Maybe String
  } deriving Int -> FunProto -> ShowS
[FunProto] -> ShowS
FunProto -> [Char]
(Int -> FunProto -> ShowS)
-> (FunProto -> [Char]) -> ([FunProto] -> ShowS) -> Show FunProto
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FunProto -> ShowS
showsPrec :: Int -> FunProto -> ShowS
$cshow :: FunProto -> [Char]
show :: FunProto -> [Char]
$cshowList :: [FunProto] -> ShowS
showList :: [FunProto] -> ShowS
Show

-- | Push a function prototype on to the prototype stack.
pushFunProto :: FunProto -> Parse ()
pushFunProto :: FunProto -> Parse ()
pushFunProto FunProto
p = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psFunProtos = psFunProtos ps Seq.|> p }

-- | Take a single function prototype off of the prototype stack.
popFunProto :: Parse FunProto
popFunProto :: Parse FunProto
popFunProto  = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  case Seq FunProto -> ViewL FunProto
forall a. Seq a -> ViewL a
Seq.viewl (ParseState -> Seq FunProto
psFunProtos ParseState
ps) of
    ViewL FunProto
Seq.EmptyL   -> [Char] -> Parse FunProto
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"empty function prototype stack"
    FunProto
p Seq.:< Seq FunProto
ps' -> do
      ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psFunProtos = ps' })
      FunProto -> Parse FunProto
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return FunProto
p


-- Parsing Environment ---------------------------------------------------------

-- | The Reader environment information maintained in the 'Parse' monad.
data Env = Env
  { Env -> Symtab
envSymtab  :: Symtab  -- ^ the global symbol table
  , Env -> [[Char]]
envContext :: [String] -- ^ the stack of "label" strings (a "stacktrace")
  } deriving Int -> Env -> ShowS
[Env] -> ShowS
Env -> [Char]
(Int -> Env -> ShowS)
-> (Env -> [Char]) -> ([Env] -> ShowS) -> Show Env
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Env -> ShowS
showsPrec :: Int -> Env -> ShowS
$cshow :: Env -> [Char]
show :: Env -> [Char]
$cshowList :: [Env] -> ShowS
showList :: [Env] -> ShowS
Show

emptyEnv :: Env
emptyEnv :: Env
emptyEnv  = Env
  { envSymtab :: Symtab
envSymtab  = Symtab
forall a. Monoid a => a
mempty
  , envContext :: [[Char]]
envContext = [[Char]]
forall a. Monoid a => a
mempty
  }

-- | Extend the symbol table for an environment, yielding a new environment.
extendSymtab :: Symtab -> Env -> Env
extendSymtab :: Symtab -> Env -> Env
extendSymtab Symtab
symtab Env
env = 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 :: [Char] -> Env -> Env
addLabel [Char]
l Env
env = 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 :: Parse [[Char]]
getContext = (Env -> [[Char]]) -> Parse [[Char]]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> [[Char]]
envContext
  getValueSymtab :: Parse ValueSymtab
getValueSymtab = (Env -> ValueSymtab) -> Parse ValueSymtab
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Env -> ValueSymtab) -> Parse ValueSymtab)
-> (Env -> ValueSymtab) -> Parse ValueSymtab
forall a b. (a -> b) -> a -> b
$ Symtab -> ValueSymtab
symValueSymtab (Symtab -> ValueSymtab) -> (Env -> Symtab) -> Env -> ValueSymtab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Symtab
envSymtab

data Symtab = Symtab
  { Symtab -> ValueSymtab
symValueSymtab :: ValueSymtab
  , Symtab -> TypeSymtab
symTypeSymtab  :: TypeSymtab
  } deriving (Int -> Symtab -> ShowS
[Symtab] -> ShowS
Symtab -> [Char]
(Int -> Symtab -> ShowS)
-> (Symtab -> [Char]) -> ([Symtab] -> ShowS) -> Show Symtab
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Symtab -> ShowS
showsPrec :: Int -> Symtab -> ShowS
$cshow :: Symtab -> [Char]
show :: Symtab -> [Char]
$cshowList :: [Symtab] -> ShowS
showList :: [Symtab] -> ShowS
Show)

instance Semigroup Symtab where
  Symtab
l <> :: Symtab -> Symtab -> Symtab
<> Symtab
r = Symtab
    { symValueSymtab :: ValueSymtab
symValueSymtab = Symtab -> ValueSymtab
symValueSymtab Symtab
l ValueSymtab -> ValueSymtab -> ValueSymtab
forall a. Semigroup a => a -> a -> a
<> Symtab -> ValueSymtab
symValueSymtab Symtab
r
    , symTypeSymtab :: TypeSymtab
symTypeSymtab  = Symtab -> TypeSymtab
symTypeSymtab  Symtab
l TypeSymtab -> TypeSymtab -> TypeSymtab
forall a. Semigroup a => a -> a -> a
<> Symtab -> TypeSymtab
symTypeSymtab  Symtab
r
    }

instance Monoid Symtab where
  mempty :: Symtab
mempty = Symtab
    { symValueSymtab :: ValueSymtab
symValueSymtab = ValueSymtab
emptyValueSymtab
    , symTypeSymtab :: TypeSymtab
symTypeSymtab  = TypeSymtab
forall a. Monoid a => a
mempty
    }

  mappend :: Symtab -> Symtab -> Symtab
mappend = Symtab -> Symtab -> Symtab
forall a. Semigroup a => a -> a -> a
(<>)

withSymtab :: Symtab -> Parse a -> Parse a
withSymtab :: forall a. Symtab -> Parse a -> Parse a
withSymtab Symtab
symtab Parse a
body = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ do
  (Env -> Env)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
(Env -> Env)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Symtab -> Env -> Env
extendSymtab Symtab
symtab) (Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
body)

-- | Run a computation with an extended value symbol table.
withValueSymtab :: ValueSymtab -> Parse a -> Parse a
withValueSymtab :: forall a. ValueSymtab -> Parse a -> Parse a
withValueSymtab ValueSymtab
symtab = Symtab -> Parse a -> Parse a
forall a. Symtab -> Parse a -> Parse a
withSymtab (Symtab
forall a. Monoid a => a
mempty { symValueSymtab = symtab })

-- | Run a computation with an extended type symbol table.
withTypeSymtab :: TypeSymtab -> Parse a -> Parse a
withTypeSymtab :: forall a. TypeSymtab -> Parse a -> Parse a
withTypeSymtab TypeSymtab
symtab = Symtab -> Parse a -> Parse a
forall a. Symtab -> Parse a -> Parse a
withSymtab (Symtab
forall a. Monoid a => a
mempty { symTypeSymtab = symtab })

-- | Retrieve the type symbol table.
getTypeSymtab :: Parse TypeSymtab
getTypeSymtab :: Parse TypeSymtab
getTypeSymtab  = ReaderT Env (StateT ParseState (Except Error)) TypeSymtab
-> Parse TypeSymtab
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (Symtab -> TypeSymtab
symTypeSymtab (Symtab -> TypeSymtab) -> (Env -> Symtab) -> Env -> TypeSymtab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Symtab
envSymtab (Env -> TypeSymtab)
-> ReaderT Env (StateT ParseState (Except Error)) Env
-> ReaderT Env (StateT ParseState (Except Error)) TypeSymtab
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (StateT ParseState (Except Error)) Env
forall r (m :: * -> *). MonadReader r m => m r
ask)

-- | Label a sub-computation with its context.
label :: String -> Parse a -> Parse a
label :: forall a. [Char] -> Parse a -> Parse a
label [Char]
l Parse a
m = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ do
  (Env -> Env)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
(Env -> Env)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ([Char] -> Env -> Env
addLabel [Char]
l) (Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
forall a.
Parse a -> ReaderT Env (StateT ParseState (Except Error)) a
unParse Parse a
m)

-- | Fail, taking into account the current context.
failWithContext :: String -> Parse a
failWithContext :: forall a. [Char] -> Parse a
failWithContext [Char]
msg = ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) a -> Parse a)
-> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a b. (a -> b) -> a -> b
$ do
  Env
env <- ReaderT Env (StateT ParseState (Except Error)) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  Error -> ReaderT Env (StateT ParseState (Except Error)) a
forall a. Error -> ReaderT Env (StateT ParseState (Except Error)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
    { errMessage :: [Char]
errMessage = [Char]
msg
    , errContext :: [[Char]]
errContext = Env -> [[Char]]
envContext Env
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 :: Int -> Parse (Type' Ident)
getType Int
ref = do
  TypeSymtab
symtab <- Parse TypeSymtab
getTypeSymtab
  case Int -> IntMap Ident -> Maybe Ident
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
ref (TypeSymtab -> IntMap Ident
tsById TypeSymtab
symtab) of
    Just Ident
i  -> Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ident -> Type' Ident
forall ident. ident -> Type' ident
Alias Ident
i)
    Maybe Ident
Nothing -> Int -> Parse (Type' Ident)
getType' Int
ref

-- | Find the id associated with a type alias.
getTypeId :: Ident -> Parse Int
getTypeId :: Ident -> Parse Int
getTypeId Ident
n = do
  TypeSymtab
symtab <- Parse TypeSymtab
getTypeSymtab
  case Ident -> Map Ident Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
n (TypeSymtab -> Map Ident Int
tsByName TypeSymtab
symtab) of
    Just Int
ix -> Int -> Parse Int
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
ix
    Maybe Int
Nothing -> [Char] -> Parse Int
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"unknown type alias " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc -> [Char]
forall a. Show a => a -> [Char]
show (Int -> ((?config::Config) => Doc) -> Doc
forall a. Int -> ((?config::Config) => a) -> a
ppLLVM Int
llvmVlatest (Ident -> Doc
forall a. LLVMPretty a => Fmt a
llvmPP Ident
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
  { ValueSymtab -> IntMap SymName
valSymtab :: IntMap.IntMap SymName
  , ValueSymtab -> IntMap SymName
bbSymtab  :: IntMap.IntMap SymName
  , ValueSymtab -> IntMap SymName
fnSymtab  :: IntMap.IntMap SymName
  } deriving (Int -> ValueSymtab -> ShowS
[ValueSymtab] -> ShowS
ValueSymtab -> [Char]
(Int -> ValueSymtab -> ShowS)
-> (ValueSymtab -> [Char])
-> ([ValueSymtab] -> ShowS)
-> Show ValueSymtab
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueSymtab -> ShowS
showsPrec :: Int -> ValueSymtab -> ShowS
$cshow :: ValueSymtab -> [Char]
show :: ValueSymtab -> [Char]
$cshowList :: [ValueSymtab] -> ShowS
showList :: [ValueSymtab] -> ShowS
Show)

type SymName = Either String Int

instance Semigroup ValueSymtab where
  ValueSymtab
l <> :: ValueSymtab -> ValueSymtab -> ValueSymtab
<> ValueSymtab
r = ValueSymtab
    { valSymtab :: IntMap SymName
valSymtab = ValueSymtab -> IntMap SymName
valSymtab ValueSymtab
l IntMap SymName -> IntMap SymName -> IntMap SymName
forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` ValueSymtab -> IntMap SymName
valSymtab ValueSymtab
r
    , bbSymtab :: IntMap SymName
bbSymtab  = ValueSymtab -> IntMap SymName
bbSymtab ValueSymtab
l  IntMap SymName -> IntMap SymName -> IntMap SymName
forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` ValueSymtab -> IntMap SymName
bbSymtab ValueSymtab
r
    , fnSymtab :: IntMap SymName
fnSymtab  = ValueSymtab -> IntMap SymName
fnSymtab ValueSymtab
l  IntMap SymName -> IntMap SymName -> IntMap SymName
forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` ValueSymtab -> IntMap SymName
fnSymtab ValueSymtab
r
    }

instance Monoid ValueSymtab where
  mappend :: ValueSymtab -> ValueSymtab -> ValueSymtab
mappend = ValueSymtab -> ValueSymtab -> ValueSymtab
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: ValueSymtab
mempty = ValueSymtab
    { valSymtab :: IntMap SymName
valSymtab = IntMap SymName
forall a. IntMap a
IntMap.empty
    , bbSymtab :: IntMap SymName
bbSymtab  = IntMap SymName
forall a. IntMap a
IntMap.empty
    , fnSymtab :: IntMap SymName
fnSymtab  = IntMap SymName
forall a. IntMap a
IntMap.empty
    }

renderName :: SymName -> String
renderName :: SymName -> [Char]
renderName  = ShowS -> (Int -> [Char]) -> SymName -> [Char]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ShowS
forall a. a -> a
id Int -> [Char]
forall a. Show a => a -> [Char]
show

mkBlockLabel :: SymName -> BlockLabel
mkBlockLabel :: SymName -> BlockLabel
mkBlockLabel  = ([Char] -> BlockLabel)
-> (Int -> BlockLabel) -> SymName -> BlockLabel
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Ident -> BlockLabel
Named (Ident -> BlockLabel) -> ([Char] -> Ident) -> [Char] -> BlockLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Ident
Ident) Int -> BlockLabel
Anon

emptyValueSymtab :: ValueSymtab
emptyValueSymtab :: ValueSymtab
emptyValueSymtab  = ValueSymtab
forall a. Monoid a => a
mempty

addEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addEntry :: Int -> [Char] -> ValueSymtab -> ValueSymtab
addEntry Int
i [Char]
n ValueSymtab
t = ValueSymtab
t { valSymtab = IntMap.insert i (Left n) (valSymtab t) }

addBBEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addBBEntry :: Int -> [Char] -> ValueSymtab -> ValueSymtab
addBBEntry Int
i [Char]
n ValueSymtab
t = ValueSymtab
t { bbSymtab = IntMap.insert i (Left n) (bbSymtab t) }

addBBAnon :: Int -> Int -> ValueSymtab -> ValueSymtab
addBBAnon :: Int -> Int -> ValueSymtab -> ValueSymtab
addBBAnon Int
i Int
n ValueSymtab
t = ValueSymtab
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 :: Int -> Int -> [Char] -> ValueSymtab -> ValueSymtab
addFNEntry Int
i Int
_o [Char]
n ValueSymtab
t = ValueSymtab
t { fnSymtab = IntMap.insert i (Left n) (fnSymtab t) }

addFwdFNEntry :: Int -> Int -> ValueSymtab -> ValueSymtab
addFwdFNEntry :: Int -> Int -> ValueSymtab -> ValueSymtab
addFwdFNEntry Int
i Int
o ValueSymtab
t = ValueSymtab
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 :: forall (m :: * -> *). HasParseEnv m => Int -> m (Maybe [Char])
entryNameMb Int
n = do
  ValueSymtab
symtab <- m ValueSymtab
forall (m :: * -> *). HasParseEnv m => m ValueSymtab
getValueSymtab
  Maybe [Char] -> m (Maybe [Char])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char] -> m (Maybe [Char]))
-> Maybe [Char] -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$! (SymName -> [Char]) -> Maybe SymName -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymName -> [Char]
renderName
         (Maybe SymName -> Maybe [Char]) -> Maybe SymName -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$  Int -> IntMap SymName -> Maybe SymName
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (ValueSymtab -> IntMap SymName
valSymtab ValueSymtab
symtab) Maybe SymName -> Maybe SymName -> Maybe SymName
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
            Int -> IntMap SymName -> Maybe SymName
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (ValueSymtab -> IntMap SymName
fnSymtab ValueSymtab
symtab)

-- | Lookup the name of an entry.
entryName :: (HasParseEnv m, HasValueTable m, MonadFail m) => Int -> m String
entryName :: forall (m :: * -> *).
(HasParseEnv m, HasValueTable m, MonadFail m) =>
Int -> m [Char]
entryName Int
n = do
  Maybe [Char]
mentry <- Int -> m (Maybe [Char])
forall (m :: * -> *). HasParseEnv m => Int -> m (Maybe [Char])
entryNameMb Int
n
  case Maybe [Char]
mentry of
    Just [Char]
name -> [Char] -> m [Char]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
name
    Maybe [Char]
Nothing   ->
      do Bool
isRel  <- m Bool
forall (m :: * -> *). HasValueTable m => m Bool
getRelIds
         ValueSymtab
symtab <- m ValueSymtab
forall (m :: * -> *). HasParseEnv m => m ValueSymtab
getValueSymtab
         [Char] -> m [Char]
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
           [ [Char]
"entry " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Bool
isRel then [Char]
" (relative)" else [Char]
"")
              [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is missing from the symbol table"
           , ValueSymtab -> [Char]
forall a. Show a => a -> [Char]
show ValueSymtab
symtab ]

-- | Lookup the name of a basic block.
bbEntryName :: Maybe Symbol -> Int -> Finalize (Maybe BlockLabel)
bbEntryName :: Maybe Symbol -> Int -> Finalize (Maybe BlockLabel)
bbEntryName Maybe Symbol
mbSym Int
n =
  (SymName -> BlockLabel) -> Maybe SymName -> Maybe BlockLabel
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymName -> BlockLabel
mkBlockLabel
  (Maybe SymName -> Maybe BlockLabel)
-> Finalize (Maybe SymName) -> Finalize (Maybe BlockLabel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case Maybe Symbol
mbSym of
        Just Symbol
fn -> do
          -- Lookup entry in a function (Defines) symbol table
          FuncSymTabs
funcSyms <- (FinalizeEnv -> FuncSymTabs) -> Finalize FuncSymTabs
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks FinalizeEnv -> FuncSymTabs
parsedFuncSymtabs
          Maybe SymName -> Finalize (Maybe SymName)
forall a. a -> Finalize a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IntMap SymName -> Maybe SymName
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (IntMap SymName -> Maybe SymName)
-> (ValueSymtab -> IntMap SymName) -> ValueSymtab -> Maybe SymName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueSymtab -> IntMap SymName
bbSymtab (ValueSymtab -> Maybe SymName)
-> Maybe ValueSymtab -> Maybe SymName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Symbol -> FuncSymTabs -> Maybe ValueSymtab
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Symbol
fn FuncSymTabs
funcSyms)
        Maybe Symbol
Nothing -> do
          -- Lookup entry in global (top-level) symbol table
          ValueSymtab
symtab <- Finalize ValueSymtab
forall (m :: * -> *). HasParseEnv m => m ValueSymtab
getValueSymtab
          Maybe SymName -> Finalize (Maybe SymName)
forall a. a -> Finalize a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IntMap SymName -> Maybe SymName
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (ValueSymtab -> IntMap SymName
bbSymtab ValueSymtab
symtab))

-- | Lookup the name of a basic block.
requireBbEntryName :: Maybe Symbol -> Int -> Finalize BlockLabel
requireBbEntryName :: Maybe Symbol -> Int -> Finalize BlockLabel
requireBbEntryName Maybe Symbol
mbSym Int
n = do
  Maybe BlockLabel
mb <- Maybe Symbol -> Int -> Finalize (Maybe BlockLabel)
bbEntryName Maybe Symbol
mbSym Int
n
  case Maybe BlockLabel
mb of
    Just BlockLabel
l  -> BlockLabel -> Finalize BlockLabel
forall a. a -> Finalize a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockLabel
l
    Maybe BlockLabel
Nothing -> [Char] -> Finalize BlockLabel
forall a. [Char] -> Finalize a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"basic block " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" / " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Symbol -> [Char]
forall a. Show a => a -> [Char]
show Maybe Symbol
mbSym [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" has no id")

-- Type Symbol Tables ----------------------------------------------------------

data TypeSymtab = TypeSymtab
  { TypeSymtab -> IntMap Ident
tsById   :: IntMap.IntMap Ident
  , TypeSymtab -> Map Ident Int
tsByName :: Map.Map Ident Int
  } deriving Int -> TypeSymtab -> ShowS
[TypeSymtab] -> ShowS
TypeSymtab -> [Char]
(Int -> TypeSymtab -> ShowS)
-> (TypeSymtab -> [Char])
-> ([TypeSymtab] -> ShowS)
-> Show TypeSymtab
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeSymtab -> ShowS
showsPrec :: Int -> TypeSymtab -> ShowS
$cshow :: TypeSymtab -> [Char]
show :: TypeSymtab -> [Char]
$cshowList :: [TypeSymtab] -> ShowS
showList :: [TypeSymtab] -> ShowS
Show

instance Semigroup TypeSymtab where
  TypeSymtab
l <> :: TypeSymtab -> TypeSymtab -> TypeSymtab
<> TypeSymtab
r = TypeSymtab
    { tsById :: IntMap Ident
tsById   = TypeSymtab -> IntMap Ident
tsById   TypeSymtab
l IntMap Ident -> IntMap Ident -> IntMap Ident
forall a. IntMap a -> IntMap a -> IntMap a
`IntMap.union` TypeSymtab -> IntMap Ident
tsById TypeSymtab
r
    , tsByName :: Map Ident Int
tsByName = TypeSymtab -> Map Ident Int
tsByName TypeSymtab
l Map Ident Int -> Map Ident Int -> Map Ident Int
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` TypeSymtab -> Map Ident Int
tsByName TypeSymtab
r
    }

instance Monoid TypeSymtab where
  mempty :: TypeSymtab
mempty = TypeSymtab
    { tsById :: IntMap Ident
tsById   = IntMap Ident
forall a. IntMap a
IntMap.empty
    , tsByName :: Map Ident Int
tsByName = Map Ident Int
forall k a. Map k a
Map.empty
    }

  mappend :: TypeSymtab -> TypeSymtab -> TypeSymtab
mappend = TypeSymtab -> TypeSymtab -> TypeSymtab
forall a. Semigroup a => a -> a -> a
(<>)

addTypeSymbol :: Int -> Ident -> TypeSymtab -> TypeSymtab
addTypeSymbol :: Int -> Ident -> TypeSymtab -> TypeSymtab
addTypeSymbol Int
ix Ident
n TypeSymtab
ts = TypeSymtab
ts
  { tsById   = IntMap.insert ix n (tsById ts)
  , tsByName = Map.insert n ix (tsByName ts)
  }


-- Metadata Kind Table ---------------------------------------------------------

data KindTable = KindTable
  { KindTable -> IntMap [Char]
ktNames :: IntMap.IntMap String
  } deriving (Int -> KindTable -> ShowS
[KindTable] -> ShowS
KindTable -> [Char]
(Int -> KindTable -> ShowS)
-> (KindTable -> [Char])
-> ([KindTable] -> ShowS)
-> Show KindTable
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KindTable -> ShowS
showsPrec :: Int -> KindTable -> ShowS
$cshow :: KindTable -> [Char]
show :: KindTable -> [Char]
$cshowList :: [KindTable] -> ShowS
showList :: [KindTable] -> ShowS
Show)

emptyKindTable :: KindTable
emptyKindTable :: KindTable
emptyKindTable  = KindTable
  { ktNames :: IntMap [Char]
ktNames = [(Int, [Char])] -> IntMap [Char]
forall a. [(Int, a)] -> IntMap a
IntMap.fromList
    [ (Int
0, [Char]
"dbg"   )
    , (Int
1, [Char]
"tbaa"  )
    , (Int
2, [Char]
"prof"  )
    , (Int
3, [Char]
"fpmath")
    , (Int
4, [Char]
"range" )
    ]
  }

addKind :: Int -> String -> Parse ()
addKind :: Int -> [Char] -> Parse ()
addKind Int
kind [Char]
name = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  let KindTable { IntMap [Char]
ktNames :: KindTable -> IntMap [Char]
ktNames :: IntMap [Char]
.. } = ParseState -> KindTable
psKinds ParseState
ps
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
ps { psKinds = KindTable { ktNames = IntMap.insert kind name ktNames } }

getKind :: Int -> Parse String
getKind :: Int -> Parse [Char]
getKind Int
kind = do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
-> Parse ParseState
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  let KindTable { IntMap [Char]
ktNames :: KindTable -> IntMap [Char]
ktNames :: IntMap [Char]
.. } = ParseState -> KindTable
psKinds ParseState
ps
  case Int -> IntMap [Char] -> Maybe [Char]
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
kind IntMap [Char]
ktNames of
    Just [Char]
name -> [Char] -> Parse [Char]
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
name
    Maybe [Char]
Nothing   -> [Char] -> Parse [Char]
forall a. [Char] -> Parse a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unknown kind id: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
kind [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\nKind table: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ KindTable -> [Char]
forall a. Show a => a -> [Char]
show (ParseState -> KindTable
psKinds ParseState
ps))

-- Partial Symbols -------------------------------------------------------------

newtype StringTable = Strtab BS.ByteString
  deriving (Int -> StringTable -> ShowS
[StringTable] -> ShowS
StringTable -> [Char]
(Int -> StringTable -> ShowS)
-> (StringTable -> [Char])
-> ([StringTable] -> ShowS)
-> Show StringTable
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StringTable -> ShowS
showsPrec :: Int -> StringTable -> ShowS
$cshow :: StringTable -> [Char]
show :: StringTable -> [Char]
$cshowList :: [StringTable] -> ShowS
showList :: [StringTable] -> ShowS
Show)
--newtype SymbolTable = Symtab BS.ByteString

mkStrtab :: BS.ByteString -> StringTable
mkStrtab :: ByteString -> StringTable
mkStrtab = ByteString -> StringTable
Strtab

--mkSymtab :: BS.ByteString -> SymbolTable
--mkSymtab = Symtab

resolveStrtabSymbol :: StringTable -> Int -> Int -> Symbol
resolveStrtabSymbol :: StringTable -> Int -> Int -> Symbol
resolveStrtabSymbol (Strtab ByteString
bs) Int
start Int
len =
  [Char] -> Symbol
Symbol ([Char] -> Symbol) -> [Char] -> Symbol
forall a b. (a -> b) -> a -> b
$ [Word8] -> [Char]
UTF8.decode ([Word8] -> [Char]) -> [Word8] -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack (ByteString -> [Word8]) -> ByteString -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
len (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
start ByteString
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 Int -> ParseWarning -> ShowS
[ParseWarning] -> ShowS
ParseWarning -> [Char]
(Int -> ParseWarning -> ShowS)
-> (ParseWarning -> [Char])
-> ([ParseWarning] -> ShowS)
-> Show ParseWarning
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseWarning -> ShowS
showsPrec :: Int -> ParseWarning -> ShowS
$cshow :: ParseWarning -> [Char]
show :: ParseWarning -> [Char]
$cshowList :: [ParseWarning] -> ShowS
showList :: [ParseWarning] -> ShowS
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 Int -> MetadataRecordSizeRange -> ShowS
[MetadataRecordSizeRange] -> ShowS
MetadataRecordSizeRange -> [Char]
(Int -> MetadataRecordSizeRange -> ShowS)
-> (MetadataRecordSizeRange -> [Char])
-> ([MetadataRecordSizeRange] -> ShowS)
-> Show MetadataRecordSizeRange
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MetadataRecordSizeRange -> ShowS
showsPrec :: Int -> MetadataRecordSizeRange -> ShowS
$cshow :: MetadataRecordSizeRange -> [Char]
show :: MetadataRecordSizeRange -> [Char]
$cshowList :: [MetadataRecordSizeRange] -> ShowS
showList :: [MetadataRecordSizeRange] -> ShowS
Show

-- | Append a 'ParseWarning' to the end of the currently accumulated warnings.
addParseWarning :: ParseWarning -> Parse ()
addParseWarning :: ParseWarning -> Parse ()
addParseWarning ParseWarning
pw = ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ReaderT Env (StateT ParseState (Except Error)) () -> Parse ())
-> ReaderT Env (StateT ParseState (Except Error)) () -> Parse ()
forall a b. (a -> b) -> a -> b
$ do
  ParseState
ps <- ReaderT Env (StateT ParseState (Except Error)) ParseState
forall s (m :: * -> *). MonadState s m => m s
get
  ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ParseState -> ReaderT Env (StateT ParseState (Except Error)) ())
-> ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall a b. (a -> b) -> a -> b
$! ParseState
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 :: ParseWarning -> Doc
ppParseWarning (InvalidMetadataRecordSize Int
len MetadataRecordSizeRange
range [[Char]]
cxt) =
  [Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
    [ Doc
"Invalid record size:" Doc -> Doc -> Doc
PP.<+> Int -> Doc
forall a. Pretty a => a -> Doc
PP.pPrint Int
len
    , Doc
expectedSizeMsg
    ] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
PP.text ([[Char]] -> [[Char]]
formatContext [[Char]]
cxt)
  where
    expectedSizeMsg :: PP.Doc
    expectedSizeMsg :: Doc
expectedSizeMsg =
      case MetadataRecordSizeRange
range of
        MetadataRecordSizeBetween Int
lb Int
ub ->
          Doc
"Expected size between" Doc -> Doc -> Doc
PP.<+> Int -> Doc
forall a. Pretty a => a -> Doc
PP.pPrint Int
lb
            Doc -> Doc -> Doc
PP.<+> Doc
"and" Doc -> Doc -> Doc
PP.<+> Int -> Doc
forall a. Pretty a => a -> Doc
PP.pPrint Int
ub
        MetadataRecordSizeIn [Int]
ns ->
          Doc
"Expected one of:" Doc -> Doc -> Doc
PP.<+> [Int] -> Doc
forall a. Pretty a => a -> Doc
PP.pPrint [Int]
ns
        MetadataRecordSizeAtLeast Int
lb ->
          Doc
"Expected size of" Doc -> Doc -> Doc
PP.<+> Int -> Doc
forall a. Pretty a => a -> Doc
PP.pPrint Int
lb Doc -> Doc -> Doc
PP.<+> Doc
"or greater"

-- | Pretty-print a group of 'ParseWarning's in a format suitable for
-- user-facing messages.
ppParseWarnings :: Seq.Seq ParseWarning -> PP.Doc
ppParseWarnings :: Seq ParseWarning -> Doc
ppParseWarnings Seq ParseWarning
warnings
  | Seq ParseWarning -> Bool
forall a. Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq ParseWarning
warnings
  = Doc
PP.empty
  | Bool
otherwise
  = [Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
      [Doc
"Encountered the following warnings during parsing:"] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
      (ParseWarning -> Doc) -> [ParseWarning] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map
        (\ParseWarning
warning ->
          Int -> Doc -> Doc
PP.nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.vcat [ParseWarning -> Doc
ppParseWarning ParseWarning
warning, Doc
""])
        (Seq ParseWarning -> [ParseWarning]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq ParseWarning
warnings) [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
      [Doc
supportMsg | (ParseWarning -> Bool) -> Seq ParseWarning -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ParseWarning -> Bool
isInvalidMetadataRecordSize Seq ParseWarning
warnings]
  where
    isInvalidMetadataRecordSize :: ParseWarning -> Bool
    isInvalidMetadataRecordSize :: ParseWarning -> Bool
isInvalidMetadataRecordSize (InvalidMetadataRecordSize {}) = Bool
True

    supportMsg :: PP.Doc
    supportMsg :: Doc
supportMsg =
      [Doc] -> Doc
PP.vcat
        [ Doc
"Are you sure you're using a supported version of LLVM/Clang?"
        , Doc
"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
                   { FinalizeEnv -> Env
parsedEnv :: Env
                   , FinalizeEnv -> ValueTable
parsedMdTable :: ValueTable
                   , FinalizeEnv -> ValueTable
parsedValueTable :: ValueTable
                   , FinalizeEnv -> FuncSymTabs
parsedFuncSymtabs :: FuncSymTabs
                   }

type FuncSymTabs = Map.Map Symbol ValueSymtab

newtype Finalize a = Finalize
  { forall a. Finalize a -> ReaderT FinalizeEnv (Except Error) a
unFinalize :: ReaderT FinalizeEnv (Except Error) a
  } deriving ((forall a b. (a -> b) -> Finalize a -> Finalize b)
-> (forall a b. a -> Finalize b -> Finalize a) -> Functor Finalize
forall a b. a -> Finalize b -> Finalize a
forall a b. (a -> b) -> Finalize a -> Finalize b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Finalize a -> Finalize b
fmap :: forall a b. (a -> b) -> Finalize a -> Finalize b
$c<$ :: forall a b. a -> Finalize b -> Finalize a
<$ :: forall a b. a -> Finalize b -> Finalize a
Functor, Functor Finalize
Functor Finalize =>
(forall a. a -> Finalize a)
-> (forall a b. Finalize (a -> b) -> Finalize a -> Finalize b)
-> (forall a b c.
    (a -> b -> c) -> Finalize a -> Finalize b -> Finalize c)
-> (forall a b. Finalize a -> Finalize b -> Finalize b)
-> (forall a b. Finalize a -> Finalize b -> Finalize a)
-> Applicative Finalize
forall a. a -> Finalize a
forall a b. Finalize a -> Finalize b -> Finalize a
forall a b. Finalize a -> Finalize b -> Finalize b
forall a b. Finalize (a -> b) -> Finalize a -> Finalize b
forall a b c.
(a -> b -> c) -> Finalize a -> Finalize b -> Finalize c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Finalize a
pure :: forall a. a -> Finalize a
$c<*> :: forall a b. Finalize (a -> b) -> Finalize a -> Finalize b
<*> :: forall a b. Finalize (a -> b) -> Finalize a -> Finalize b
$cliftA2 :: forall a b c.
(a -> b -> c) -> Finalize a -> Finalize b -> Finalize c
liftA2 :: forall a b c.
(a -> b -> c) -> Finalize a -> Finalize b -> Finalize c
$c*> :: forall a b. Finalize a -> Finalize b -> Finalize b
*> :: forall a b. Finalize a -> Finalize b -> Finalize b
$c<* :: forall a b. Finalize a -> Finalize b -> Finalize a
<* :: forall a b. Finalize a -> Finalize b -> Finalize a
Applicative, MonadReader FinalizeEnv)

instance Monad Finalize where
#if !MIN_VERSION_base(4,11,0)
  {-# INLINE return #-}
  return = pure
#endif

  {-# INLINE (>>=) #-}
  Finalize ReaderT FinalizeEnv (Except Error) a
m >>= :: forall a b. Finalize a -> (a -> Finalize b) -> Finalize b
>>= a -> Finalize b
f = ReaderT FinalizeEnv (Except Error) b -> Finalize b
forall a. ReaderT FinalizeEnv (Except Error) a -> Finalize a
Finalize (ReaderT FinalizeEnv (Except Error) a
m ReaderT FinalizeEnv (Except Error) a
-> (a -> ReaderT FinalizeEnv (Except Error) b)
-> ReaderT FinalizeEnv (Except Error) b
forall a b.
ReaderT FinalizeEnv (Except Error) a
-> (a -> ReaderT FinalizeEnv (Except Error) b)
-> ReaderT FinalizeEnv (Except Error) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Finalize b -> ReaderT FinalizeEnv (Except Error) b
forall a. Finalize a -> ReaderT FinalizeEnv (Except Error) a
unFinalize (Finalize b -> ReaderT FinalizeEnv (Except Error) b)
-> (a -> Finalize b) -> a -> ReaderT FinalizeEnv (Except Error) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Finalize b
f)

#if !MIN_VERSION_base(4,13,0)
  {-# INLINE fail #-}
  fail = failWithContext'
#endif

instance MonadFail Finalize where
  {-# INLINE fail #-}
  fail :: forall a. [Char] -> Finalize a
fail = [Char] -> Finalize a
forall a. [Char] -> Finalize a
failWithContext'

instance Alternative Finalize where
  {-# INLINE empty #-}
  empty :: forall a. Finalize a
empty = [Char] -> Finalize a
forall a. [Char] -> Finalize a
failWithContext' [Char]
"empty"

  {-# INLINE (<|>) #-}
  Finalize a
a <|> :: forall a. Finalize a -> Finalize a -> Finalize a
<|> Finalize a
b = ReaderT FinalizeEnv (Except Error) a -> Finalize a
forall a. ReaderT FinalizeEnv (Except Error) a -> Finalize a
Finalize (ReaderT FinalizeEnv (Except Error) a -> Finalize a)
-> ReaderT FinalizeEnv (Except Error) a -> Finalize a
forall a b. (a -> b) -> a -> b
$ ReaderT FinalizeEnv (Except Error) a
-> (Error -> ReaderT FinalizeEnv (Except Error) a)
-> ReaderT FinalizeEnv (Except Error) a
forall a.
ReaderT FinalizeEnv (Except Error) a
-> (Error -> ReaderT FinalizeEnv (Except Error) a)
-> ReaderT FinalizeEnv (Except Error) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Finalize a -> ReaderT FinalizeEnv (Except Error) a
forall a. Finalize a -> ReaderT FinalizeEnv (Except Error) a
unFinalize Finalize a
a) (ReaderT FinalizeEnv (Except Error) a
-> Error -> ReaderT FinalizeEnv (Except Error) a
forall a b. a -> b -> a
const (Finalize a -> ReaderT FinalizeEnv (Except Error) a
forall a. Finalize a -> ReaderT FinalizeEnv (Except Error) a
unFinalize Finalize a
b))

instance MonadPlus Finalize where
  {-# INLINE mzero #-}
  mzero :: forall a. Finalize a
mzero = [Char] -> Finalize a
forall a. [Char] -> Finalize a
failWithContext' [Char]
"mzero"

  {-# INLINE mplus #-}
  mplus :: forall a. Finalize a -> Finalize a -> Finalize a
mplus = Finalize a -> Finalize a -> Finalize a
forall a. Finalize a -> Finalize a -> Finalize a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)

instance HasParseEnv Finalize where
  getContext :: Finalize [[Char]]
getContext = (FinalizeEnv -> [[Char]]) -> Finalize [[Char]]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((FinalizeEnv -> [[Char]]) -> Finalize [[Char]])
-> (FinalizeEnv -> [[Char]]) -> Finalize [[Char]]
forall a b. (a -> b) -> a -> b
$ Env -> [[Char]]
envContext (Env -> [[Char]])
-> (FinalizeEnv -> Env) -> FinalizeEnv -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FinalizeEnv -> Env
parsedEnv
  getValueSymtab :: Finalize ValueSymtab
getValueSymtab = (FinalizeEnv -> ValueSymtab) -> Finalize ValueSymtab
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((FinalizeEnv -> ValueSymtab) -> Finalize ValueSymtab)
-> (FinalizeEnv -> ValueSymtab) -> Finalize ValueSymtab
forall a b. (a -> b) -> a -> b
$ Symtab -> ValueSymtab
symValueSymtab (Symtab -> ValueSymtab)
-> (FinalizeEnv -> Symtab) -> FinalizeEnv -> ValueSymtab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Symtab
envSymtab (Env -> Symtab) -> (FinalizeEnv -> Env) -> FinalizeEnv -> Symtab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FinalizeEnv -> Env
parsedEnv

instance HasMdTable Finalize where
  getMdTable :: Finalize ValueTable
getMdTable = (FinalizeEnv -> ValueTable) -> Finalize ValueTable
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks FinalizeEnv -> ValueTable
parsedMdTable

instance HasValueTable Finalize where
  getValueTable :: Finalize ValueTable
getValueTable = (FinalizeEnv -> ValueTable) -> Finalize ValueTable
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks FinalizeEnv -> ValueTable
parsedValueTable

-- | Fail, taking into account the current context.
failWithContext' :: String -> Finalize a
failWithContext' :: forall a. [Char] -> Finalize a
failWithContext' [Char]
msg =
  ReaderT FinalizeEnv (Except Error) a -> Finalize a
forall a. ReaderT FinalizeEnv (Except Error) a -> Finalize a
Finalize (ReaderT FinalizeEnv (Except Error) a -> Finalize a)
-> ReaderT FinalizeEnv (Except Error) a -> Finalize a
forall a b. (a -> b) -> a -> b
$
  do Env
env <- (FinalizeEnv -> Env) -> ReaderT FinalizeEnv (Except Error) Env
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks FinalizeEnv -> Env
parsedEnv
     Error -> ReaderT FinalizeEnv (Except Error) a
forall a. Error -> ReaderT FinalizeEnv (Except Error) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
       { errMessage :: [Char]
errMessage = [Char]
msg
       , errContext :: [[Char]]
errContext = Env -> [[Char]]
envContext Env
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 :: forall a. FuncSymTabs -> Finalize a -> Parse a
liftFinalize FuncSymTabs
defs (Finalize ReaderT FinalizeEnv (Except Error) a
m) =
  do Env
env <- Parse Env
forall r (m :: * -> *). MonadReader r m => m r
ask
     ValueTable
mdt <- Parse ValueTable
forall (m :: * -> *). HasMdTable m => m ValueTable
getMdTable
     ValueTable
valt <- Parse ValueTable
forall (m :: * -> *). HasValueTable m => m ValueTable
getValueTable
     let fenv :: FinalizeEnv
fenv = FinalizeEnv { parsedEnv :: Env
parsedEnv = Env
env
                            , parsedMdTable :: ValueTable
parsedMdTable = ValueTable
mdt
                            , parsedValueTable :: ValueTable
parsedValueTable = ValueTable
valt
                            , parsedFuncSymtabs :: FuncSymTabs
parsedFuncSymtabs = FuncSymTabs
defs
                            }
     case Except Error a -> Either Error a
forall e a. Except e a -> Either e a
runExcept (ReaderT FinalizeEnv (Except Error) a
-> FinalizeEnv -> Except Error a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT FinalizeEnv (Except Error) a
m FinalizeEnv
fenv) of
       Left Error
err -> Error -> Parse a
forall a. Error -> Parse a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
err
       Right a
a -> a -> Parse a
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a