{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
module Data.LLVM.BitCode.IR where
import Data.LLVM.BitCode.Bitstream
import Data.LLVM.BitCode.BitString
import Data.LLVM.BitCode.IR.Blocks
import Data.LLVM.BitCode.IR.Module (parseModuleBlock)
import Data.LLVM.BitCode.Match
import Data.LLVM.BitCode.Parse
import Data.LLVM.BitCode.Record
import Text.LLVM.AST
import Control.Monad (unless,forM_)
import Data.Word (Word16)
llvmIrMagic :: Word16
llvmIrMagic :: Word16
llvmIrMagic = BitString -> Word16
forall a. (Num a, Bits a) => BitString -> a
fromBitString (NumBits -> Int -> BitString
toBitString (Int -> NumBits
Bits' Int
8) Int
0xc0
BitString -> BitString -> BitString
`joinBitString`
NumBits -> Int -> BitString
toBitString (Int -> NumBits
Bits' Int
8) Int
0xde)
parseModule :: Bitstream -> Parse Module
parseModule :: Bitstream -> Parse Module
parseModule Bitstream { Word16
bsAppMagic :: Word16
bsAppMagic :: Bitstream -> Word16
bsAppMagic, [Entry]
bsEntries :: [Entry]
bsEntries :: Bitstream -> [Entry]
bsEntries } = String -> Parse Module -> Parse Module
forall a. String -> Parse a -> Parse a
label String
"Bitstream" (Parse Module -> Parse Module) -> Parse Module -> Parse Module
forall a b. (a -> b) -> a -> b
$ do
Bool -> Parse () -> Parse ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word16
bsAppMagic Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
llvmIrMagic) (String -> Parse ()
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bitstream is not an llvm-ir")
[Entry] -> Parse Module
parseTopLevel [Entry]
bsEntries
findTables :: [Entry] -> Parse ()
findTables :: [Entry] -> Parse ()
findTables [Entry]
es = [Entry] -> (Entry -> Parse ()) -> Parse ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Entry]
es ((Entry -> Parse ()) -> Parse ())
-> (Entry -> Parse ()) -> Parse ()
forall a b. (a -> b) -> a -> b
$ \Entry
e ->
case Entry
e of
(Match Entry [Entry]
strtabBlockId -> Just [ Match Entry DefineAbbrev
abbrevDef -> Just DefineAbbrev
_
, Match Entry AbbrevRecord
abbrev -> Just (Match AbbrevRecord Record
fromAbbrev -> Just Record
r)
]) -> do
StringTable
st <- ByteString -> StringTable
mkStrtab (ByteString -> StringTable)
-> Parse ByteString -> Parse StringTable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Record -> LookupField ByteString
forall a. Record -> LookupField a
parseField Record
r Int
0 Match Field ByteString
fieldBlob
StringTable -> Parse ()
setStringTable StringTable
st
Entry
_ -> () -> Parse ()
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
parseTopLevel :: [Entry] -> Parse Module
parseTopLevel :: [Entry] -> Parse Module
parseTopLevel ((Match Entry [Entry]
moduleBlockId -> Just [Entry]
blockEntries) : [Entry]
rest) = do
[Entry] -> Parse ()
findTables [Entry]
rest
[Entry] -> Parse Module
parseModuleBlock [Entry]
blockEntries
parseTopLevel (Entry
_ : [Entry]
rest) =
[Entry] -> Parse Module
parseTopLevel [Entry]
rest
parseTopLevel [] =
String -> Parse Module
forall a. String -> Parse a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"MODULE_BLOCK missing"