{-# LANGUAGE ViewPatterns #-}
module Data.LLVM.BitCode.IR.Values (
getValueTypePair
, getValue
, getFnValueById, getFnValueById'
, parseValueSymbolTableBlock
) where
import Data.LLVM.BitCode.Bitstream
import Data.LLVM.BitCode.Match
import Data.LLVM.BitCode.Parse
import Data.LLVM.BitCode.Record
import Text.LLVM.AST
import Control.Monad ((<=<),foldM)
getValueTypePair :: ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair :: ValueTable -> Record -> Int -> Parse (Typed PValue, Int)
getValueTypePair ValueTable
t Record
r Int
ix = do
let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
Int
n <- Int -> Parse Int
adjustId (Int -> Parse Int) -> Parse Int -> Parse Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field Int
ix Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
Maybe (Typed PValue)
mb <- Int -> Parse (Maybe (Typed PValue))
lookupValueAbs Int
n
case Maybe (Typed PValue)
mb of
Just Typed PValue
tv -> (Typed PValue, Int) -> Parse (Typed PValue, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed PValue
tv, Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
Maybe (Typed PValue)
Nothing -> do
Type
ty <- Int -> Parse Type
getType (Int -> Parse Type) -> Parse Int -> Parse Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LookupField Int
forall {a}. LookupField a
field (Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
[String]
cxt <- Parse [String]
getContext
let ref :: Typed PValue
ref = HasCallStack => [String] -> Int -> ValueTable -> Typed PValue
[String] -> Int -> ValueTable -> Typed PValue
forwardRef [String]
cxt Int
n ValueTable
t
(Typed PValue, Int) -> Parse (Typed PValue, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Typed PValue -> PValue
forall a. Typed a -> a
typedValue Typed PValue
ref), Int
ixInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)
getFnValueById :: Type -> Int -> Parse (Typed PValue)
getFnValueById :: Type -> Int -> Parse (Typed PValue)
getFnValueById = Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)
getFnValueById' Maybe ValueTable
forall a. Maybe a
Nothing
getValue :: ValueTable -> Type -> Int -> Parse (Typed PValue)
getValue :: ValueTable -> Type -> Int -> Parse (Typed PValue)
getValue ValueTable
vt Type
ty Int
n = String -> Parse (Typed PValue) -> Parse (Typed PValue)
forall a. String -> Parse a -> Parse a
label String
"getValue" (Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)
getFnValueById' (ValueTable -> Maybe ValueTable
forall a. a -> Maybe a
Just ValueTable
vt) Type
ty (Int -> Parse (Typed PValue)) -> Parse Int -> Parse (Typed PValue)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Parse Int
adjustId Int
n)
getFnValueById' :: Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)
getFnValueById' :: Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)
getFnValueById' Maybe ValueTable
mbVt Type
ty Int
n = String -> Parse (Typed PValue) -> Parse (Typed PValue)
forall a. String -> Parse a -> Parse a
label String
"getFnValueById'" (Parse (Typed PValue) -> Parse (Typed PValue))
-> Parse (Typed PValue) -> Parse (Typed PValue)
forall a b. (a -> b) -> a -> b
$ case Type
ty of
PrimType PrimType
Metadata -> do
[String]
cxt <- Parse [String]
getContext
ValueTable
md <- Parse ValueTable
getMdTable
Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => [String] -> Int -> ValueTable -> Typed PValue
[String] -> Int -> ValueTable -> Typed PValue
forwardRef [String]
cxt Int
n ValueTable
md)
Type
_ -> do
Maybe (Typed PValue)
mb <- Int -> Parse (Maybe (Typed PValue))
lookupValueAbs 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 -> do
Maybe String
mbName <- Int -> Parse (Maybe String)
entryNameMb Int
n
case Maybe String
mbName of
Just String
name -> Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> PValue -> Typed PValue
forall a. Type -> a -> Typed a
Typed Type
ty (Ident -> PValue
forall lab. Ident -> Value' lab
ValIdent (String -> Ident
Ident String
name)))
Maybe String
Nothing
| Just ValueTable
vt <- Maybe ValueTable
mbVt ->
do [String]
cxt <- Parse [String]
getContext
Typed PValue -> Parse (Typed PValue)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (HasCallStack => [String] -> Int -> ValueTable -> Typed PValue
[String] -> Int -> ValueTable -> Typed PValue
forwardRef [String]
cxt Int
n ValueTable
vt)
| Bool
otherwise ->
String -> Parse (Typed PValue)
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to create forward reference"
vstCodeEntry :: Match Entry Record
vstCodeEntry :: Match Entry Record
vstCodeEntry = Int -> Match Record Record
hasRecordCode Int
1 Match Record Record -> Match Entry Record -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Match Entry Record
fromEntry
vstCodeBBEntry :: Match Entry Record
vstCodeBBEntry :: Match Entry Record
vstCodeBBEntry = Int -> Match Record Record
hasRecordCode Int
2 Match Record Record -> Match Entry Record -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Match Entry Record
fromEntry
vstCodeFNEntry :: Match Entry Record
vstCodeFNEntry :: Match Entry Record
vstCodeFNEntry = Int -> Match Record Record
hasRecordCode Int
3 Match Record Record -> Match Entry Record -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Match Entry Record
fromEntry
parseValueSymbolTableBlock :: [Entry] -> Parse ValueSymtab
parseValueSymbolTableBlock :: [Entry] -> Parse ValueSymtab
parseValueSymbolTableBlock = (ValueSymtab -> Entry -> Parse ValueSymtab)
-> ValueSymtab -> [Entry] -> Parse ValueSymtab
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ValueSymtab -> Entry -> Parse ValueSymtab
parseValueSymbolTableBlockEntry ValueSymtab
forall a. Monoid a => a
mempty
parseValueSymbolTableBlockEntry :: ValueSymtab -> Entry -> Parse ValueSymtab
parseValueSymbolTableBlockEntry :: ValueSymtab -> Entry -> Parse ValueSymtab
parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry Record
vstCodeEntry -> Just Record
r) = do
let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
Int
valid <- LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
String
name <- LookupField String
forall {a}. LookupField a
field Int
1 Match Field String
cstring
ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> ValueSymtab -> ValueSymtab
addEntry Int
valid String
name ValueSymtab
vs)
parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry Record
vstCodeBBEntry -> Just Record
r) = do
let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
Int
bbid <- LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
String
name <- LookupField String
forall {a}. LookupField a
field Int
1 Match Field String
cstring
ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> String -> ValueSymtab -> ValueSymtab
addBBEntry Int
bbid String
name ValueSymtab
vs)
parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry Record
vstCodeFNEntry -> Just Record
r) = do
let field :: LookupField a
field = Record -> LookupField a
forall a. Record -> LookupField a
parseField Record
r
Int
valid <- LookupField Int
forall {a}. LookupField a
field Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
Int
offset <- LookupField Int
forall {a}. LookupField a
field Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
case [Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r) of
Int
2 -> ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> ValueSymtab -> ValueSymtab
addFwdFNEntry Int
valid Int
offset ValueSymtab
vs)
Int
3 -> do
String
name <- LookupField String
forall {a}. LookupField a
field Int
2 Match Field String
cstring
ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> String -> ValueSymtab -> ValueSymtab
addFNEntry Int
valid Int
offset String
name ValueSymtab
vs)
Int
_ -> String -> Parse ValueSymtab
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected number of parameters to FNENTRY"
parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry DefineAbbrev
abbrevDef -> Just DefineAbbrev
_) =
ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ValueSymtab
vs
parseValueSymbolTableBlockEntry ValueSymtab
vs (Match Entry Block
block -> Just Block
_) =
ValueSymtab -> Parse ValueSymtab
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ValueSymtab
vs
parseValueSymbolTableBlockEntry ValueSymtab
_ Entry
e =
String -> Parse ValueSymtab
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"value symtab: unexpected entry: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Entry -> String
forall a. Show a => a -> String
show Entry
e)