{-# 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(..))


-- Generic Records -------------------------------------------------------------

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)

-- | Record construction from an unabbreviated record
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)
  }

-- | Record construction from an abbreviated field.
fromAbbrev :: Match AbbrevRecord Record
fromAbbrev :: Match AbbrevRecord Record
fromAbbrev AbbrevRecord
a = do
  -- If abbrevFields is empty here, it will cause the Match to fail with
  -- Nothing, at which point alternatives may then be tried.
  (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
    }

-- | Match the record with the given code.
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

-- | Get a field from a record
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

-- | Match a literal field.
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

-- | Match a fixed field.
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

-- | Match a vbr field.
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

-- | Match a character field.
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

-- | Match the array field.
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

-- | Match a blob field.
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

-- | Flatten arrays inside a record.
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]

-- | Parse a field from a record.
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 ]

-- | Parse all record fields starting from an index.
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))

-- | Parse out a sublist from a record
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 []

-- | Parse a @Field@ as a numeric value.
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 -- not really right, but it's what llvm does
    where
    n :: a
n = BitString -> a
forall a. (Num a, Bits a) => BitString -> a
fromBitString BitString
bs

-- | Parse a @Field@ as a sign-encoded number.
signedWord64 :: Match Field Word64
signedWord64 :: Match Field Word64
signedWord64 = Match Field Word64
forall a. (Bits a, Num a) => Match Field a
signedImpl

-- | Parse a @Field@ as a sign-encoded number.
signedInt64 :: Match Field Int64
signedInt64 :: Match Field Int64
signedInt64 = Match Field Int64
forall a. (Bits a, Num a) => Match Field a
signedImpl

-- | Parse a @Field@ as a Word32.
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)

-- | Lookup the name at the given field index if using an old bitcode
-- version, or in the string table if using a new bitcode version.
-- Returns the name and the offset into the record to use for further
-- queries.
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."