{-# LANGUAGE MultiWayIf #-}
module Data.LLVM.BitCode.Record where
import Data.LLVM.BitCode.Bitstream
import Data.LLVM.BitCode.BitString hiding (drop,take)
import Data.LLVM.BitCode.Match
import Data.LLVM.BitCode.Parse
import Text.LLVM.AST
import Data.Bits (Bits,testBit,shiftR,bit)
import Data.Int (Int64)
import Data.Word (Word8,Word32,Word64)
import Data.ByteString (ByteString)
import qualified Codec.Binary.UTF8.String as UTF8 (decode)
import Control.Monad ((<=<),MonadPlus(..))
data Record = Record
{ Record -> Int
recordCode :: !Int
, Record -> [Field]
recordFields :: [Field]
} deriving (Int -> Record -> ShowS
[Record] -> ShowS
Record -> String
(Int -> Record -> ShowS)
-> (Record -> String) -> ([Record] -> ShowS) -> Show Record
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Record -> ShowS
showsPrec :: Int -> Record -> ShowS
$cshow :: Record -> String
show :: Record -> String
$cshowList :: [Record] -> ShowS
showList :: [Record] -> ShowS
Show)
fromEntry :: Match Entry Record
fromEntry :: Match Entry Record
fromEntry = (Match UnabbrevRecord Record
fromUnabbrev Match UnabbrevRecord Record
-> (Entry -> Maybe UnabbrevRecord) -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Entry -> Maybe UnabbrevRecord
unabbrev) Match Entry Record -> Match Entry Record -> Match Entry Record
forall a b. Match a b -> Match a b -> Match a b
||| (Match AbbrevRecord Record
fromAbbrev Match AbbrevRecord Record
-> (Entry -> Maybe AbbrevRecord) -> Match Entry Record
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Entry -> Maybe AbbrevRecord
abbrev)
fromUnabbrev :: Match UnabbrevRecord Record
fromUnabbrev :: Match UnabbrevRecord Record
fromUnabbrev UnabbrevRecord
u = Record -> Maybe Record
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Record
{ recordCode :: Int
recordCode = UnabbrevRecord -> Int
unabbrevCode UnabbrevRecord
u
, recordFields :: [Field]
recordFields = (BitString -> Field) -> [BitString] -> [Field]
forall a b. (a -> b) -> [a] -> [b]
map BitString -> Field
FieldLiteral (UnabbrevRecord -> [BitString]
unabbrevOps UnabbrevRecord
u)
}
fromAbbrev :: Match AbbrevRecord Record
fromAbbrev :: Match AbbrevRecord Record
fromAbbrev AbbrevRecord
a = do
(Field
f:[Field]
fs) <- [Field] -> Maybe [Field]
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Field] -> Maybe [Field]) -> [Field] -> Maybe [Field]
forall a b. (a -> b) -> a -> b
$ AbbrevRecord -> [Field]
abbrevFields AbbrevRecord
a
Int
code <- Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric Field
f
Record -> Maybe Record
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Record
{ recordCode :: Int
recordCode = Int
code
, recordFields :: [Field]
recordFields = [Field]
fs
}
hasRecordCode :: Int -> Match Record Record
hasRecordCode :: Int -> Record -> Maybe Record
hasRecordCode Int
c Record
r | Record -> Int
recordCode Record
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
c = Record -> Maybe Record
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Record
r
| Bool
otherwise = Maybe Record
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
fieldAt :: Int -> Match Record Field
fieldAt :: Int -> Match Record Field
fieldAt Int
n = Int -> Match [Field] Field
forall a. Int -> Match [a] a
index Int
n Match [Field] Field -> (Record -> [Field]) -> Match Record Field
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Record -> [Field]
recordFields
fieldLiteral :: Match Field BitString
fieldLiteral :: Match Field BitString
fieldLiteral (FieldLiteral BitString
bs) = BitString -> Maybe BitString
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return BitString
bs
fieldLiteral Field
_ = Maybe BitString
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
fieldFixed :: Match Field BitString
fieldFixed :: Match Field BitString
fieldFixed (FieldFixed BitString
bs) = BitString -> Maybe BitString
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return BitString
bs
fieldFixed Field
_ = Maybe BitString
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
fieldVbr :: Match Field BitString
fieldVbr :: Match Field BitString
fieldVbr (FieldVBR BitString
bs) = BitString -> Maybe BitString
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return BitString
bs
fieldVbr Field
_ = Maybe BitString
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
fieldChar6 :: Match Field Word8
fieldChar6 :: Match Field Word8
fieldChar6 (FieldChar6 Word8
c) = Word8 -> Maybe Word8
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
c
fieldChar6 Field
_ = Maybe Word8
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
fieldArray :: Match Field a -> Match Field [a]
fieldArray :: forall a. Match Field a -> Match Field [a]
fieldArray Match Field a
p (FieldArray [Field]
fs) = Match Field a -> [Field] -> Maybe [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Match Field a
p [Field]
fs
fieldArray Match Field a
_ Field
_ = Maybe [a]
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
fieldBlob :: Match Field ByteString
fieldBlob :: Match Field ByteString
fieldBlob (FieldBlob ByteString
bs) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs
fieldBlob Field
_ = Maybe ByteString
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
type LookupField a = Int -> Match Field a -> Parse a
flattenRecord :: Record -> Record
flattenRecord :: Record -> Record
flattenRecord Record
r = Record
r { recordFields = concatMap flatten (recordFields r) }
where
flatten :: Field -> [Field]
flatten (FieldArray [Field]
as) = [Field]
as
flatten Field
f = [Field
f]
parseField :: Record -> LookupField a
parseField :: forall a. Record -> LookupField a
parseField Record
r Int
n Match Field a
p = case (Match Field a
p Match Field a -> Match Record Field -> Record -> Maybe a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Int -> Match Record Field
fieldAt Int
n) Record
r of
Just a
a -> a -> Parse a
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Maybe a
Nothing -> String -> Parse a
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parse a) -> String -> Parse a
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[ String
"parseField: unable to parse record field", Int -> String
forall a. Show a => a -> String
show Int
n, String
"of record", Record -> String
forall a. Show a => a -> String
show Record
r ]
parseFields :: Record -> Int -> Match Field a -> Parse [a]
parseFields :: forall a. Record -> Int -> Match Field a -> Parse [a]
parseFields Record
r Int
n = Record -> Int -> Int -> Match Field a -> Parse [a]
forall a. Record -> Int -> Int -> Match Field a -> Parse [a]
parseSlice Record
r Int
n ([Field] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Record -> [Field]
recordFields Record
r))
parseSlice :: Record -> Int -> Int -> Match Field a -> Parse [a]
parseSlice :: forall a. Record -> Int -> Int -> Match Field a -> Parse [a]
parseSlice Record
r Int
l Int
n Match Field a
p = [Field] -> Parse [a]
forall {f :: * -> *}. MonadFail f => [Field] -> f [a]
loop (Int -> [Field] -> [Field]
forall a. Int -> [a] -> [a]
take Int
n (Int -> [Field] -> [Field]
forall a. Int -> [a] -> [a]
drop Int
l (Record -> [Field]
recordFields Record
r)))
where
loop :: [Field] -> f [a]
loop (Field
f:[Field]
fs) = do
case Match Field a
p Field
f of
Just a
a -> (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> f [a] -> f [a]
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [Field] -> f [a]
loop [Field]
fs
Maybe a
Nothing -> String -> f [a]
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f [a]) -> String -> f [a]
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
[String
"parseSlice: unable to parse record field", Int -> String
forall a. Show a => a -> String
show Int
n, String
"of record", Record -> String
forall a. Show a => a -> String
show Record
r]
loop [] = [a] -> f [a]
forall a. a -> f a
forall (m :: * -> *) a. Monad m => a -> m a
return []
numeric :: (Num a, Bits a) => Match Field a
numeric :: forall a. (Num a, Bits a) => Match Field a
numeric = (BitString -> a) -> Maybe BitString -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BitString -> a
forall a. (Num a, Bits a) => BitString -> a
fromBitString (Maybe BitString -> Maybe a)
-> Match Field BitString -> Field -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Match Field BitString
fieldLiteral Match Field BitString
-> Match Field BitString -> Match Field BitString
forall a b. Match a b -> Match a b -> Match a b
||| Match Field BitString
fieldFixed Match Field BitString
-> Match Field BitString -> Match Field BitString
forall a b. Match a b -> Match a b -> Match a b
||| Match Field BitString
fieldVbr)
signedImpl :: (Bits a, Num a) => Match Field a
signedImpl :: forall a. (Bits a, Num a) => Match Field a
signedImpl = (BitString -> a) -> Maybe BitString -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BitString -> a
forall a. (Num a, Bits a) => BitString -> a
decode (Maybe BitString -> Maybe a)
-> Match Field BitString -> Field -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Match Field BitString
fieldLiteral Match Field BitString
-> Match Field BitString -> Match Field BitString
forall a b. Match a b -> Match a b -> Match a b
||| Match Field BitString
fieldFixed Match Field BitString
-> Match Field BitString -> Match Field BitString
forall a b. Match a b -> Match a b -> Match a b
||| Match Field BitString
fieldVbr)
where
decode :: BitString -> a
decode BitString
bs
| Bool -> Bool
not (a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a
n Int
0) = a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
| a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
1 = a -> a
forall a. Num a => a -> a
negate (a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
| Bool
otherwise = Int -> a
forall a. Bits a => Int -> a
bit Int
63
where
n :: a
n = BitString -> a
forall a. (Num a, Bits a) => BitString -> a
fromBitString BitString
bs
signedWord64 :: Match Field Word64
signedWord64 :: Match Field Word64
signedWord64 = Match Field Word64
forall a. (Bits a, Num a) => Match Field a
signedImpl
signedInt64 :: Match Field Int64
signedInt64 :: Match Field Int64
signedInt64 = Match Field Int64
forall a. (Bits a, Num a) => Match Field a
signedImpl
unsigned :: Match Field Word32
unsigned :: Match Field Word32
unsigned = Match Field Word32
forall a. (Num a, Bits a) => Match Field a
numeric
boolean :: Match Field Bool
boolean :: Match Field Bool
boolean = BitString -> Maybe Bool
forall {m :: * -> *}. MonadPlus m => BitString -> m Bool
decode (BitString -> Maybe Bool)
-> Match Field BitString -> Match Field Bool
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Match Field BitString
fieldFixed Match Field BitString
-> Match Field BitString -> Match Field BitString
forall a b. Match a b -> Match a b -> Match a b
||| Match Field BitString
fieldLiteral Match Field BitString
-> Match Field BitString -> Match Field BitString
forall a b. Match a b -> Match a b -> Match a b
||| Match Field BitString
fieldVbr)
where
decode :: BitString -> m Bool
decode BitString
bs = case BitString -> Int
bitStringValue BitString
bs of
Int
0 -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Int
1 -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Int
_ -> m Bool
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
nonzero :: Match Field Bool
nonzero :: Match Field Bool
nonzero = BitString -> Maybe Bool
forall {m :: * -> *}. Monad m => BitString -> m Bool
decode (BitString -> Maybe Bool)
-> Match Field BitString -> Match Field Bool
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (Match Field BitString
fieldFixed Match Field BitString
-> Match Field BitString -> Match Field BitString
forall a b. Match a b -> Match a b -> Match a b
||| Match Field BitString
fieldLiteral Match Field BitString
-> Match Field BitString -> Match Field BitString
forall a b. Match a b -> Match a b -> Match a b
||| Match Field BitString
fieldVbr)
where
decode :: BitString -> m Bool
decode BitString
bs = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ case BitString -> Int
bitStringValue BitString
bs of
Int
0 -> Bool
False
Int
_ -> Bool
True
char :: Match Field Word8
char :: Match Field Word8
char = Match Field Word8
forall a. (Num a, Bits a) => Match Field a
numeric
string :: Match Field String
string :: Match Field String
string = ([Word8] -> String) -> Maybe [Word8] -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word8] -> String
UTF8.decode (Maybe [Word8] -> Maybe String)
-> (Field -> Maybe [Word8]) -> Match Field String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match Field Word8 -> Field -> Maybe [Word8]
forall a. Match Field a -> Match Field [a]
fieldArray Match Field Word8
char
cstring :: Match Field String
cstring :: Match Field String
cstring = ([Word8] -> String) -> Maybe [Word8] -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word8] -> String
UTF8.decode (Maybe [Word8] -> Maybe String)
-> (Field -> Maybe [Word8]) -> Match Field String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match Field Word8 -> Field -> Maybe [Word8]
forall a. Match Field a -> Match Field [a]
fieldArray (Match Field Word8
fieldChar6 Match Field Word8 -> Match Field Word8 -> Match Field Word8
forall a b. Match a b -> Match a b -> Match a b
||| Match Field Word8
char)
oldOrStrtabName :: Int -> Record -> Parse (Symbol, Int)
oldOrStrtabName :: Int -> Record -> Parse (Symbol, Int)
oldOrStrtabName Int
n Record
r = do
Int
v <- Parse Int
getModVersion
if | Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 -> do
String
name <- Int -> Parse String
entryName Int
n
(Symbol, Int) -> Parse (Symbol, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Symbol
Symbol String
name, Int
0)
| Bool
otherwise -> do
Maybe StringTable
mst <- Parse (Maybe StringTable)
getStringTable
case Maybe StringTable
mst of
Just StringTable
st -> do
Int
offset <- Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
0 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
Int
len <- Record -> LookupField Int
forall a. Record -> LookupField a
parseField Record
r Int
1 Match Field Int
forall a. (Num a, Bits a) => Match Field a
numeric
(Symbol, Int) -> Parse (Symbol, Int)
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return (StringTable -> Int -> Int -> Symbol
resolveStrtabSymbol StringTable
st Int
offset Int
len, Int
2)
Maybe StringTable
Nothing -> String -> Parse (Symbol, Int)
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"New-style name encountered with no string table."