{-# 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
{ recordCode :: !Int
, recordFields :: [Field]
} deriving (Show)
fromEntry :: Match Entry Record
fromEntry = (fromUnabbrev <=< unabbrev) ||| (fromAbbrev <=< abbrev)
-- | Record construction from an unabbreviated record
fromUnabbrev :: Match UnabbrevRecord Record
fromUnabbrev u = return Record
{ recordCode = unabbrevCode u
, recordFields = map FieldLiteral (unabbrevOps u)
}
-- | Record construction from an abbreviated field.
fromAbbrev :: Match AbbrevRecord Record
fromAbbrev a = do
-- If abbrevFields is empty here, it will cause the Match to fail with
-- Nothing, at which point alternatives may then be tried.
(f:fs) <- return $ abbrevFields a
code <- numeric f
return Record
{ recordCode = code
, recordFields = fs
}
-- | Match the record with the given code.
hasRecordCode :: Int -> Match Record Record
hasRecordCode c r | recordCode r == c = return r
| otherwise = mzero
-- | Get a field from a record
fieldAt :: Int -> Match Record Field
fieldAt n = index n . recordFields
-- | Match a literal field.
fieldLiteral :: Match Field BitString
fieldLiteral (FieldLiteral bs) = return bs
fieldLiteral _ = mzero
-- | Match a fixed field.
fieldFixed :: Match Field BitString
fieldFixed (FieldFixed bs) = return bs
fieldFixed _ = mzero
-- | Match a vbr field.
fieldVbr :: Match Field BitString
fieldVbr (FieldVBR bs) = return bs
fieldVbr _ = mzero
-- | Match a character field.
fieldChar6 :: Match Field Word8
fieldChar6 (FieldChar6 c) = return c
fieldChar6 _ = mzero
-- | Match the array field.
fieldArray :: Match Field a -> Match Field [a]
fieldArray p (FieldArray fs) = mapM p fs
fieldArray _ _ = mzero
-- | Match a blob field.
fieldBlob :: Match Field ByteString
fieldBlob (FieldBlob bs) = return bs
fieldBlob _ = mzero
type LookupField a = Int -> Match Field a -> Parse a
-- | Flatten arrays inside a record.
flattenRecord :: Record -> Record
flattenRecord r = r { recordFields = concatMap flatten (recordFields r) }
where
flatten (FieldArray as) = as
flatten f = [f]
-- | Parse a field from a record.
parseField :: Record -> LookupField a
parseField r n p = case (p <=< fieldAt n) r of
Just a -> return a
Nothing -> fail $ unwords
[ "parseField: unable to parse record field", show n, "of record", show r ]
-- | Parse all record fields starting from an index.
parseFields :: Record -> Int -> Match Field a -> Parse [a]
parseFields r n = parseSlice r n (length (recordFields r))
-- | Parse out a sublist from a record
parseSlice :: Record -> Int -> Int -> Match Field a -> Parse [a]
parseSlice r l n p = loop (take n (drop l (recordFields r)))
where
loop (f:fs) = do
case p f of
Just a -> (a:) `fmap` loop fs
Nothing -> fail $ unwords
["parseSlice: unable to parse record field", show n, "of record", show r]
loop [] = return []
-- | Parse a @Field@ as a numeric value.
numeric :: (Num a, Bits a) => Match Field a
numeric = fmap fromBitString . (fieldLiteral ||| fieldFixed ||| fieldVbr)
signedImpl :: (Bits a, Num a) => Match Field a
signedImpl = fmap decode . (fieldLiteral ||| fieldFixed ||| fieldVbr)
where
decode bs
| not (testBit n 0) = n `shiftR` 1
| n /= 1 = negate (n `shiftR` 1)
| otherwise = bit 63 -- not really right, but it's what llvm does
where
n = fromBitString bs
-- | Parse a @Field@ as a sign-encoded number.
signedWord64 :: Match Field Word64
signedWord64 = signedImpl
-- | Parse a @Field@ as a sign-encoded number.
signedInt64 :: Match Field Int64
signedInt64 = signedImpl
-- | Parse a @Field@ as a Word32.
unsigned :: Match Field Word32
unsigned = numeric
boolean :: Match Field Bool
boolean = decode <=< (fieldFixed ||| fieldLiteral ||| fieldVbr)
where
decode bs = case bitStringValue bs of
0 -> return False
1 -> return True
_ -> mzero
nonzero :: Match Field Bool
nonzero = decode <=< (fieldFixed ||| fieldLiteral ||| fieldVbr)
where
decode bs = return $ case bitStringValue bs of
0 -> False
_ -> True
char :: Match Field Word8
char = numeric
string :: Match Field String
string = fmap UTF8.decode . fieldArray char
cstring :: Match Field String
cstring = fmap UTF8.decode . fieldArray (fieldChar6 ||| 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 n r = do
v <- getModVersion
if | v < 2 -> do
name <- entryName n
return (Symbol name, 0)
| otherwise -> do
mst <- getStringTable
case mst of
Just st -> do
offset <- parseField r 0 numeric
len <- parseField r 1 numeric
return (resolveStrtabSymbol st offset len, 2)
Nothing -> fail "New-style name encountered with no string table."