{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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
#endif
import Control.Monad.Fix (MonadFix)
import Control.Monad.Except (MonadError(..), Except, runExcept)
import Control.Monad.Reader (MonadReader(..), ReaderT(..))
import Control.Monad.State.Strict (MonadState(..), StateT(..))
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 Prelude
data Error = Error
{ Error -> [String]
errContext :: [String]
, Error -> String
errMessage :: String
} deriving (Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$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 -> String
formatError Error
err
| [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Error -> [String]
errContext Error
err) = Error -> String
errMessage Error
err
| Bool
otherwise = [String] -> String
unlines
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Error -> String
errMessage Error
err
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"from:"
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char
'\t' Char -> ShowS
forall a. a -> [a] -> [a]
:) (Error -> [String]
errContext Error
err)
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)
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. String -> Parse a
fail = String -> Parse a
forall a. String -> Parse a
failWithContext
instance Alternative Parse where
{-# INLINE empty #-}
empty :: forall a. Parse a
empty = String -> Parse a
forall a. String -> Parse a
failWithContext String
"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 = String -> Parse a
forall a. String -> Parse a
failWithContext String
"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
runParse :: forall a. Parse a -> Either Error a
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
forall a b. a -> Either a b
Left Error
err
Right (a
a, ParseState
_) -> a -> Either Error a
forall a b. b -> Either a b
Right a
a
notImplemented :: Parse a
notImplemented :: forall a. Parse a
notImplemented = String -> Parse a
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not implemented"
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 String
psTypeName :: Maybe String
, ParseState -> Int
psNextTypeId :: !Int
, ParseState -> Maybe PDebugLoc
psLastLoc :: Maybe PDebugLoc
, ParseState -> KindTable
psKinds :: !KindTable
, ParseState -> Int
psModVersion :: !Int
} deriving (Int -> ParseState -> ShowS
[ParseState] -> ShowS
ParseState -> String
(Int -> ParseState -> ShowS)
-> (ParseState -> String)
-> ([ParseState] -> ShowS)
-> Show ParseState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseState -> ShowS
showsPrec :: Int -> ParseState -> ShowS
$cshow :: ParseState -> String
show :: ParseState -> String
$cshowList :: [ParseState] -> ShowS
showList :: [ParseState] -> ShowS
Show)
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 String
psTypeName = Maybe String
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
}
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 :: Parse Bool
getRelIds :: Parse Bool
getRelIds = 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 Bool
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValueTable -> Bool
valueRelIds (ParseState -> ValueTable
psValueTable ParseState
ps))
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 -> String -> Parse PDebugLoc
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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)
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 TypeTable = IntMap.IntMap Type
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 ..]
data BadForwardRef
= BadTypeRef CallStack [String] String Int
| BadValueRef CallStack [String] String Int
deriving (Int -> BadForwardRef -> ShowS
[BadForwardRef] -> ShowS
BadForwardRef -> String
(Int -> BadForwardRef -> ShowS)
-> (BadForwardRef -> String)
-> ([BadForwardRef] -> ShowS)
-> Show BadForwardRef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BadForwardRef -> ShowS
showsPrec :: Int -> BadForwardRef -> ShowS
$cshow :: BadForwardRef -> String
show :: BadForwardRef -> String
$cshowList :: [BadForwardRef] -> ShowS
showList :: [BadForwardRef] -> ShowS
Show,Typeable)
instance X.Exception BadForwardRef
badRefError :: BadForwardRef -> Error
badRefError :: BadForwardRef -> Error
badRefError BadForwardRef
ref =
let (CallStack
stk, [String]
cxt, String
explanation, Int
i, String
thing) =
case BadForwardRef
ref of
BadTypeRef CallStack
stk' [String]
cxt' String
explanation' Int
i' -> (CallStack
stk', [String]
cxt', String
explanation', Int
i', String
"type")
BadValueRef CallStack
stk' [String]
cxt' String
explanation' Int
i' -> (CallStack
stk', [String]
cxt', String
explanation', Int
i', String
"value")
in [String] -> String -> Error
Error [String]
cxt (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"bad forward reference to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
thing String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
, String
"additional details: "
, String
explanation
, String
"with call stack: "
, CallStack -> String
prettyCallStack CallStack
stk
]
lookupTypeRef :: HasCallStack
=> [String] -> Int -> TypeTable -> Type
lookupTypeRef :: HasCallStack => [String] -> Int -> TypeTable -> Type' Ident
lookupTypeRef [String]
cxt Int
n =
let explanation :: String
explanation = String
"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 -> [String] -> String -> Int -> BadForwardRef
BadTypeRef CallStack
HasCallStack => CallStack
callStack [String]
cxt String
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 }
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
String
str <- case ParseState -> Maybe String
psTypeName ParseState
ps of
Just String
tn -> do
ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psTypeName = Nothing }
String -> ReaderT Env (StateT ParseState (Except Error)) String
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return String
tn
Maybe String
Nothing -> do
ParseState -> ReaderT Env (StateT ParseState (Except Error)) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ParseState
ps { psNextTypeId = psNextTypeId ps + 1 }
String -> ReaderT Env (StateT ParseState (Except Error)) String
forall a. a -> ReaderT Env (StateT ParseState (Except Error)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String
forall a. Show a => a -> String
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 (String -> Ident
Ident String
str)
setTypeName :: String -> Parse ()
setTypeName :: String -> Parse ()
setTypeName String
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 }
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)
(String -> Parse ()
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"type reference " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ref String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is too large"))
[String]
cxt <- Parse [String]
getContext
Type' Ident -> Parse (Type' Ident)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => [String] -> Int -> TypeTable -> Type' Ident
[String] -> Int -> TypeTable -> Type' Ident
lookupTypeRef [String]
cxt Int
ref (ParseState -> TypeTable
psTypeTable ParseState
ps))
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)
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 -> String
(Int -> ValueTable -> ShowS)
-> (ValueTable -> String)
-> ([ValueTable] -> ShowS)
-> Show ValueTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueTable -> ShowS
showsPrec :: Int -> ValueTable -> ShowS
$cshow :: ValueTable -> String
show :: ValueTable -> String
$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)
}
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)
nextValueId :: Parse Int
nextValueId :: Parse Int
nextValueId = ReaderT Env (StateT ParseState (Except Error)) Int -> Parse Int
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ValueTable -> Int
valueNextId (ValueTable -> Int)
-> (ParseState -> ValueTable) -> ParseState -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseState -> ValueTable
psValueTable (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)
adjustId :: Int -> Parse Int
adjustId :: Int -> Parse Int
adjustId Int
n = do
ValueTable
vt <- Parse 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)
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)
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)
lookupValueAbs :: Int -> Parse (Maybe (Typed PValue))
lookupValueAbs :: Int -> Parse (Maybe (Typed PValue))
lookupValueAbs Int
n = Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs 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
getValueTable
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
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
getValueTable
forwardRef :: HasCallStack
=> [String] -> Int -> ValueTable -> Typed PValue
forwardRef :: HasCallStack => [String] -> Int -> ValueTable -> Typed PValue
forwardRef [String]
cxt Int
n ValueTable
vt =
let explanation :: String
explanation = String
"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 -> [String] -> String -> Int -> BadForwardRef
BadValueRef CallStack
HasCallStack => CallStack
callStack [String]
cxt String
explanation Int
n)) (Int -> ValueTable -> Maybe (Typed PValue)
lookupValueTableAbs Int
n ValueTable
vt)
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 -> String -> Parse (Typed PValue)
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not defined")
getValueTable :: Parse ValueTable
getValueTable :: Parse ValueTable
getValueTable = ReaderT Env (StateT ParseState (Except Error)) ValueTable
-> Parse ValueTable
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> ValueTable
psValueTable (ParseState -> ValueTable)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) ValueTable
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)
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
getValueTable
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 }
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
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
getMdTable :: Parse MdTable
getMdTable :: Parse ValueTable
getMdTable = ReaderT Env (StateT ParseState (Except Error)) ValueTable
-> Parse ValueTable
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (ParseState -> ValueTable
psMdTable (ParseState -> ValueTable)
-> ReaderT Env (StateT ParseState (Except Error)) ParseState
-> ReaderT Env (StateT ParseState (Except Error)) ValueTable
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)
setMdTable :: MdTable -> Parse ()
setMdTable :: ValueTable -> Parse ()
setMdTable ValueTable
md = 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 { 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
_ -> String -> Parse (Typed PValMd)
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected non-metadata value in metadata table"
Maybe (Typed PValue)
Nothing -> String -> Parse (Typed PValMd)
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"metadata index " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ix String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" 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 }
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 String
protoSect :: Maybe String
, FunProto -> Maybe String
protoComdat :: Maybe String
} deriving Int -> FunProto -> ShowS
[FunProto] -> ShowS
FunProto -> String
(Int -> FunProto -> ShowS)
-> (FunProto -> String) -> ([FunProto] -> ShowS) -> Show FunProto
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FunProto -> ShowS
showsPrec :: Int -> FunProto -> ShowS
$cshow :: FunProto -> String
show :: FunProto -> String
$cshowList :: [FunProto] -> ShowS
showList :: [FunProto] -> ShowS
Show
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 }
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 -> String -> Parse FunProto
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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
data Env = Env
{ Env -> Symtab
envSymtab :: Symtab
, Env -> [String]
envContext :: [String]
} deriving Int -> Env -> ShowS
[Env] -> ShowS
Env -> String
(Int -> Env -> ShowS)
-> (Env -> String) -> ([Env] -> ShowS) -> Show Env
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Env -> ShowS
showsPrec :: Int -> Env -> ShowS
$cshow :: Env -> String
show :: Env -> String
$cshowList :: [Env] -> ShowS
showList :: [Env] -> ShowS
Show
emptyEnv :: Env
emptyEnv :: Env
emptyEnv = Env
{ envSymtab :: Symtab
envSymtab = Symtab
forall a. Monoid a => a
mempty
, envContext :: [String]
envContext = [String]
forall a. Monoid a => a
mempty
}
extendSymtab :: Symtab -> Env -> Env
extendSymtab :: Symtab -> Env -> Env
extendSymtab Symtab
symtab Env
env = Env
env { envSymtab = envSymtab env `mappend` symtab }
addLabel :: String -> Env -> Env
addLabel :: String -> Env -> Env
addLabel String
l Env
env = Env
env { envContext = l : envContext env }
getContext :: Parse [String]
getContext :: Parse [String]
getContext = ReaderT Env (StateT ParseState (Except Error)) [String]
-> Parse [String]
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (Env -> [String]
envContext (Env -> [String])
-> ReaderT Env (StateT ParseState (Except Error)) Env
-> ReaderT Env (StateT ParseState (Except Error)) [String]
forall a b.
(a -> b)
-> ReaderT Env (StateT ParseState (Except Error)) a
-> ReaderT Env (StateT ParseState (Except Error)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ReaderT Env (StateT ParseState (Except Error)) Env
forall r (m :: * -> *). MonadReader r m => m r
ask)
data Symtab = Symtab
{ Symtab -> ValueSymtab
symValueSymtab :: ValueSymtab
, Symtab -> TypeSymtab
symTypeSymtab :: TypeSymtab
} deriving (Int -> Symtab -> ShowS
[Symtab] -> ShowS
Symtab -> String
(Int -> Symtab -> ShowS)
-> (Symtab -> String) -> ([Symtab] -> ShowS) -> Show Symtab
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Symtab -> ShowS
showsPrec :: Int -> Symtab -> ShowS
$cshow :: Symtab -> String
show :: Symtab -> String
$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)
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 })
getValueSymtab :: Finalize ValueSymtab
getValueSymtab :: Finalize ValueSymtab
getValueSymtab = ReaderT Env (Except Error) ValueSymtab -> Finalize ValueSymtab
forall a. ReaderT Env (Except Error) a -> Finalize a
Finalize (Symtab -> ValueSymtab
symValueSymtab (Symtab -> ValueSymtab) -> (Env -> Symtab) -> Env -> ValueSymtab
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Symtab
envSymtab (Env -> ValueSymtab)
-> ReaderT Env (Except Error) Env
-> ReaderT Env (Except Error) ValueSymtab
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Env (Except Error) Env
forall r (m :: * -> *). MonadReader r m => m r
ask)
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 })
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 :: String -> Parse a -> Parse a
label :: forall a. String -> Parse a -> Parse a
label String
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 (String -> Env -> Env
addLabel String
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)
failWithContext :: String -> Parse a
failWithContext :: forall a. String -> Parse a
failWithContext String
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 :: String
errMessage = String
msg
, errContext :: [String]
errContext = Env -> [String]
envContext Env
env
}
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
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 -> String -> Parse Int
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unknown type alias " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
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)))
type SymName = Either String Int
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 -> String
(Int -> ValueSymtab -> ShowS)
-> (ValueSymtab -> String)
-> ([ValueSymtab] -> ShowS)
-> Show ValueSymtab
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueSymtab -> ShowS
showsPrec :: Int -> ValueSymtab -> ShowS
$cshow :: ValueSymtab -> String
show :: ValueSymtab -> String
$cshowList :: [ValueSymtab] -> ShowS
showList :: [ValueSymtab] -> ShowS
Show)
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 -> String
renderName = ShowS -> (Int -> String) -> SymName -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ShowS
forall a. a -> a
id Int -> String
forall a. Show a => a -> String
show
mkBlockLabel :: SymName -> BlockLabel
mkBlockLabel :: SymName -> BlockLabel
mkBlockLabel = (String -> BlockLabel)
-> (Int -> BlockLabel) -> SymName -> BlockLabel
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Ident -> BlockLabel
Named (Ident -> BlockLabel) -> (String -> Ident) -> String -> BlockLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
Ident) Int -> BlockLabel
Anon
emptyValueSymtab :: ValueSymtab
emptyValueSymtab :: ValueSymtab
emptyValueSymtab = ValueSymtab
forall a. Monoid a => a
mempty
addEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addEntry Int
i String
n ValueSymtab
t = ValueSymtab
t { valSymtab = IntMap.insert i (Left n) (valSymtab t) }
addBBEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addBBEntry :: Int -> String -> ValueSymtab -> ValueSymtab
addBBEntry Int
i String
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
addFNEntry :: Int -> Int -> String -> ValueSymtab -> ValueSymtab
addFNEntry Int
i Int
_o String
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) }
entryNameMb :: Int -> Parse (Maybe String)
entryNameMb :: Int -> Parse (Maybe String)
entryNameMb Int
n = do
ValueSymtab
symtab <- Finalize ValueSymtab -> Parse ValueSymtab
forall a. Finalize a -> Parse a
liftFinalize Finalize ValueSymtab
getValueSymtab
Maybe String -> Parse (Maybe String)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> Parse (Maybe String))
-> Maybe String -> Parse (Maybe String)
forall a b. (a -> b) -> a -> b
$! (SymName -> String) -> Maybe SymName -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymName -> String
renderName
(Maybe SymName -> Maybe String) -> Maybe SymName -> Maybe String
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)
entryName :: Int -> Parse String
entryName :: Int -> Parse String
entryName Int
n = do
Maybe String
mentry <- Int -> Parse (Maybe String)
entryNameMb Int
n
case Maybe String
mentry of
Just String
name -> String -> Parse String
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return String
name
Maybe String
Nothing ->
do Bool
isRel <- Parse Bool
getRelIds
ValueSymtab
symtab <- Finalize ValueSymtab -> Parse ValueSymtab
forall a. Finalize a -> Parse a
liftFinalize Finalize ValueSymtab
getValueSymtab
String -> Parse String
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parse String) -> String -> Parse String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
[ String
"entry " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Bool
isRel then String
" (relative)" else String
"")
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is missing from the symbol table"
, ValueSymtab -> String
forall a. Show a => a -> String
show ValueSymtab
symtab ]
bbEntryName :: Int -> Finalize (Maybe BlockLabel)
bbEntryName :: Int -> Finalize (Maybe BlockLabel)
bbEntryName Int
n = do
ValueSymtab
symtab <- Finalize ValueSymtab
getValueSymtab
Maybe BlockLabel -> Finalize (Maybe BlockLabel)
forall a. a -> Finalize a
forall (m :: * -> *) a. Monad m => a -> m a
return (SymName -> BlockLabel
mkBlockLabel (SymName -> BlockLabel) -> Maybe SymName -> Maybe BlockLabel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IntMap SymName -> Maybe SymName
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n (ValueSymtab -> IntMap SymName
bbSymtab ValueSymtab
symtab))
requireBbEntryName :: Int -> Finalize BlockLabel
requireBbEntryName :: Int -> Finalize BlockLabel
requireBbEntryName Int
n = do
Maybe BlockLabel
mb <- Int -> Finalize (Maybe BlockLabel)
bbEntryName 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 -> String -> Finalize BlockLabel
forall a. String -> Finalize a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"basic block " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" has no id")
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 -> String
(Int -> TypeSymtab -> ShowS)
-> (TypeSymtab -> String)
-> ([TypeSymtab] -> ShowS)
-> Show TypeSymtab
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TypeSymtab -> ShowS
showsPrec :: Int -> TypeSymtab -> ShowS
$cshow :: TypeSymtab -> String
show :: TypeSymtab -> String
$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)
}
data KindTable = KindTable
{ KindTable -> IntMap String
ktNames :: IntMap.IntMap String
} deriving (Int -> KindTable -> ShowS
[KindTable] -> ShowS
KindTable -> String
(Int -> KindTable -> ShowS)
-> (KindTable -> String)
-> ([KindTable] -> ShowS)
-> Show KindTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KindTable -> ShowS
showsPrec :: Int -> KindTable -> ShowS
$cshow :: KindTable -> String
show :: KindTable -> String
$cshowList :: [KindTable] -> ShowS
showList :: [KindTable] -> ShowS
Show)
emptyKindTable :: KindTable
emptyKindTable :: KindTable
emptyKindTable = KindTable
{ ktNames :: IntMap String
ktNames = [(Int, String)] -> IntMap String
forall a. [(Int, a)] -> IntMap a
IntMap.fromList
[ (Int
0, String
"dbg" )
, (Int
1, String
"tbaa" )
, (Int
2, String
"prof" )
, (Int
3, String
"fpmath")
, (Int
4, String
"range" )
]
}
addKind :: Int -> String -> Parse ()
addKind :: Int -> String -> Parse ()
addKind Int
kind String
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 String
ktNames :: KindTable -> IntMap String
ktNames :: IntMap String
.. } = 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 String
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 String
ktNames :: KindTable -> IntMap String
ktNames :: IntMap String
.. } = ParseState -> KindTable
psKinds ParseState
ps
case Int -> IntMap String -> Maybe String
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
kind IntMap String
ktNames of
Just String
name -> String -> Parse String
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return String
name
Maybe String
Nothing -> String -> Parse String
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown kind id: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
kind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nKind table: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ KindTable -> String
forall a. Show a => a -> String
show (ParseState -> KindTable
psKinds ParseState
ps))
newtype StringTable = Strtab BS.ByteString
deriving (Int -> StringTable -> ShowS
[StringTable] -> ShowS
StringTable -> String
(Int -> StringTable -> ShowS)
-> (StringTable -> String)
-> ([StringTable] -> ShowS)
-> Show StringTable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StringTable -> ShowS
showsPrec :: Int -> StringTable -> ShowS
$cshow :: StringTable -> String
show :: StringTable -> String
$cshowList :: [StringTable] -> ShowS
showList :: [StringTable] -> ShowS
Show)
mkStrtab :: BS.ByteString -> StringTable
mkStrtab :: ByteString -> StringTable
mkStrtab = ByteString -> StringTable
Strtab
resolveStrtabSymbol :: StringTable -> Int -> Int -> Symbol
resolveStrtabSymbol :: StringTable -> Int -> Int -> Symbol
resolveStrtabSymbol (Strtab ByteString
bs) Int
start Int
len =
String -> Symbol
Symbol (String -> Symbol) -> String -> Symbol
forall a b. (a -> b) -> a -> b
$ [Word8] -> String
UTF8.decode ([Word8] -> String) -> [Word8] -> String
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
newtype Finalize a = Finalize
{ forall a. Finalize a -> ReaderT Env (Except Error) a
unFinalize :: ReaderT Env (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)
instance Monad Finalize where
#if !MIN_VERSION_base(4,11,0)
{-# INLINE return #-}
return = pure
#endif
{-# INLINE (>>=) #-}
Finalize ReaderT Env (Except Error) a
m >>= :: forall a b. Finalize a -> (a -> Finalize b) -> Finalize b
>>= a -> Finalize b
f = ReaderT Env (Except Error) b -> Finalize b
forall a. ReaderT Env (Except Error) a -> Finalize a
Finalize (ReaderT Env (Except Error) a
m ReaderT Env (Except Error) a
-> (a -> ReaderT Env (Except Error) b)
-> ReaderT Env (Except Error) b
forall a b.
ReaderT Env (Except Error) a
-> (a -> ReaderT Env (Except Error) b)
-> ReaderT Env (Except Error) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Finalize b -> ReaderT Env (Except Error) b
forall a. Finalize a -> ReaderT Env (Except Error) a
unFinalize (Finalize b -> ReaderT Env (Except Error) b)
-> (a -> Finalize b) -> a -> ReaderT Env (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. String -> Finalize a
fail = String -> Finalize a
forall a. String -> Finalize a
failWithContext'
instance Alternative Finalize where
{-# INLINE empty #-}
empty :: forall a. Finalize a
empty = String -> Finalize a
forall a. String -> Finalize a
failWithContext' String
"empty"
{-# INLINE (<|>) #-}
Finalize a
a <|> :: forall a. Finalize a -> Finalize a -> Finalize a
<|> Finalize a
b = ReaderT Env (Except Error) a -> Finalize a
forall a. ReaderT Env (Except Error) a -> Finalize a
Finalize (ReaderT Env (Except Error) a -> Finalize a)
-> ReaderT Env (Except Error) a -> Finalize a
forall a b. (a -> b) -> a -> b
$ ReaderT Env (Except Error) a
-> (Error -> ReaderT Env (Except Error) a)
-> ReaderT Env (Except Error) a
forall a.
ReaderT Env (Except Error) a
-> (Error -> ReaderT Env (Except Error) a)
-> ReaderT Env (Except Error) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Finalize a -> ReaderT Env (Except Error) a
forall a. Finalize a -> ReaderT Env (Except Error) a
unFinalize Finalize a
a) (ReaderT Env (Except Error) a
-> Error -> ReaderT Env (Except Error) a
forall a b. a -> b -> a
const (Finalize a -> ReaderT Env (Except Error) a
forall a. Finalize a -> ReaderT Env (Except Error) a
unFinalize Finalize a
b))
instance MonadPlus Finalize where
{-# INLINE mzero #-}
mzero :: forall a. Finalize a
mzero = String -> Finalize a
forall a. String -> Finalize a
failWithContext' String
"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
(<|>)
failWithContext' :: String -> Finalize a
failWithContext' :: forall a. String -> Finalize a
failWithContext' String
msg =
ReaderT Env (Except Error) a -> Finalize a
forall a. ReaderT Env (Except Error) a -> Finalize a
Finalize (ReaderT Env (Except Error) a -> Finalize a)
-> ReaderT Env (Except Error) a -> Finalize a
forall a b. (a -> b) -> a -> b
$
do Env
env <- ReaderT Env (Except Error) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
Error -> ReaderT Env (Except Error) a
forall a. Error -> ReaderT Env (Except Error) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Error
{ errMessage :: String
errMessage = String
msg
, errContext :: [String]
errContext = Env -> [String]
envContext Env
env
}
liftFinalize :: Finalize a -> Parse a
liftFinalize :: forall a. Finalize a -> Parse a
liftFinalize (Finalize ReaderT Env (Except Error) a
m) =
do Env
env <- ReaderT Env (StateT ParseState (Except Error)) Env -> Parse Env
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse ReaderT Env (StateT ParseState (Except Error)) Env
forall r (m :: * -> *). MonadReader r m => m r
ask
case Except Error a -> Either Error a
forall e a. Except e a -> Either e a
runExcept (ReaderT Env (Except Error) a -> Env -> Except Error a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Env (Except Error) a
m Env
env) of
Left Error
err -> ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
forall a.
ReaderT Env (StateT ParseState (Except Error)) a -> Parse a
Parse (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
err)
Right a
a -> a -> Parse a
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a