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


-- Module Parsing --------------------------------------------------------------

-- | The magic number that identifies a @Bitstream@ structure as LLVM IR.
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)

-- | Parse an LLVM Module out of a Bitstream object.
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
    --(symtabBlockId -> Just _) -> fail "Found symbol table."
    Entry
_ -> () -> Parse ()
forall a. a -> Parse a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | The only top-level block that we parse currently is the module block. The
-- Identification block that's introduced in 3.8 is ignored. In the future, it
-- might be advantageous to parse it, as it could include information that would
-- aid error reporting.
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"