{-# 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.Module (parseModuleBlock)
import Data.LLVM.BitCode.Match
import Data.LLVM.BitCode.Parse
import Text.LLVM.AST
import Control.Monad ((<=<),unless)
import Data.Monoid (mappend)
import Data.Word (Word16)
llvmIrMagic :: Word16
llvmIrMagic = fromBitString (toBitString 8 0xc0 `mappend` toBitString 8 0xde)
moduleBlock :: Match Entry [Entry]
moduleBlock = fmap blockEntries . hasBlockId 8 <=< block
parseModule :: Bitstream -> Parse Module
parseModule Bitstream { bsAppMagic, bsEntries } = label "Bitstream" $ do
unless (bsAppMagic == llvmIrMagic) (fail "Bitstream is not an llvm-ir")
parseTopLevel bsEntries
parseTopLevel :: [Entry] -> Parse Module
parseTopLevel (EntryBlock Block { blockId = 8, blockEntries } : _) =
parseModuleBlock blockEntries
parseTopLevel (_ : rest) =
parseTopLevel rest
parseTopLevel [] =
fail "MODULE_BLOCK missing"