llvm-pretty-bc-parser (empty) → 0.1.2.0

raw patch · 43 files changed

+4726/−0 lines, 43 filesdep +arraydep +basedep +bytestringsetup-changed

Dependencies added: array, base, bytestring, cereal, containers, directory, fgl, fgl-visualize, filepath, llvm-pretty, llvm-pretty-bc-parser, monadLib, pretty, process

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• disasm-test/Main.hs +221/−0
• disasm-test/tests/alloca.ll +10/−0
• disasm-test/tests/debug-loc.ll +33/−0
• disasm-test/tests/factorial2.ll +19/−0
• disasm-test/tests/fn-metadata.ll +8/−0
• disasm-test/tests/fun-attrs.ll +4/−0
• disasm-test/tests/global-alias.ll +10/−0
• disasm-test/tests/global-array.ll +2/−0
• disasm-test/tests/global.ll +1/−0
• disasm-test/tests/hello-world.ll +4/−0
• disasm-test/tests/insertelt.ll +9/−0
• disasm-test/tests/metadata.ll +10/−0
• disasm-test/tests/mutual-struct-rec.ll +7/−0
• disasm-test/tests/phi-anon.ll +20/−0
• disasm-test/tests/simple-metadata.ll +6/−0
• disasm-test/tests/simple-res.ll +5/−0
• disasm-test/tests/struct-initializer.ll +6/−0
• disasm-test/tests/switch-big-value.ll +13/−0
• disasm-test/tests/switch-same-target.ll +13/−0
• disasm-test/tests/switch-simple.ll +16/−0
• disasm-test/tests/switch.ll +16/−0
• llvm-disasm/LLVMDis.hs +43/−0
• llvm-pretty-bc-parser.cabal +82/−0
• src/Data/LLVM/BitCode.hs +42/−0
• src/Data/LLVM/BitCode/BitString.hs +67/−0
• src/Data/LLVM/BitCode/Bitstream.hs +442/−0
• src/Data/LLVM/BitCode/GetBits.hs +136/−0
• src/Data/LLVM/BitCode/IR.hs +32/−0
• src/Data/LLVM/BitCode/IR/Attrs.hs +33/−0
• src/Data/LLVM/BitCode/IR/Blocks.hs +99/−0
• src/Data/LLVM/BitCode/IR/Constants.hs +406/−0
• src/Data/LLVM/BitCode/IR/Function.hs +883/−0
• src/Data/LLVM/BitCode/IR/Globals.hs +82/−0
• src/Data/LLVM/BitCode/IR/Metadata.hs +286/−0
• src/Data/LLVM/BitCode/IR/Module.hs +236/−0
• src/Data/LLVM/BitCode/IR/Types.hs +224/−0
• src/Data/LLVM/BitCode/IR/Values.hs +116/−0
• src/Data/LLVM/BitCode/Match.hs +88/−0
• src/Data/LLVM/BitCode/Parse.hs +580/−0
• src/Data/LLVM/BitCode/Record.hs +130/−0
• src/Data/LLVM/CFG.hs +254/−0

@@ -0,0 +1,30 @@+Copyright (c)2010, Trevor Elliott <trevor@galois.com>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Trevor Elliott <trevor@galois.com> nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,221 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Data.LLVM.BitCode (parseBitCodeLazyFromFile,Error(..),formatError)+import Text.LLVM.AST (Module,ppModule)++import Control.Monad (when)+import Data.Char (ord,isSpace,chr)+import Data.Monoid ( mconcat, Endo(..) )+import Data.Typeable (Typeable)+import System.Console.GetOpt+           ( ArgOrder(..), ArgDescr(..), OptDescr(..), getOpt, usageInfo )+import System.Directory (getTemporaryDirectory,removeFile)+import System.Environment (getArgs,getProgName)+import System.Exit (exitFailure,exitSuccess,ExitCode(..))+import System.FilePath ((<.>),dropExtension,takeFileName)+import System.IO+    (openBinaryTempFile,hClose,openTempFile,hPrint)+import System.Process+    (proc,createProcess,waitForProcess,cmdspec,CmdSpec(..),CreateProcess())+import qualified Control.Exception as X+import qualified Data.ByteString.Lazy as L+++-- Option Parsing --------------------------------------------------------------++data Options = Options { optTests   :: [FilePath] -- ^ Tests+                       , optLlvmAs  :: String     -- ^ llvm-as  name+                       , optLlvmDis :: String     -- ^ llvm-dis name+                       , optHelp    :: Bool+                       } deriving (Show)++defaultOptions :: Options+defaultOptions  = Options { optTests   = []+                          , optLlvmAs  = "llvm-as"+                          , optLlvmDis = "llvm-dis"+                          , optHelp    = False+                          }++options :: [OptDescr (Endo Options)]+options  =+  [ Option "" ["with-llvm-as"] (ReqArg setLlvmAs "FILEPATH")+    "path to llvm-as"+  , Option "" ["with-llvm-dis"] (ReqArg setLlvmDis "FILEPATH")+    "path to llvm-dis"+  , Option "h" ["help"] (NoArg setHelp)+    "display this message"+  ]++setLlvmAs :: String -> Endo Options+setLlvmAs str = Endo (\opt -> opt { optLlvmAs = str })++setLlvmDis :: String -> Endo Options+setLlvmDis str = Endo (\opt -> opt { optLlvmDis = str })++setHelp :: Endo Options+setHelp  = Endo (\opt -> opt { optHelp = True })++addTest :: String -> Endo Options+addTest test = Endo (\opt -> opt { optTests = test : optTests opt })++getOptions :: IO Options+getOptions  =+  do args <- getArgs+     case getOpt (ReturnInOrder addTest) options args of++       (fs,[],[]) -> do let opts = appEndo (mconcat fs) defaultOptions++                        when (optHelp opts) $ do printUsage []+                                                 exitSuccess++                        return opts++       (_,_,errs) -> do printUsage errs+                        exitFailure++printUsage :: [String] -> IO ()+printUsage errs =+  do prog <- getProgName+     let banner = "Usage: " ++ prog ++ " [OPTIONS] test1.ll .. testn.ll"+     putStrLn (usageInfo (unlines (errs ++ [banner])) options)+++-- Test Running ----------------------------------------------------------------++-- | Run all provided tests.+main :: IO ()+main  = do+  opts <- getOptions+  mapM_ (runTest opts) (optTests opts)++-- | A test failure.+data TestFailure+  = ParseError Error -- ^ A parser failure.+    deriving (Typeable,Show)++instance X.Exception TestFailure++-- | Attempt to compare the assembly generated by llvm-pretty and llvm-dis.+runTest :: Options -> FilePath -> IO ()+runTest opts file = do+  putStr (showString file ":")+  X.handle logError                                  $+    X.handle logCommandError                         $+    X.bracket (generateBitCode  opts pfx file) removeFile $ \ bc     ->+    X.bracket (normalizeBitCode opts pfx bc)   removeFile $ \ norm   ->+    X.bracket (processBitCode        pfx bc)   removeFile $ \ parsed -> do+      ignore (wait (proc "diff" ["-u",norm,parsed]))+      putStrLn "success"+  where+  pfx = dropExtension (takeFileName file)++  logError (ParseError msg) = do+    putStrLn "failure"+    putStrLn (unlines (map ("; " ++) (lines (formatError msg))))++  logCommandError (CommandFailed cmd) = do+    putStrLn "failure"+    putStrLn ("Command ``" ++ cmd ++ "'' failed\n\n")++-- | Assemble some llvm assembly, producing a bitcode file in /tmp.+generateBitCode :: Options -> FilePath -> FilePath -> IO FilePath+generateBitCode Options { .. } pfx file = do+  tmp    <- getTemporaryDirectory+  (bc,h) <- openBinaryTempFile tmp (pfx <.> "bc")+  hClose h+  wait (proc optLlvmAs ["-o", bc, file])+  return bc++-- | Use llvm-dis to parse a bitcode file, to obtain a normalized version of the+-- llvm assembly.+normalizeBitCode :: Options -> FilePath -> FilePath -> IO FilePath+normalizeBitCode Options { .. } pfx file = do+  tmp      <- getTemporaryDirectory+  (norm,h) <- openTempFile tmp (pfx <.> "ll")+  hClose h+  wait (proc optLlvmDis ["-o", norm, file])+  stripComments norm+  return norm++-- | Parse a bitcode file using llvm-pretty, failing the test if the parser+-- fails.+processBitCode :: FilePath -> FilePath -> IO FilePath+processBitCode pfx file = do+  let handler :: X.SomeException -> IO (Either Error Module)+      handler se = return (Left (Error [] (show se)))+  e <- parseBitCodeLazyFromFile file `X.catch` handler+  case e of+    Left err -> X.throwIO (ParseError err)+    Right m  -> do+      tmp        <- getTemporaryDirectory+      (parsed,h) <- openTempFile tmp (pfx <.> "ll")+      hPrint h (ppModule m)+      hClose h+      stripComments parsed+      return parsed++-- | Remove comments from a .ll file, stripping everything including the+-- semi-colon.+stripComments :: FilePath -> IO ()+stripComments path = do+  bytes <- L.readFile path+  removeFile path+  mapM_ (writeLine . dropComments) (bsLines bytes)+  where+  writeLine bs | L.null bs = return ()+               | otherwise = do+                 L.appendFile path bs+                 L.appendFile path (L.singleton 0x0a)++-- | Split a bytestring by its lines.+bsLines :: L.ByteString -> [L.ByteString]+bsLines = L.split char+  where+  char = fromIntegral (ord '\n')++-- | Take characters until the llvm comment delimiter is found.+dropComments :: L.ByteString -> L.ByteString+dropComments  = dropTrailingSpace . L.takeWhile (/= char)+  where+  char = fromIntegral (ord ';')++-- | Drop trailing space from a bytestring.+dropTrailingSpace :: L.ByteString -> L.ByteString+dropTrailingSpace bs+  | len <= 0  = L.empty+  | otherwise = L.take (loop len) bs+  where+  len = L.length bs - 1+  loop n | isSpace (chr (fromIntegral (L.index bs n))) = loop (n-1)+         | otherwise                                   = n++-- | A shell-command failure.+data CommandError+  = CommandFailed String -- ^ The command failed when running.+    deriving (Typeable,Show)++instance X.Exception CommandError++-- | Construct a command error, given a description of the command that was run.+commandError :: CmdSpec -> CommandError+commandError (ShellCommand str)  = CommandFailed str+commandError (RawCommand p args) = CommandFailed (unwords (takeFileName p:args))++-- | Run a command, waiting for it to return.+wait :: CreateProcess -> IO ()+wait cmd = do+  (_,_,_,ph) <- createProcess cmd+  status     <- waitForProcess ph+  case status of+    ExitFailure{} -> X.throwIO (commandError (cmdspec cmd))+    _             -> return ()++-- | Ignore a command that fails.+ignore :: IO () -> IO ()+ignore  = X.handle f+  where+  f :: CommandError -> IO ()+  f _ = return ()

@@ -0,0 +1,10 @@+; ModuleID = 'alloca.bc'++%aaaa = type [1 x i32]++define i32 @f() {+  %arr = alloca %aaaa, align 4+  %ptr = getelementptr %aaaa* %arr, i32 0, i32 0+  store i32 0, i32* %ptr+  ret i32 0+}

@@ -0,0 +1,33 @@+; ModuleID = 'test.c'+target datalayout = "e-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:128:128-a0:0:64-s0:64:64-f80:128:128-n8:16:32:64-S128"+target triple = "x86_64-redhat-linux-gnu"++define i32 @f(i32 %x) nounwind uwtable {+  %1 = alloca i32, align 4+  store i32 %x, i32* %1, align 4+  call void @llvm.dbg.declare(metadata !{i32* %1}, metadata !12), !dbg !13+  %2 = load i32* %1, align 4, !dbg !14+  %3 = add nsw i32 %2, 1, !dbg !14+  ret i32 %3, !dbg !14+}++declare void @llvm.dbg.declare(metadata, metadata) nounwind readnone++!llvm.dbg.cu = !{!0}++!0 = metadata !{i32 720913, i32 0, i32 12, metadata !"test.c", metadata !"<file>", metadata !"clang version 3.0 (tags/RELEASE_30/final)", i1 true, i1 false, metadata !"", i32 0, metadata !1, metadata !1, metadata !3, metadata !1} ; [ DW_TAG_compile_unit ]+!1 = metadata !{metadata !2}+!2 = metadata !{i32 0}+!3 = metadata !{metadata !4}+!4 = metadata !{metadata !5}+!5 = metadata !{i32 720942, i32 0, metadata !6, metadata !"f", metadata !"f", metadata !"", metadata !6, i32 2, metadata !7, i1 false, i1 true, i32 0, i32 0, i32 0, i32 256, i1 false, i32 (i32)* @f, null, null, metadata !10} ; [ DW_TAG_subprogram ]+!6 = metadata !{i32 720937, metadata !"test.c", metadata !"<file>", null} ; [ DW_TAG_file_type ]+!7 = metadata !{i32 720917, i32 0, metadata !"", i32 0, i32 0, i64 0, i64 0, i32 0, i32 0, i32 0, metadata !8, i32 0, i32 0} ; [ DW_TAG_subroutine_type ]+!8 = metadata !{metadata !9}+!9 = metadata !{i32 720932, null, metadata !"int", null, i32 0, i64 32, i64 32, i64 0, i32 0, i32 5} ; [ DW_TAG_base_type ]+!10 = metadata !{metadata !11}+!11 = metadata !{i32 720932}                      ; [ DW_TAG_base_type ]+!12 = metadata !{i32 721153, metadata !5, metadata !"x", metadata !6, i32 16777218, metadata !9, i32 0, i32 0} ; [ DW_TAG_arg_variable ]+!13 = metadata !{i32 2, i32 11, metadata !5, null}+!14 = metadata !{i32 3, i32 2, metadata !15, null}+!15 = metadata !{i32 720907, metadata !5, i32 2, i32 14, metadata !6, i32 0} ; [ DW_TAG_lexical_block ]

@@ -0,0 +1,19 @@+; ModuleID = 'test.bc'++define i32 @factorial(i32 %a0) {+  br label %test++test:                                             ; preds = %incr, %0+  %1 = phi i32 [ %a0, %0 ], [ %6, %4 ]+  %2 = phi i32 [ 1, %0 ], [ %5, %4 ]+  %3 = icmp ule i32 %2, 1+  br i1 %3, label %exit, label %4++; <label>:4+  %5 = mul i32 %2, %1+  %6 = sub i32 %1, 1+  br label %test++exit:                                             ; preds = %test+  ret i32 %2+}

@@ -0,0 +1,8 @@++declare void @llvm.dbg.declare(metadata, metadata)++define void @f(i32 %x) {+  %y = add i32 %x, 20+  call void @llvm.dbg.declare( metadata !{ i32 %x }, metadata !{ metadata !"x" } )+  ret void+}

@@ -0,0 +1,4 @@++define private i32 @x() {+  ret i32 10+}

@@ -0,0 +1,10 @@++%azaz = type { i32, i8 }++define i32 @f() {+	%a = alloca %azaz, align 4+	%ptr = getelementptr %azaz* %a, i32 0, i32 0+	store i32 42, i32* %ptr+	%x = load i32* %ptr+	ret i32 %x+}

@@ -0,0 +1,2 @@++@val = internal constant [1 x i16] [i16 1], align 8

@@ -0,0 +1,1 @@+@value = global i32 10

@@ -0,0 +1,4 @@++define void @hello_world() {+	ret void+}

@@ -0,0 +1,9 @@++define <4 x i8> @f(i8 %a, i8 %b, i8 %c, i8 %d) {+  %1 = insertelement <4 x i8> undef, i8 %a, i32 0+  %2 = insertelement <4 x i8> %1,    i8 %b, i32 1+  %3 = insertelement <4 x i8> %2,    i8 %c, i32 2+  %4 = insertelement <4 x i8> %3,    i8 %d, i32 3++  ret <4 x i8> %3+}

@@ -0,0 +1,10 @@++; Some unnamed metadata nodes, which are referenced by the named metadata.+!0 = metadata !{ metadata !"zero" }+!1 = metadata !{ metadata !{ metadata !"three" }, metadata !2 }+!2 = metadata !{ metadata !"one"  }++; A named metadata.+!thinger = !{ !0, !1, !2 }++@val = global i32 10

@@ -0,0 +1,7 @@++%struct.A = type { i32, %struct.B* }+%struct.B = type { i32, %struct.A* }++define %struct.A* @f(%struct.A* %ptr) {+  ret %struct.A* %ptr+}

@@ -0,0 +1,20 @@++; This test exposes a strange problem in which our parser was ignoring arguments+; to the phi instruction if they failed to parse.  The case where they were+; failing was exposed by having one pair of value and label be made up of+; implicit identifiers.+define void @test(i32 %a) {+	br label %test++test:+	%1 = phi i32 [ %a, %0 ], [ %4, %3 ]+	%2 = icmp eq i32 %a, 0+	br i1 %2, label %exit, label %3++; label %3+	%4 = sub i32 %1, 1+	br label %test++exit:+	ret void+}

@@ -0,0 +1,6 @@++!0 = metadata !{ metadata !"string" }++define void @f() {+  ret void+}

@@ -0,0 +1,5 @@++define i32 @f(i32 %a) {+  %b = add i32 %a, 5+  ret i32 %b+}

@@ -0,0 +1,6 @@++%0 = type { i32, i8, [3 x i8] }+%1 = type { i32, [6 x i8], [2 x i8] }++@struct_test.b = internal constant %0 { i32 99, i8 122, [3 x i8] undef }, align 4+@struct_test_two.x = internal constant %1 { i32 1, [6 x i8] c"fredd\00", [2 x i8] undef }, align 4

@@ -0,0 +1,13 @@++define i32 @f(i512 %x) {+  switch i512 %x, label %default [+    i512  9223372036854775808, label %isOne+    i512 19223372036854775808, label %isOne+  ]++default:+  ret i32 0++isOne:+  ret i32 1+}

@@ -0,0 +1,13 @@++define i32 @f(i32 %x) {+  switch i32 %x, label %default [+    i32 1, label %isOne+    i32 2, label %isOne+  ]++default:+  ret i32 0++isOne:+  ret i32 1+}

@@ -0,0 +1,16 @@++define i32 @f(i32 %x) {+  switch i32 %x, label %default [+    i32 1, label %isOne+    i32 2, label %isTwo+  ]++default:+  ret i32 0++isOne:+  ret i32 1++isTwo:+  ret i32 10+}

@@ -0,0 +1,16 @@++define i32 @f(i32 %x) {+  switch i32 %x, label %default [+    i32 1, label %isOne+    i32 2, label %isTwo+  ]++default:+  ret i32 0++isOne:+  ret i32 1++isTwo:+  ret i32 10+}

@@ -0,0 +1,43 @@++import Data.LLVM.BitCode (parseBitCode, formatError)+import Data.LLVM.CFG (buildCFG, CFG(..), blockId)+import Text.LLVM.AST (ppModule, defBody, modDefines)++import Control.Monad (when)+import Data.Graph.Inductive.Graph (nmap, emap)+import Data.Graph.Inductive.Dot (fglToDotString, showDot)+import Data.List (partition)+import System.Environment (getArgs,getProgName)+import System.Exit (exitFailure)+import System.IO (stderr,hPutStrLn)+import qualified Data.ByteString as S++main :: IO ()+main  = do+  args <- getArgs+  let (doCFG, files) = partition (== "-cfg") args+  when (null files) (printUsage >> exitFailure)+  mapM_ (disasm (not $ null doCFG)) files++printUsage :: IO ()+printUsage  = do+  name <- getProgName+  putStrLn ("Usage: " ++ name ++ " [-cfg] { file.bc }+")++disasm :: Bool -> FilePath -> IO ()+disasm doCFG file = do+  putStrLn (replicate 80 '=' ++ "\n")+  putStrLn ("; " ++ file)+  e <- parseBitCode =<< S.readFile file+  case e of++    Left err -> do+      hPutStrLn stderr (formatError err)+      exitFailure++    Right m  -> do+      print (ppModule m)+      when doCFG $ do+        let cfgs  = map (buildCFG . defBody) $ modDefines m+            fixup = nmap (show . blockId) . emap (const "")+        mapM_ (putStrLn . showDot . fglToDotString . fixup . cfgGraph) cfgs

@@ -0,0 +1,82 @@+Name:                llvm-pretty-bc-parser+Version:             0.1.2.0+License:             BSD3+License-file:        LICENSE+Author:              Trevor Elliott <trevor@galois.com>+Maintainer:          Trevor Elliott+Category:            Text+Build-type:          Simple+Cabal-version:       >=1.16+Synopsis:            LLVM bitcode parsing library++Extra-source-files:  disasm-test/tests/*.ll++Source-repository head+  type:                git+  location:            http://github.com/galoisinc/llvm-pretty-bc-parser++Library+  Hs-source-dirs:      src+  Exposed-modules:     Data.LLVM.CFG,+                       Data.LLVM.BitCode++  Default-language:    Haskell2010++  Other-modules:       Data.LLVM.BitCode.BitString,+                       Data.LLVM.BitCode.Bitstream,+                       Data.LLVM.BitCode.GetBits,+                       Data.LLVM.BitCode.IR,+                       Data.LLVM.BitCode.IR.Attrs+                       Data.LLVM.BitCode.IR.Blocks,+                       Data.LLVM.BitCode.IR.Constants,+                       Data.LLVM.BitCode.IR.Function,+                       Data.LLVM.BitCode.IR.Globals,+                       Data.LLVM.BitCode.IR.Metadata,+                       Data.LLVM.BitCode.IR.Module,+                       Data.LLVM.BitCode.IR.Types,+                       Data.LLVM.BitCode.IR.Values,+                       Data.LLVM.BitCode.Match,+                       Data.LLVM.BitCode.Parse,+                       Data.LLVM.BitCode.Record++  Ghc-options:         -Wall++  Build-depends:       base       >= 4 && < 5,+                       containers >= 0.4,+                       array      >= 0.3,+                       pretty     >= 1.0.1,+                       monadLib   >= 3.7.2,+                       fgl        >= 5.5,+                       cereal     >= 0.3.5.2,+                       bytestring >= 0.9.1,+                       llvm-pretty>= 0.1.0.0++Executable llvm-disasm+  Main-is:             LLVMDis.hs+  Default-language:    Haskell2010+  Ghc-options:         -Wall+  Hs-source-dirs:      llvm-disasm+  Build-depends:       bytestring >= 0.9.1,+                       base       >= 4 && < 5,+                       pretty     >= 1.0.1,+                       containers >= 0.4,+                       array      >= 0.3,+                       monadLib   >= 3.7.2,+                       fgl        >= 5.5,+                       fgl-visualize >= 0.1,+                       cereal     >= 0.3.5.2,+                       llvm-pretty>= 0.1.0.0,+                       llvm-pretty-bc-parser++Test-suite disasm-test+  type:                exitcode-stdio-1.0+  Main-is:             Main.hs+  hs-source-dirs:      disasm-test+  Ghc-options:         -Wall+  build-depends:       base >= 4 && < 5,+                       process,+                       directory,+                       bytestring,+                       filepath,+                       llvm-pretty>= 0.1.0.0,+                       llvm-pretty-bc-parser

@@ -0,0 +1,42 @@+module Data.LLVM.BitCode (+    -- * Bitcode Parsing+    parseBitCode,     parseBitCodeFromFile+  , parseBitCodeLazy, parseBitCodeLazyFromFile++    -- * Re-exported+  , Error(..), formatError+  ) where++import Data.LLVM.BitCode.Bitstream+    (Bitstream,parseBitCodeBitstream,parseBitCodeBitstreamLazy)+import Data.LLVM.BitCode.IR (parseModule)+import Data.LLVM.BitCode.Parse (runParse,badRefError,Error(..),formatError)+import Text.LLVM.AST (Module)++import Control.Monad ((<=<))+import qualified Control.Exception as X+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++parseBitCode :: S.ByteString -> IO (Either Error Module)+parseBitCode  = parseBitstream . parseBitCodeBitstream++parseBitCodeFromFile :: FilePath -> IO (Either Error Module)+parseBitCodeFromFile  = parseBitCode <=< S.readFile++parseBitCodeLazy :: L.ByteString -> IO (Either Error Module)+parseBitCodeLazy  = parseBitstream . parseBitCodeBitstreamLazy++parseBitCodeLazyFromFile :: FilePath -> IO (Either Error Module)+parseBitCodeLazyFromFile  = parseBitCodeLazy <=< L.readFile++parseBitstream :: Either String Bitstream -> IO (Either Error Module)+parseBitstream e = case e of+  Left err   -> mkError ["Bitstream"] err+  Right bits -> X.handle (return . Left . badRefError)+                         (X.evaluate (runParse (parseModule bits)))+  where+  mkError cxt msg = return $ Left Error+    { errMessage = msg+    , errContext = cxt+    }

@@ -0,0 +1,67 @@+module Data.LLVM.BitCode.BitString (+    BitString(..)+  , toBitString+  , showBitString+  , fromBitString+  , maskBits+  , take, drop, splitAt+  ) where++import Prelude hiding (take,drop,splitAt)++import Data.Bits ((.&.),(.|.),shiftL,shiftR,bit)+import Data.Monoid (Monoid(..))+import Numeric (showIntAtBase)+++data BitString = BitString+  { bsLength :: !Int+  , bsData   :: !Integer+  } deriving Show++instance Eq BitString where+  BitString n i == BitString m j = n == m && i == j++instance Monoid BitString where+  mempty = BitString 0 0+  mappend (BitString n i) (BitString m j) =+    BitString (n+m) (i .|. (j `shiftL` n))++-- | Given a number of bits to take, and an @Integer@, create a @BitString@.+toBitString :: Int -> Integer -> BitString+toBitString len val = BitString len (val .&. maskBits len)++fromBitString :: Num a => BitString -> a+fromBitString (BitString l i) = fromIntegral (i .&. maskBits l)++showBitString :: BitString -> ShowS+showBitString bs = showString padding . showString bin+  where+  bin     = showIntAtBase 2 fmt (bsData bs) ""+  padding = replicate (bsLength bs - length bin) '0'+  fmt 0   = '0'+  fmt 1   = '1'+  fmt _   = error "invalid binary digit value"+++-- | Generate a mask from a number of bits desired.+maskBits :: Int -> Integer+maskBits len+  | len <= 0  = 0+  | otherwise = pred (bit len)++take :: Int -> BitString -> BitString+take n bs@(BitString l i)+  | n >= l    = bs+  | otherwise = toBitString n i++drop :: Int -> BitString -> BitString+drop n (BitString l i)+  | n >= l    = mempty+  | otherwise = BitString (l - n) (i `shiftR` n)++splitAt :: Int -> BitString -> (BitString,BitString)+splitAt n bs@(BitString l i)+  | n <= 0    = (mempty, bs)+  | n >= l    = (bs, mempty)+  | otherwise = (toBitString n i, toBitString (l - n) (i `shiftR` n))

@@ -0,0 +1,442 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PatternGuards #-}++module Data.LLVM.BitCode.Bitstream (+    Bitstream(..)+  , Entry(..)+  , AbbrevIdWidth, AbbrevId(..)+  , Block(..), BlockId+  , RecordId+  , UnabbrevRecord(..)+  , DefineAbbrev(..), AbbrevOp(..)+  , AbbrevRecord(..), Field(..)++  , getBitstream, parseBitstream+  , getBitCodeBitstream, parseBitCodeBitstream, parseBitCodeBitstreamLazy+  ) where++import Data.LLVM.BitCode.BitString as BS+import Data.LLVM.BitCode.GetBits++import Control.Applicative ((<$>))+import Control.Monad (unless,replicateM,guard)+import Data.Monoid (Monoid(..))+import Data.Word (Word8,Word16,Word32)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.Map as Map+import qualified Data.Serialize as C+++-- Primitive Reads -------------------------------------------------------------++-- | Parse a @Bool@ out of a single bit.+boolean :: GetBits Bool+boolean  = do+  bs <- fixed 1+  return (bsData bs == 1)++-- | Parse a Num type out of n-bits.+numeric :: Num a => Int -> GetBits a+numeric n = do+  bs <- fixed n+  return (fromIntegral (bsData bs))++-- | Get a @BitString@ formatted as vbr.+vbr :: Int -> GetBits BitString+vbr n = loop mempty+  where+  len      = n - 1+  loop acc = acc `seq` do+    chunk <- fixed len+    cont  <- boolean+    let acc' = acc `mappend` chunk+    if cont+       then loop acc'+       else return acc'++-- | Process a variable-bit encoded integer.+vbrNum :: Num a => Int -> GetBits a+vbrNum n = fromBitString <$> vbr n++-- | Decode a 6-bit encoded character.+char6 :: GetBits Char+char6  = do+  word <- numeric 6+  case word of+    n | 0  <= n && n <= 25 -> return (toEnum (n + 97))+      | 26 <= n && n <= 51 -> return (toEnum (n + 39))+      | 52 <= n && n <= 61 -> return (toEnum (n - 4))+    62                     -> return '.'+    63                     -> return '_'+    _                      -> fail "invalid char6"+++-- Bitstream Parsing -----------------------------------------------------------++data Bitstream = Bitstream+  { bsAppMagic :: !Word16+  , bsEntries  :: [Entry]+  } deriving (Show)++parseBitstream :: S.ByteString -> Either String Bitstream+parseBitstream  = C.runGet (runGetBits getBitstream)++parseBitCodeBitstream :: S.ByteString -> Either String Bitstream+parseBitCodeBitstream  = C.runGet (runGetBits getBitCodeBitstream)++parseBitCodeBitstreamLazy :: L.ByteString -> Either String Bitstream+parseBitCodeBitstreamLazy  = C.runGetLazy (runGetBits getBitCodeBitstream)++-- | The magic constant at the beginning of all llvm-bitcode files.+bcMagicConst :: BitString+bcMagicConst  = BitString 8 0x42 `mappend` BitString 8 0x43++-- | Parse a @Bitstream@ from either a normal bitcode file, or a wrapped+-- bitcode.+getBitCodeBitstream :: GetBits Bitstream+getBitCodeBitstream  = label "llvm-bitstream" $ do+  mb <- try guardWrapperMagic+  case mb of+    Nothing -> getBitstream+    Just () -> do+      skip 32 -- Version+      off <- fixed 32+      -- the offset should always be 20 (5 word32 values)+      unless (fromBitString off == (20 :: Int))+          (fail ("invalid offset value: " ++ show off))+      size <- fixed 32+      skip 32 -- CPUType+      isolate (fromBitString size `div` 4) getBitstream++bcWrapperMagicConst :: BitString+bcWrapperMagicConst  = mconcat [byte 0xDE, byte 0xC0, byte 0x17, byte 0x0B]+  where+  byte = BitString 8++guardWrapperMagic :: GetBits ()+guardWrapperMagic  = do+  magic <- fixed 32+  guard (magic == bcWrapperMagicConst)++-- | Parse a @Bitstream@.+getBitstream :: GetBits Bitstream+getBitstream  = label "bitstream" $ do+  bc       <- fixed 16+  unless (bc == bcMagicConst) (fail "Invalid magic number")+  appMagic <- numeric 16+  entries  <- getTopLevelEntries+  return Bitstream+    { bsAppMagic = appMagic+    , bsEntries  = entries+    }++data Entry+  = EntryBlock          Block+  | EntryUnabbrevRecord UnabbrevRecord+  | EntryDefineAbbrev   DefineAbbrev+  | EntryAbbrevRecord   AbbrevRecord+    deriving (Show)++-- | Parse top-level entries.+getTopLevelEntries :: GetBits [Entry]+getTopLevelEntries  = fst <$> getEntries 2 Map.empty emptyAbbrevMap True++-- | Get as many entries as we can parse.+getEntries :: AbbrevIdWidth -> BlockInfoMap -> AbbrevMap -> Bool+           -> GetBits ([Entry],BlockInfoMap)+getEntries aw bim0 am0 endBlocksFail = loop bim0 am0+  where+  loop bim am = do+    let finish = return ([],bim)+    mb <- try (getAbbrevId aw)+    case mb of+      Nothing  -> finish+      Just aid -> do+        let continue bim' am' k = do+              (rest,bim'') <- loop bim' am'+              return (k rest,bim'')+        label (show aid) $ case aid of++          END_BLOCK | endBlocksFail -> fail "unexpected END_BLOCK"+                    | otherwise     -> align32bits >> finish++          ENTER_SUBBLOCK -> do+            (block,bim') <- getBlock bim+            continue bim' am (EntryBlock block :)++          DEFINE_ABBREV -> do+            def <- getDefineAbbrev+            continue bim (insertAbbrev def am) (EntryDefineAbbrev def :)++          UNABBREV_RECORD -> do+            record <- getUnabbrevRecord+            continue bim am (EntryUnabbrevRecord record :)++          ABBREV_RECORD rid -> case lookupAbbrev rid am of+            Nothing  -> fail ("unknown abbrev id: " ++ show rid)+            Just def -> do+              record <- getAbbrevRecord aw rid def+              continue bim am (EntryAbbrevRecord record :)+++-- Abbreviation IDs ------------------------------------------------------------++type AbbrevIdWidth = Int++data AbbrevId+  = END_BLOCK+  | ENTER_SUBBLOCK+  | DEFINE_ABBREV+  | UNABBREV_RECORD+  | ABBREV_RECORD !RecordId+    deriving (Ord,Eq,Show)++-- | Retrieve an @AbbrevId@, with the current width for the containing block.+getAbbrevId :: AbbrevIdWidth -> GetBits AbbrevId+getAbbrevId aw = label "abbreviation" $ do+  aid <- numeric aw+  case aid of+    0 -> return END_BLOCK+    1 -> return ENTER_SUBBLOCK+    2 -> return DEFINE_ABBREV+    3 -> return UNABBREV_RECORD+    _ -> return (ABBREV_RECORD aid)+++-- Abbreviation Definitions ----------------------------------------------------++data DefineAbbrev = DefineAbbrev+  { defineOps    :: [AbbrevOp]+  } deriving (Show)++-- | Parse an abbreviation definition.+getDefineAbbrev :: GetBits DefineAbbrev+getDefineAbbrev  =+  label "define abbrev" (DefineAbbrev `fmap` (getAbbrevOps =<< vbrNum 5))++data AbbrevOp+  = OpLiteral !BitString+  | OpFixed   !Int+  | OpVBR     !Int+  | OpArray    AbbrevOp+  | OpChar6+  | OpBlob+    deriving (Show)++-- | Parse n abbreviation operands.+getAbbrevOps :: Int -> GetBits [AbbrevOp]+getAbbrevOps 0 = return []+getAbbrevOps n = do+  (op,consumed) <- getAbbrevOp+  rest          <- getAbbrevOps (n - consumed)+  return (op:rest)++-- | Parse an abbreviation operand.+getAbbrevOp :: GetBits (AbbrevOp,Int)+getAbbrevOp  = label "abbrevop" $ do+  let one = fmap (\x -> (x,1))+  isLiteral <- boolean+  if isLiteral+     then one (OpLiteral <$> vbr 8)+     else do+       enc <- numeric 3+       case enc :: Word8 of+         1 -> one (OpFixed <$> vbrNum 5)+         2 -> one (OpVBR   <$> vbrNum 5)+         3 -> do+           (op,n) <- getAbbrevOp+           return (OpArray op, n+1)+         4 -> one (return OpChar6)+         5 -> one (return OpBlob)+         _ -> fail ("invalid encoding: " ++ show enc)+++-- Abbrev Definition Maps ------------------------------------------------------++data AbbrevMap = AbbrevMap+  { amNextId  :: !RecordId+  , amDefines :: Map.Map RecordId DefineAbbrev+  } deriving (Show)++emptyAbbrevMap :: AbbrevMap+emptyAbbrevMap  = AbbrevMap+  { amNextId  = 4+  , amDefines = Map.empty+  }++insertAbbrev :: DefineAbbrev -> AbbrevMap -> AbbrevMap+insertAbbrev def m = m+  { amNextId  = amNextId m + 1+  , amDefines = Map.insert (amNextId m) def (amDefines m)+  }++lookupAbbrev :: RecordId -> AbbrevMap -> Maybe DefineAbbrev+lookupAbbrev aid = Map.lookup aid . amDefines+++-- Blocks ----------------------------------------------------------------------++type BlockId = Word32++-- XXX Are 32-bit words big enough to house the encoded numbers?  Are they too+-- big, and waste space in most cases?+data Block = Block+  { blockId           :: !BlockId+  , blockNewAbbrevLen :: !AbbrevIdWidth+  , blockLength       :: !Int+  , blockEntries      :: [Entry]+  } deriving (Show)++-- | Parse a block, optionally extending the known block info metadata.+getBlock :: BlockInfoMap -> GetBits (Block, BlockInfoMap)+getBlock bim = do+  (block,bim') <- getGenericBlock bim+  case blockId block of++    0 -> do+      bim'' <- processBlockInfo block bim'+      return (block,bim'')++    _ -> return (block, bim')++-- | A generic block.+getGenericBlock :: BlockInfoMap -> GetBits (Block,BlockInfoMap)+getGenericBlock bim = label "block " $ do+  blockid      <- vbrNum 8+  newabbrevlen <- vbrNum 4+  align32bits+  blocklen     <- numeric 32+  let am = lookupAbbrevMap blockid bim+  (entries,bim') <- isolate blocklen (getEntries newabbrevlen bim am False)+  let block = Block+        { blockId           = blockid+        , blockNewAbbrevLen = newabbrevlen+        , blockLength       = blocklen+        , blockEntries      = entries+        }+  return (block,bim')+++-- Block Metadata --------------------------------------------------------------++data BlockInfo = BlockInfo+  { infoId      :: !BlockId+  , infoAbbrevs :: AbbrevMap+  } deriving (Show)++-- | Extend the set of abbreviation definitions for a @BlockInfo@.+addAbbrev :: DefineAbbrev -> BlockInfo -> BlockInfo+addAbbrev a bi = bi { infoAbbrevs = insertAbbrev a (infoAbbrevs bi) }++type BlockInfoMap = Map.Map BlockId BlockInfo++-- | Add a @BlockInfo@ to the set of known metadata.+insertBlockInfo :: BlockInfo -> BlockInfoMap -> BlockInfoMap+insertBlockInfo bi bim = Map.insert (infoId bi) bi bim++-- | Lookup the abbreviations defined for a block, falling back on an empty set+-- if there aren't any.+lookupAbbrevMap :: BlockId -> BlockInfoMap -> AbbrevMap+lookupAbbrevMap bid bim = maybe emptyAbbrevMap infoAbbrevs (Map.lookup bid bim)++-- | Process a generic block with blockid 0, adding all the metadata that it+-- defines to the BlockInfoMap provided.+processBlockInfo :: Block -> BlockInfoMap -> GetBits BlockInfoMap+processBlockInfo bl bim0 = case blockEntries bl of+  EntryUnabbrevRecord record:es+    | Just bi0 <- unabbrevSetBid record -> loop bim0 bi0 es+  _                                     -> fail "invalid BLOCKINFO block"+  where+  closeInfo bi bim   = insertBlockInfo bi bim+  loop bim bi []     = return (closeInfo bi bim)+  loop bim bi (e:es) = case e of++    EntryDefineAbbrev def -> loop bim (addAbbrev def bi) es++    EntryUnabbrevRecord record+      | Just bi' <- unabbrevSetBid record -> loop (closeInfo bi bim) bi' es++    -- XXX there are more interesting records, but we don't process them yet+    _ -> loop bim bi es+++-- Unabbreviated Records -------------------------------------------------------++type RecordId = Int++data UnabbrevRecord = UnabbrevRecord+  { unabbrevCode :: !RecordId+  , unabbrevOps  :: [BitString]+  } deriving (Show)++-- | Parse an unabbreviated record.+getUnabbrevRecord :: GetBits UnabbrevRecord+getUnabbrevRecord  = label "unabbreviated record" $ do+  code   <- vbrNum 6+  numops <- vbrNum 6+  ops    <- replicateM numops (vbr 6)+  return UnabbrevRecord+    { unabbrevCode = code+    , unabbrevOps  = ops+    }++-- | Turn a SETBIT unabbreviated record into an empty @BlockInfo@.+unabbrevSetBid :: UnabbrevRecord -> Maybe BlockInfo+unabbrevSetBid record = do+  guard (unabbrevCode record == 1)+  guard (not (null (unabbrevOps record)))+  return BlockInfo+    { infoId      = fromBitString (unabbrevOps record !! 0)+    , infoAbbrevs = emptyAbbrevMap+    }+++-- Abbreviated Records ---------------------------------------------------------++data AbbrevRecord = AbbrevRecord+  { abbrevIdWidth :: !AbbrevIdWidth+  , abbrevId      :: !RecordId+  , abbrevFields  :: [Field]+  } deriving (Show)++-- | Given its definition, parse an abbreviated record.+getAbbrevRecord :: AbbrevIdWidth -> RecordId -> DefineAbbrev+                -> GetBits AbbrevRecord+getAbbrevRecord aw aid def =+  label "abbreviated record" (AbbrevRecord aw aid <$> getFields def)++data Field+  = FieldLiteral !BitString+  | FieldFixed   !BitString+  | FieldVBR     !BitString+  | FieldArray    [Field]+  | FieldChar6   !Char+  | FieldBlob    !BitString+    deriving Show++getFields :: DefineAbbrev -> GetBits [Field]+getFields def = mapM interpAbbrevOp (defineOps def)++-- | Interpret a single abbreviation operation.+interpAbbrevOp :: AbbrevOp -> GetBits Field+interpAbbrevOp op = label (show op) $ case op of++  OpLiteral val -> return (FieldLiteral val)++  OpFixed width -> FieldFixed <$> fixed width++  OpVBR width -> FieldVBR <$> vbr width++  OpArray ty -> do+    len <- vbrNum 6+    FieldArray <$> replicateM len (interpAbbrevOp ty)++  OpChar6 -> FieldChar6 <$> char6++  OpBlob -> do+    len   <- vbrNum 6+    align32bits+    bytes <- fixed (len * 8)+    align32bits+    return (FieldBlob bytes)

@@ -0,0 +1,136 @@+module Data.LLVM.BitCode.GetBits (+    GetBits+  , runGetBits+  , fixed, align32bits+  , label+  , isolate+  , try+  , skip+  ) where++import Data.LLVM.BitCode.BitString++import Control.Applicative (Applicative(..),Alternative(..),(<$>))+import Control.Arrow (first)+import Control.Monad (MonadPlus(..))+import Data.Bits (shiftR)+import Data.Monoid (mempty,mappend)+import Data.Word (Word32)+import qualified Data.Serialize as C+++-- Bit-level Parsing -----------------------------------------------------------++newtype GetBits a = GetBits { unGetBits :: SubWord -> C.Get (a,SubWord) }++-- | Run a @GetBits@ action, returning its value, and the number of bits offset+-- into the next byte of the stream.+runGetBits :: GetBits a -> C.Get a+runGetBits m = fst `fmap` unGetBits m Aligned++instance Functor GetBits where+  {-# INLINE fmap #-}+  fmap f m = GetBits (\ off -> first f <$> unGetBits m off)++instance Applicative GetBits where+  {-# INLINE pure #-}+  pure x = GetBits (\ off -> return (x,off))++  {-# INLINE (<*>) #-}+  f <*> x = GetBits $ \ off0 -> do+    (g,off1) <- unGetBits f off0+    (y,off2) <- unGetBits x off1+    return (g y,off2)++instance Monad GetBits where+  {-# INLINE return #-}+  return = pure++  {-# INLINE (>>=) #-}+  m >>= f = GetBits $ \ off0 -> do+    (x,off1) <- unGetBits m off0+    unGetBits (f x) off1++  {-# INLINE fail #-}+  fail str = GetBits (\ _ -> fail str)++instance Alternative GetBits where+  {-# INLINE empty #-}+  empty   = GetBits (\_ -> mzero)++  {-# INLINE (<|>) #-}+  a <|> b = GetBits (\ off -> unGetBits a off <|> unGetBits b off)++instance MonadPlus GetBits where+  {-# INLINE mzero #-}+  mzero = empty++  {-# INLINE mplus #-}+  mplus = (<|>)+++-- Sub-word Bit Parsing State --------------------------------------------------++-- This assumes that we'll pad any incoming bitcode to a 32-bit boundary, but+-- given the use of 32-bit padding already, it seems likely that all bitcode+-- files get padded to a 32-bit boundary.+data SubWord+  = SubWord !Int !Word32+  | Aligned+    deriving (Show)++splitWord :: Int -> Int -> Word32 -> (BitString,Either Int SubWord)+splitWord n l w = case compare n l of+  LT -> (toBitString n (fromIntegral w), Right (SubWord (l - n) (w `shiftR` n)))+  EQ -> (toBitString n (fromIntegral w), Right Aligned)+  GT -> (toBitString l (fromIntegral w), Left (n - l))++-- | Get a @BitString@, yielding a new partial word.+getBitString :: Int -> C.Get (BitString,SubWord)+getBitString 0 = return (mempty,Aligned)+getBitString n = getBitStringPartial n 32 =<< C.getWord32le++-- | A combination of @splitWord@ and @getBitString@ that takes an initial+-- partial word as input.+getBitStringPartial :: Int -> Int -> Word32 -> C.Get (BitString,SubWord)+getBitStringPartial n l w = case splitWord n l w of+  (bs,Right off) -> return (bs, off)+  (bs,Left n')   -> do+    (rest,off) <- getBitString n'+    return (bs `mappend` rest, off)+++-- Basic Interface -------------------------------------------------------------++-- | Read zeros up to an alignment of 32-bits.+align32bits :: GetBits ()+align32bits  = GetBits $ \ off -> case off of+  Aligned     -> return ((),Aligned)+  SubWord _ 0 -> return ((),Aligned)+  SubWord _ _ -> fail "alignment padding was not zeros"++-- | Read out n bits as a @BitString@.+fixed :: Int -> GetBits BitString+fixed n = GetBits $ \ off -> case off of+  Aligned     -> getBitString n+  SubWord l w -> getBitStringPartial n l w++-- | Add a label to the error tag stack.+label :: String -> GetBits a -> GetBits a+label l m = GetBits (\ off -> C.label l (unGetBits m off))++-- | Isolate input length, in 32-bit words.+isolate :: Int -> GetBits a -> GetBits a+isolate ws m = GetBits (\ off -> C.isolate (ws * 4) (unGetBits m off))++-- | Try to parse something, returning Nothing when it fails.+--+-- XXX this will hang on to the parsing state at the Get and GetBits levels, so+-- a long-running computation will keep the current state until it finishes.+try :: GetBits a -> GetBits (Maybe a)+try m = (Just <$> m) `mplus` return Nothing++skip :: Int -> GetBits ()+skip n = do+  _ <- fixed n+  return ()

@@ -0,0 +1,32 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++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)+++-- Module Parsing --------------------------------------------------------------++-- | The magic number that identifies a @Bitstream@ structure as LLVM IR.+llvmIrMagic :: Word16+llvmIrMagic  = fromBitString (toBitString 8 0xc0 `mappend` toBitString 8 0xde)++-- | Block selector for the top-level module block.+moduleBlock :: Match Entry [Entry]+moduleBlock  = fmap blockEntries . hasBlockId 8 <=< block++-- | Parse an LLVM Module out of a Bitstream object.+parseModule :: Bitstream -> Parse Module+parseModule bs = do+  unless (bsAppMagic bs == llvmIrMagic) (fail "Bitstream is not an llvm-ir")+  parseModuleBlock =<< match (moduleBlock <=< oneChild) (bsEntries bs)

@@ -0,0 +1,33 @@+module Data.LLVM.BitCode.IR.Attrs where++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Record+import Text.LLVM.AST++import Control.Monad ((<=<),mzero)+++-- | Matching function for parsing the linkage types out of fields.+linkage :: Match Field Linkage+linkage  = choose <=< numeric+  where+  choose :: Match Int Linkage+  choose n = case n of+    0  -> return External+    1  -> return Weak+    2  -> return Appending+    3  -> return Internal+    4  -> return Linkonce+    5  -> return DLLImport+    6  -> return DLLExport+    7  -> return ExternWeak+    8  -> return Common+    9  -> return Private+    10 -> return WeakODR+    11 -> return LinkonceODR+    12 -> return AvailableExternally+    13 -> return LinkerPrivate+    14 -> return LinkerPrivateWeak+    15 -> return LinkerPrivateWeakDefAuto+    _  -> mzero

@@ -0,0 +1,99 @@+module Data.LLVM.BitCode.IR.Blocks where++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Record++import Control.Monad ((<=<))+++-- Generic Block Ids -----------------------------------------------------------++-- | Block info block selector.+blockInfoBlockId :: Match Entry [Entry]+blockInfoBlockId  = fmap blockEntries . hasBlockId 0 <=< block+++-- Module Block Ids ------------------------------------------------------------++moduleBlockId :: Match Entry [Entry]+moduleBlockId  = fmap blockEntries . hasBlockId 8 <=< block++paramattrBlockId :: Match Entry [Entry]+paramattrBlockId  = fmap blockEntries . hasBlockId 9 <=< block++paramattrGroupBlockId :: Match Entry [Entry]+paramattrGroupBlockId  = fmap blockEntries . hasBlockId 10 <=< block++-- | Constants block selector.+constantsBlockId :: Match Entry [Entry]+constantsBlockId  = fmap blockEntries . hasBlockId 11 <=< block++-- | Function block selector.  This will succeed for function body, only.+functionBlockId :: Match Entry [Entry]+functionBlockId  = fmap blockEntries . hasBlockId 12 <=< block++-- UNUSED_ID2 (13)++-- | Value symbol table block selector.+valueSymtabBlockId :: Match Entry [Entry]+valueSymtabBlockId  = fmap blockEntries . hasBlockId 14 <=< block++-- | Metadata block selector.+metadataBlockId :: Match Entry [Entry]+metadataBlockId  = fmap blockEntries . hasBlockId 15 <=< block++-- | Metadata attachment block selector.+metadataAttachmentBlockId :: Match Entry [Entry]+metadataAttachmentBlockId  = fmap blockEntries . hasBlockId 16 <=< block++-- | TYPE_BLOCK_ID_NEW+typeBlockIdNew :: Match Entry [Entry]+typeBlockIdNew  = fmap blockEntries . hasBlockId 17 <=< block++uselistBlockId :: Match Entry [Entry]+uselistBlockId  = fmap blockEntries . hasBlockId 18 <=< block+++-- Module Codes ----------------------------------------------------------------++-- | MODULE_CODE_VERSION+moduleCodeVersion :: Match Entry Record+moduleCodeVersion  = hasRecordCode 1 <=< fromEntry++-- | MODULE_CODE_TRIPLE+moduleCodeTriple :: Match Entry Record+moduleCodeTriple  = hasRecordCode 2 <=< fromEntry++-- | MODULE_CODE_DATALAYOUT+moduleCodeDatalayout :: Match Entry Record+moduleCodeDatalayout  = hasRecordCode 3 <=< fromEntry++-- | MODULE_CODE_ASM+moduleCodeAsm :: Match Entry Record+moduleCodeAsm  = hasRecordCode 4 <=< fromEntry++moduleCodeSectionname :: Match Entry Record+moduleCodeSectionname  = hasRecordCode 5 <=< fromEntry++moduleCodeDeplib :: Match Entry Record+moduleCodeDeplib  = hasRecordCode 6 <=< fromEntry++-- | MODULE_CODE_GLOBALVAR+moduleCodeGlobalvar :: Match Entry Record+moduleCodeGlobalvar  = hasRecordCode 7 <=< fromEntry++moduleCodeFunction :: Match Entry Record+moduleCodeFunction  = hasRecordCode 8 <=< fromEntry++-- | MODULE_CODE_ALIAS+moduleCodeAlias :: Match Entry Record+moduleCodeAlias  = hasRecordCode 9 <=< fromEntry++moduleCodePurgevals :: Match Entry Record+moduleCodePurgevals  = hasRecordCode 10 <=< fromEntry++moduleCodeGcname :: Match Entry Record+moduleCodeGcname  = hasRecordCode 11 <=< fromEntry++

@@ -0,0 +1,406 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}++module Data.LLVM.BitCode.IR.Constants where++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.IR.Values+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record+import Text.LLVM.AST++import Control.Monad (mplus,mzero,foldM,(<=<))+import Control.Monad.ST (runST,ST)+import Data.Array.ST (newArray,readArray,MArray,STUArray)+import Data.Bits (shiftL,shiftR,testBit)+import Data.Char (chr)+import Data.Maybe (fromMaybe)+import Data.Word (Word32,Word64)+import qualified Data.Map as Map++#if __GLASGOW_HASKELL__ >= 704+import Data.Array.Unsafe (castSTUArray)+#else+import Data.Array.ST (castSTUArray)+#endif+++-- Instruction Field Parsing ---------------------------------------------------++-- | Parse a binop from a field, returning its constructor in the AST.+binop :: Match Field (Maybe Int -> Typed PValue -> PValue -> PInstr)+binop  = choose <=< numeric+  where++  constant = return . const++  nuw x = testBit x 0+  nsw x = testBit x 1++  -- operations that accept the nuw and nsw flags+  wrapFlags i k = return $ \ mb x y ->+    case mb of+      Nothing -> i (k  False   False)  x y+      Just w  -> i (k (nuw w) (nsw w)) x y++  exact x = testBit x 0++  -- operations that accept the exact flag+  exactFlag i k = return $ \ mb x y ->+    case mb of+      Nothing -> i (k  False)    x y+      Just w  -> i (k (exact w)) x y++  choose :: Match Int (Maybe Int -> Typed PValue -> PValue -> PInstr)+  choose 0  = wrapFlags Arith Add+  choose 1  = wrapFlags Arith Sub+  choose 2  = wrapFlags Arith Mul+  choose 3  = exactFlag Arith UDiv+  choose 4  = exactFlag Arith SDiv+  choose 5  = constant (Arith URem)+  choose 6  = constant (Arith SRem)+  choose 7  = wrapFlags Bit Shl+  choose 8  = exactFlag Bit Lshr+  choose 9  = exactFlag Bit Ashr+  choose 10 = constant (Bit And)+  choose 11 = constant (Bit Or)+  choose 12 = constant (Bit Xor)+  choose _  = mzero++fcmpOp :: Match Field (Typed PValue -> PValue -> PInstr)+fcmpOp  = choose <=< numeric+  where+  op        = return . FCmp+  choose :: Match Int (Typed PValue -> PValue -> PInstr)+  choose 0  = op Ffalse+  choose 1  = op Foeq+  choose 2  = op Fogt+  choose 3  = op Foge+  choose 4  = op Folt+  choose 5  = op Fole+  choose 6  = op Fone+  choose 7  = op Ford+  choose 8  = op Funo+  choose 9  = op Fueq+  choose 10 = op Fugt+  choose 11 = op Fuge+  choose 12 = op Fult+  choose 13 = op Fule+  choose 14 = op Fune+  choose 15 = op Ftrue+  choose _  = mzero++icmpOp :: Match Field (Typed PValue -> PValue -> PInstr)+icmpOp  = choose <=< numeric+  where+  op        = return . ICmp+  choose :: Match Int (Typed PValue -> PValue -> PInstr)+  choose 32 = op Ieq+  choose 33 = op Ine+  choose 34 = op Iugt+  choose 35 = op Iuge+  choose 36 = op Iult+  choose 37 = op Iule+  choose 38 = op Isgt+  choose 39 = op Isge+  choose 40 = op Islt+  choose 41 = op Isle+  choose _  = mzero++castOp :: Match Field (Typed PValue -> Type -> PInstr)+castOp  = choose <=< numeric+  where+  op        = return . Conv+  choose :: Match Int (Typed PValue -> Type -> PInstr)+  choose 0  = op Trunc+  choose 1  = op ZExt+  choose 2  = op SExt+  choose 3  = op FpToUi+  choose 4  = op FpToSi+  choose 5  = op UiToFp+  choose 6  = op SiToFp+  choose 7  = op FpTrunc+  choose 8  = op FpExt+  choose 9  = op PtrToInt+  choose 10 = op IntToPtr+  choose 11 = op BitCast+  choose _  = mzero++castOpCE :: Match Field (Typed PValue -> Type -> PValue)+castOpCE  = choose <=< numeric+  where+  op c      = return (\ tv t -> ValConstExpr (ConstConv c tv t))+  choose :: Match Int (Typed PValue -> Type -> PValue)+  choose 0  = op Trunc+  choose 1  = op ZExt+  choose 2  = op SExt+  choose 3  = op FpToUi+  choose 4  = op FpToSi+  choose 5  = op UiToFp+  choose 6  = op SiToFp+  choose 7  = op FpTrunc+  choose 8  = op FpExt+  choose 9  = op PtrToInt+  choose 10 = op IntToPtr+  choose 11 = op BitCast+  choose _  = mzero++-- Constants Block -------------------------------------------------------------++type ConstantTable = Map.Map Int (Typed Value)++cstGep :: Match Entry Record+cstGep  = hasRecordCode 12 <=< fromEntry++cstInboundsGep :: Match Entry Record+cstInboundsGep  = hasRecordCode 20 <=< fromEntry++setCurType :: Int -> Parse Type+setCurType  = getType'+++-- Constants Block Parsing -----------------------------------------------------++-- | Parse the entries of the constants block.+parseConstantsBlock :: [Entry] -> Parse ()+parseConstantsBlock es = fixValueTable_ $ \ vs' -> do+  let curTy = fail "no current type id set"+  (_,vs) <- foldM (parseConstantEntry vs') (curTy,[]) es+  return vs++-- | Parse entries of the constant table.+parseConstantEntry :: ValueTable -> (Parse Type,[Typed PValue]) -> Entry+                   -> Parse (Parse Type, [Typed PValue])++parseConstantEntry t (getTy,cs) (fromEntry -> Just r) =+ label "CONSTANTS_BLOCK" $ case recordCode r of++  1 -> label "CST_CODE_SETTYPE" $ do+    let field = parseField r+    i <- field 0 numeric+    return (setCurType i, cs)++  2 -> label "CST_CODE_NULL" $ do+    ty  <- getTy+    val <- resolveNull ty+    return (getTy, Typed ty val:cs)++  3 -> label "CST_CODE_UNDEF" $ do+    ty <- getTy+    return (getTy, Typed ty ValUndef:cs)++  -- [intval]+  4 -> label "CST_CODE_INTEGER" $ do+    let field = parseField r+    ty <- getTy+    n  <- field 0 signed+    let val = fromMaybe (ValInteger n) $ do+                Integer 0 <- elimPrimType ty+                return (ValBool (n /= 0))+    return (getTy, Typed ty val:cs)++  -- [n x value]+  5 -> label "CST_CODE_WIDE_INTEGER" $ do+    ty <- getTy+    n  <- parseWideInteger r+    return (getTy, Typed ty (ValInteger n):cs)++  -- [fpval]+  6 -> label "CST_CODE_FLOAT" $ do+    let field = parseField r+    ty <- getTy+    ft <- (elimFloatType =<< elimPrimType ty)+        `mplus` fail "expecting a float type"+    let build k = do+          w <- field 0 numeric+          return (getTy, (Typed ty $! k w):cs)+    case ft of+      Float -> build (ValFloat  . castFloat)+      _     -> build (ValDouble . castDouble)++  -- [n x value number]+  7 -> label "CST_CODE_AGGREGATE" $ do+    ty    <- getTy+    elems <- parseField r 0 (fieldArray numeric)+        `mplus` parseFields r 0 numeric+    cxt <- getContext+    let vals = [forwardRef cxt ix t | ix <- elems ]+    case ty of++      Struct _fs ->+        return (getTy, Typed ty (ValStruct vals):cs)++      PackedStruct _fs ->+        return (getTy, Typed ty (ValPackedStruct vals):cs)++      Array _n fty ->+        return (getTy, Typed ty (ValArray fty (map typedValue vals)):cs)++      Vector _n ety -> do+        return (getTy, Typed ty (ValVector ety (map typedValue vals)):cs)++      _ -> return (getTy, Typed ty ValUndef:cs)++  -- [values]+  8 -> label "CST_CODE_STRING" $ do+    let field = parseField r+    ty     <- getTy+    values <- field 0 string+    return (getTy, Typed ty (ValString values):cs)++  -- [values]+  9 -> label "CST_CODE_CSTRING" $ do+    ty     <- getTy+    values <- parseField r 0 cstring+        `mplus` parseFields r 0 (fieldChar6 ||| char)+    return (getTy, Typed ty (ValString (values ++ [chr 0])):cs)++  -- [opcode,opval,opval]+  10 -> label "CST_CODE_CE_BINOP" $ do+    fail "not implemented"++  -- [opcode, opty, opval]+  11 -> label "CST_CODE_CE_CAST" $ do+    let field = parseField r+    ty   <- getTy+    -- We're not handling the opcode < 0 case here, in which the cast is+    -- reported as ``unknown.''+    cast'  <- field 0 castOpCE+    opval  <- field 2 numeric+    cxt    <- getContext+    return (getTy,Typed ty (cast' (forwardRef cxt opval t) ty):cs)++  -- [n x operands]+  12 -> label "CST_CODE_CE_GEP" $ do+    ty   <- getTy+    args <- parseCeGep t r+    return (getTy,Typed ty (ValConstExpr (ConstGEP False args)):cs)++  -- [opval,opval,opval]+  13 -> label "CST_CODE_CE_SELECT" $ do+    let field = parseField r+    ty  <- getTy+    ix1 <- field 0 numeric+    ix2 <- field 1 numeric+    ix3 <- field 2 numeric+    cxt <- getContext+    let ref ix = forwardRef cxt ix t+        ce     = ConstSelect (ref ix1) (ref ix2) (ref ix3)+    return (getTy, Typed ty (ValConstExpr ce):cs)++  -- [opty,opval,opval]+  14 -> label "CST_CODE_CE_EXTRACTELT" $ do+    fail "not implemented"++  15 -> label "CST_CODE_CE_INSERTELT" $ do+    fail "not implemented"++  16 -> label "CST_CODE_CE_SHUFFLEVEC" $ do+    fail "not implemented"++  17 -> label "CST_CODE_CE_CMP" $ do+    fail "not implemented"++  18 -> label "CST_CODE_INLINEASM" $ do+    let field = parseField r+    ty    <- getTy+    flags <- field 0 numeric+    let sideEffect = testBit (flags :: Int) 0+        alignStack = (flags `shiftR` 1) == 1++    alen <- field 1 numeric+    asm  <- parseSlice r 2 alen char++    clen <- field (2+alen) numeric+    cst  <- parseSlice r (3+alen) clen char++    return (getTy, Typed ty (ValAsm sideEffect alignStack asm cst):cs)++  19 -> label "CST_CODE_CE_SHUFFLEVEC_EX" $ do+    fail "not implemented"++  -- [n x operands]+  20 -> label "CST_CODE_CE_INBOUNDS_GEP" $ do+    ty   <- getTy+    args <- parseCeGep t r+    return (getTy,Typed ty (ValConstExpr (ConstGEP True args)):cs)++  -- [funty,fnval,bb#]+  21 -> label "CST_CODE_BLOCKADDRESS" $ do+    let field = parseField r+    ty  <- getTy+    val <- getValue ty =<< field 1 numeric+    bid <-                 field 2 numeric+    sym <- elimValSymbol (typedValue val)+        `mplus` fail "invalid function symbol in BLOCKADDRESS record"+    let ce = ConstBlockAddr sym bid+    return (getTy, Typed ty (ValConstExpr ce):cs)++  -- [n x elements]+  22 -> label "CST_CODE_DATA" $ do+    ty     <- getTy+    elemTy <- (elimPrimType =<< elimSequentialType ty)+        `mplus` fail "invalid container type for CST_CODE_DATA"+    let build mk = do+          ns <- parseFields r 0 numeric+          let elems            = map mk ns+              val | isArray ty = ValArray (PrimType elemTy) elems+                  | otherwise  = ValVector (PrimType elemTy) elems+          return (getTy, Typed ty val : cs)+    case elemTy of+      Integer 8        -> build ValInteger+      Integer 16       -> build ValInteger+      Integer 32       -> build ValInteger+      Integer 64       -> build ValInteger+      FloatType Float  -> build ValFloat+      FloatType Double -> build ValDouble+      _                -> fail "unknown element type in CE_DATA"++  code -> fail ("unknown constant record code: " ++ show code)++parseConstantEntry _ st (abbrevDef -> Just _) =+  -- ignore abbreviation definitions+  return st++parseConstantEntry _ _ e =+  fail ("constant block: unexpected: " ++ show e)++parseCeGep :: ValueTable -> Record -> Parse [Typed PValue]+parseCeGep t r = loop 0+  where+  field = parseField r++  loop n = do+    ty   <- getType =<< field  n    numeric+    elt  <-             field (n+1) numeric+    rest <- loop (n+2) `mplus` return []+    cxt  <- getContext+    return (Typed ty (typedValue (forwardRef cxt elt t)) : rest)++parseWideInteger :: Record -> Parse Integer+parseWideInteger r = do+  limbs <- parseFields r 0 signed+  return (foldr (\l acc -> acc `shiftL` 64 + l) 0 limbs)++resolveNull :: Type -> Parse PValue+resolveNull ty = case typeNull ty of+  HasNull nv    -> return nv+  ResolveNull i -> resolveNull =<< getType' =<< getTypeId i+++-- Float/Double Casting --------------------------------------------------------++castFloat :: Word32 -> Float+castFloat w = runST (cast w)++castDouble :: Word64 -> Double+castDouble w = runST (cast w)++cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s))+     => a -> ST s b+cast x = do+  arr <- newArray (0 :: Int, 0) x+  res <- castSTUArray arr+  readArray res 0

@@ -0,0 +1,883 @@+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ViewPatterns #-}++module Data.LLVM.BitCode.IR.Function where++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.IR.Blocks+import Data.LLVM.BitCode.IR.Constants+import Data.LLVM.BitCode.IR.Metadata+import Data.LLVM.BitCode.IR.Values+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record+import Text.LLVM.AST+import Text.LLVM.Labels++import Control.Applicative ((<$>),(<*>))+import Control.Monad (unless,mplus,mzero,foldM,(<=<))+import Data.Bits (shiftR,bit,shiftL)+import Data.Int (Int32)+import qualified Data.Foldable as F+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import qualified Data.Traversable as T+++-- Function Aliases ------------------------------------------------------------++type AliasList = Seq.Seq PartialAlias++data PartialAlias = PartialAlias+  { paName   :: Symbol+  , paType   :: Type+  , paTarget :: !Int+  } deriving Show++parseAlias :: Int -> Record -> Parse PartialAlias+parseAlias n r = do+  let field = parseField r+  ty  <- getType   =<< field 0 numeric+  tgt <-               field 1 numeric+  sym <- entryName n+  let name = Symbol sym+  _   <- pushValue (Typed ty (ValSymbol name))+  return PartialAlias+    { paName   = name+    , paType   = ty+    , paTarget = tgt+    }++finalizePartialAlias :: PartialAlias -> Parse GlobalAlias+finalizePartialAlias pa = do+  tv  <- getValue (paType pa) (paTarget pa)+  tgt <- relabel (const requireBbEntryName) (typedValue tv)+  return GlobalAlias+    { aliasName   = paName pa+    , aliasType   = paType pa+    , aliasTarget = tgt+    }+++-- Function Attribute Record ---------------------------------------------------++type DeclareList = Seq.Seq FunProto++-- | Turn a function prototype into a declaration.+finalizeDeclare :: FunProto -> Parse Declare+finalizeDeclare fp = case protoType fp of+  PtrTo (FunTy ret args va) -> return Declare+    { decRetType = ret+    , decName    = Symbol (protoName fp)+    , decArgs    = args+    , decVarArgs = va+    }+  _ -> fail "invalid type on function prototype"+++-- Function Body ---------------------------------------------------------------++type DefineList = Seq.Seq PartialDefine++-- | A define with a list of statements for a body, instead of a list of basic+-- bocks.+data PartialDefine = PartialDefine+  { partialAttrs   :: FunAttrs+  , partialRetType :: Type+  , partialName    :: Symbol+  , partialArgs    :: [Typed Ident]+  , partialVarArgs :: Bool+  , partialBody    :: BlockList+  , partialBlock   :: StmtList+  , partialBlockId :: !Int+  , partialSymtab  :: ValueSymtab+  } deriving (Show)++-- | Generate a partial function definition from a function prototype.+emptyPartialDefine :: FunProto -> Parse PartialDefine+emptyPartialDefine proto = do+  (rty,tys,va) <- elimFunPtr (protoType proto)+      `mplus` fail "invalid function type in prototype"+  names <- mapM nameNextValue tys++  symtab <- initialPartialSymtab++  return PartialDefine+    { partialAttrs     = protoAttrs proto+    , partialRetType   = rty+    , partialName      = Symbol (protoName proto)+    , partialArgs      = zipWith Typed tys names+    , partialVarArgs   = va+    , partialBody      = Seq.empty+    , partialBlock     = Seq.empty+    , partialBlockId   = 0+    , partialSymtab    = symtab+    }++-- | Set the statement list in a partial define.+setPartialBlock :: StmtList -> PartialDefine -> PartialDefine+setPartialBlock stmts pd = pd { partialBlock = stmts }++-- | Set the block list in a partial define.+setPartialBody :: BlockList -> PartialDefine -> PartialDefine+setPartialBody blocks pd = pd { partialBody = blocks }++initialPartialSymtab :: Parse ValueSymtab+initialPartialSymtab  = do+  mb     <- bbEntryName 0+  case mb of+    Just{}  -> return emptyValueSymtab+    Nothing -> do+      i <- nextResultId+      return (addBBAnon 0 i emptyValueSymtab)++updateLastStmt :: (PStmt -> PStmt) -> PartialDefine -> Parse PartialDefine+updateLastStmt f pd = case updatePartialBlock `mplus` updatePartialBody of+  Just pd' -> return pd'+  Nothing  -> fail "No statement to update"+  where+  updatePartialBlock = updateStmts partialBlock setPartialBlock pd++  updatePartialBody = case Seq.viewr (partialBody pd) of+    blocks Seq.:> b -> do+      b' <- updateStmts partialStmts setPartialStmts b+      return (setPartialBody (blocks Seq.|> b') pd)+    Seq.EmptyR          -> mzero++  updateStmts prj upd a = case Seq.viewr (prj a) of+    stmts Seq.:> stmt -> return (upd (stmts Seq.|> f stmt) a)+    Seq.EmptyR        -> mzero++++type BlockLookup = Symbol -> Int -> Parse BlockLabel++lookupBlockName :: DefineList -> BlockLookup+lookupBlockName dl = lkp+  where+  syms = Map.fromList [ (partialName d, partialSymtab d) | d <- F.toList dl ]+  lkp fn bid = case Map.lookup fn syms of+    Nothing -> fail ("symbol " ++ show (ppSymbol fn) ++ " is not defined")+    Just st -> case Map.lookup (SymTabBBEntry bid) st of+      Nothing -> fail ("block id " ++ show bid ++ " does not exist")+      Just sn -> return (mkBlockLabel sn)++-- | Finalize a partial definition.+finalizePartialDefine :: BlockLookup -> PartialDefine -> Parse Define+finalizePartialDefine lkp pd =+  -- augment the symbol table with implicitly named anonymous blocks, and+  -- generate basic blocks.+  withValueSymtab (partialSymtab pd) $ do+    body <- finalizeBody lkp (partialBody pd)+    return Define+      { defAttrs   = partialAttrs pd+      , defRetType = partialRetType pd+      , defName    = partialName pd+      , defArgs    = partialArgs pd+      , defVarArgs = partialVarArgs pd+      , defBody    = body+      }++-- | Individual label resolution step.+resolveBlockLabel :: BlockLookup -> Maybe Symbol -> Int -> Parse BlockLabel+resolveBlockLabel lkp mbSym = case mbSym of+  Nothing  -> requireBbEntryName+  Just sym -> lkp sym++-- | Name the next result with either its symbol, or the next available+-- anonymous result id.+nameNextValue :: Type -> Parse Ident+nameNextValue ty = do+  vs   <- getValueTable+  let nextId = valueNextId vs+  name <- entryName nextId `mplus` (show <$> nextResultId)+  let i   = Ident name+      tv  = Typed ty (ValIdent i)+  setValueTable (addValue tv vs)+  return i++-- | The record that defines the number of blocks in a function.+declareBlocksRecord :: Match Entry UnabbrevRecord+declareBlocksRecord  = hasUnabbrevCode 1 <=< unabbrev++-- | Emit a statement to the current partial definition.+addStmt :: Stmt' Int -> PartialDefine -> Parse PartialDefine+addStmt s d+  | isTerminator (stmtInstr s) = terminateBlock d'+  | otherwise                  = return d'+  where+  d' = d { partialBlock = partialBlock d Seq.|> s }++-- | Terminate the current basic block.  Resolve the name of the next basic+-- block as either its symbol from the symbol table, or the next available+-- anonymous identifier.+terminateBlock :: PartialDefine -> Parse PartialDefine+terminateBlock d = do+  let next = partialBlockId d + 1+  mb <- bbEntryName next+  d' <- case mb of+    Just _  -> return d+    Nothing -> do+      -- no label, use the next result id+      l <- nextResultId+      return d { partialSymtab = addBBAnon next l (partialSymtab d) }++  return d'+    { partialBody  = partialBody d Seq.|> PartialBlock+      { partialLabel = partialBlockId d+      , partialStmts = partialBlock   d+      }+    , partialBlockId = next+    , partialBlock   = Seq.empty+    }++type BlockList = Seq.Seq PartialBlock++-- | Process a @BlockList@, turning it into a list of basic blocks.+finalizeBody :: BlockLookup -> BlockList -> Parse [BasicBlock]+finalizeBody lkp = fmap F.toList . T.mapM (finalizePartialBlock lkp)++data PartialBlock = PartialBlock+  { partialLabel :: !Int+  , partialStmts :: StmtList+  } deriving (Show)++setPartialStmts :: StmtList -> PartialBlock -> PartialBlock+setPartialStmts stmts pb = pb { partialStmts = stmts }++-- | Process a partial basic block into a full basic block.+finalizePartialBlock :: BlockLookup -> PartialBlock -> Parse BasicBlock+finalizePartialBlock lkp pb = BasicBlock+                          <$> bbEntryName (partialLabel pb)+                          <*> finalizeStmts lkp (partialStmts pb)++type PStmt = Stmt' Int++type StmtList = Seq.Seq PStmt++-- | Process a list of statements with explicit block id labels into one with+-- textual labels.+finalizeStmts :: BlockLookup -> StmtList -> Parse [Stmt]+finalizeStmts lkp = mapM (finalizeStmt lkp) . F.toList++finalizeStmt :: BlockLookup -> Stmt' Int -> Parse Stmt+finalizeStmt lkp = relabel (resolveBlockLabel lkp)+++-- Function Block Parsing ------------------------------------------------------++-- | Parse the function block.+parseFunctionBlock :: [Entry] -> Parse PartialDefine+parseFunctionBlock ents = label "FUNCTION_BLOCK" $ enterFunctionDef $ do++  -- parse the value symtab block first, so that names are present during the+  -- rest of the parse+  symtab <- label "VALUE_SYMTAB" $ do+    mb <- match (findMatch valueSymtabBlockId) ents+    case mb of+      Just es -> parseValueSymbolTableBlock es+      Nothing -> return Map.empty++  -- pop the function prototype off of the internal stack+  proto <- popFunProto++  label (protoName proto) $ withValueSymtab symtab $ do++    -- generate the initial partial definition+    pd  <- emptyPartialDefine proto+    rec pd' <- foldM (parseFunctionBlockEntry vt) pd ents+        vt  <- getValueTable++    -- merge the symbol table with the anonymous symbol table+    return pd' { partialSymtab = partialSymtab pd' `Map.union` symtab }++-- | Parse the members of the function block+parseFunctionBlockEntry :: ValueTable -> PartialDefine -> Entry+                        -> Parse PartialDefine++parseFunctionBlockEntry _ d (constantsBlockId -> Just es) = do+  -- CONSTANTS_BLOCK+  parseConstantsBlock es+  return d++parseFunctionBlockEntry t d (fromEntry -> Just r) = case recordCode r of++  -- [n]+  1 -> label "FUNC_CODE_DECLARE_BLOCKS" (return d)++  -- [opval,ty,opval,opcode]+  2 -> label "FUNC_CODE_INST_BINOP" $ do+    let field = parseField r+    (lhs,ix) <- getValueTypePair r 0+    rhs      <- getValue (typedType lhs) =<< field ix numeric+    mkInstr  <- field (ix + 1) binop+    -- if there's an extra field on the end of the record, it's for designating+    -- the value of the nuw and nsw flags.  the constructor returned from binop+    -- will use that value when constructing the binop.+    let mbWord = numeric =<< fieldAt (ix + 2) r+    result (typedType lhs) (mkInstr mbWord lhs (typedValue rhs)) d++  -- [opval,opty,destty,castopc]+  3 -> label "FUNC_CODE_INST_CAST" $ do+    let field = parseField r+    (tv,ix) <- getValueTypePair r 0+    resty   <- getType =<< field ix numeric+    cast'   <-             field (ix+1) castOp+    result resty (cast' tv resty) d++  4 -> label "FUNC_CODE_INST_GEP" (parseGEP False r d)++  -- [opval,ty,opval,opval]+  5 -> label "FUNC_CODE_INST_SELECT" $ do+    let field = parseField r+    (tval,ix) <- getValueTypePair r 0+    fval      <- getValue (typedType tval)       =<< field  ix    numeric+    cond      <- getValue (PrimType (Integer 1)) =<< field (ix+1) numeric+    result (typedType tval) (Select cond tval (typedValue fval)) d++  -- [ty,opval,opval]+  6 -> label "FUNC_CODE_INST_EXTRACTELT" $ do+    (tv,ix) <- getValueTypePair r 0+    idx     <- getValue (PrimType (Integer 32)) =<< parseField r ix numeric+    (_, ty) <- elimVector (typedType tv)+        `mplus` fail "invalid EXTRACTELT record"+    result ty (ExtractElt tv (typedValue idx)) d++  -- [ty,opval,opval,opval]+  7 -> label "FUNC_CODE_INST_INSERTELT" $ do+    let field = parseField r+    (tv,ix) <- getValueTypePair r 0+    (_,pty) <- elimVector (typedType tv)+                 `mplus` fail "invalid INSERTELT record (not a vector)"+    elt     <- getValue pty                     =<< field  ix    numeric+    idx     <- getValue (PrimType (Integer 32)) =<< field (ix+1) numeric+    result (typedType tv) (InsertElt tv elt (typedValue idx)) d++  -- [opval,ty,opval,opval]+  8 -> label "FUNC_CODE_INST_SHUFFLEVEC" $ do+    let field = parseField r+    (vec1,ix) <- getValueTypePair r 0+    vec2      <- getValue (typedType vec1) =<< field  ix    numeric+    (mask,_)  <- getValueTypePair r (ix+1)+    result (typedType vec1) (ShuffleVector vec1 (typedValue vec2) mask) d++  -- 9 is handled lower down, as it's processed the same way as 28++  -- [opval,opval<optional>]+  10 -> label "FUNC_CODE_INST_RET" $ case length (recordFields r) of+    0 -> effect RetVoid d+    _ -> do+      (tv,_) <- getValueTypePair r 0+      effect (Ret tv) d++  -- [bb#,bb#,cond] or [bb#]+  11 -> label "FUNC_CODE_INST_BR" $ do+    let field = parseField r+    bb1 <- field 0 numeric+    let jump   = effect (Jump bb1) d+        branch = do+          bb2  <- field 1 numeric+          n    <- field 2 numeric+          cond <- getValue (PrimType (Integer 1)) n+          effect (Br cond bb1 bb2) d+    branch `mplus` jump++  12 -> label "FUNC_CODE_INST_SWITCH" $ do+    let field = parseField r++    -- switch implementation magic, May 2012 => 1205 => 0x4B5+    let switchInstMagic :: Int+        switchInstMagic  = 0x4B5++    n <- field 0 numeric++    -- parse the new switch format.+    let newSwitch = do+          opty <- getType =<< field 1 numeric++          width <- case opty of+            PrimType (Integer w) -> return w+            _                    -> fail "invalid switch discriminate"++          cond     <- getValue opty =<< field 2 numeric+          def      <-                   field 3 numeric -- Int id of a label+          numCases <-                   field 4 numeric+          ls       <- parseNewSwitchLabels width r numCases 5+          effect (Switch cond def ls) d++++    -- parse the old switch format+    -- [opty, op0, op1, ...]+    let oldSwitch = do+          opty <- getType n+          cond <- getValue opty =<< field 1 numeric+          def  <-                   field 2 numeric+          ls   <- parseSwitchLabels opty r 3+          effect (Switch cond def ls) d++    -- NOTE: there's a message in BitcodeReader.cpp that indicates that the+    -- newSwitch format is not used as of sometime before 3.4.2.  It's still+    -- supported, but 3.4.2 at least doesn't generate it anymore.+    if n `shiftR` 16 == switchInstMagic then newSwitch else oldSwitch+++++  -- [attrs,cc,normBB,unwindBB,fnty,op0,op1..]+  13 -> label "FUNC_CODE_INST_INVOKE" $ do+    let field = parseField r+    normal      <- field 2 numeric+    unwind      <- field 3 numeric+    (f,ix)      <- getValueTypePair r 4+    (ret,as,va) <- elimFunPtr (typedType f)+        `mplus` fail "invalid INVOKE record"+    args        <- parseInvokeArgs va r ix as+    result ret (Invoke (typedType f) (typedValue f) args normal unwind) d++  14 -> label "FUNC_CODE_INST_UNWIND" (effect Unwind d)++  15 -> label "FUNC_CODE_INST_UNREACHABLE" (effect Unreachable d)++  -- [ty,val0,bb0,...]+  16 -> label "FUNC_CODE_INST_PHI" $ do+    ty     <- getType =<< parseField r 0 numeric++    -- NOTE: we use getRelIds here, as that uses a table that's not currently+    -- stuck in the recursive loop.  Attempting to use valueRelIds on t will+    -- cause a loop.+    useRelIds <- getRelIds+    args      <- parsePhiArgs useRelIds t r+    result ty (Phi ty args) d++  -- 17 is unused+  -- 18 is unused++  -- [instty,opty,op,align]+  19 -> label "FUNC_CODE_INST_ALLOCA" $ do+    unless (length (recordFields r) == 4)+        (fail "Invalid ALLOCA record")+    let field = parseField r++    instty <- getType           =<< field 0 numeric -- pointer type+    ty     <- getType           =<< field 1 numeric -- size type+    size   <- getFnValueById ty =<< field 2 numeric -- size value+    align  <-                       field 3 numeric -- alignment value++    let sval = case typedValue size of+          ValInteger i | i == 1 -> Nothing+          _                     -> Just size+        aval = bit align `shiftR` 1++    ret <- elimPtrTo instty+        `mplus` fail "invalid return type in INST_ALLOCA"++    result instty (Alloca ret sval (Just aval)) d++  -- [opty,op,align,vol]+  20 -> label "FUNC_CODE_INST_LOAD" $ do+    (tv,ix) <- getValueTypePair r 0+    aval    <- parseField r ix numeric+    ret     <- elimPtrTo (typedType tv)+        `mplus` fail "invalid type to INST_LOAD"+    let align | aval > 0  = Just (bit aval `shiftR` 1)+              | otherwise = Nothing+    result ret (Load tv align) d++  -- 21 is unused+  -- 22 is unused++  23 -> label "FUNC_CODE_INST_VAARG" $ do+    let field = parseField r+    ty    <- getType     =<< field 0 numeric+    op    <- getValue ty =<< field 1 numeric+    resTy <- getType     =<< field 2 numeric+    result resTy (VaArg op resTy) d++  -- [ptrty,ptr,val,align,vol]+  24 -> label "FUNC_CODE_INST_STORE" $ do+    let field = parseField r+    (ptr,ix) <- getValueTypePair r 0+    ty       <- elimPtrTo (typedType ptr)+                  `mplus` fail "invalid type to INST_STORE"+    val      <- getValue ty =<< field ix numeric+    aval     <- field (ix+1) numeric+    let align | aval > 0  = Just (bit aval `shiftR` 1)+              | otherwise = Nothing+    effect (Store val ptr align) d++  -- 25 is unused++  -- [opty, opval, n x indices]+  26 -> label "FUNC_CODE_INST_EXTRACTVAL" $ do+    (tv,ix) <- getValueTypePair r 0+    ixs     <- parseIndexes r ix+    ret     <- interpValueIndex (typedType tv) ixs+    result ret (ExtractValue tv ixs) d++  27 -> label "FUNC_CODE_INST_INSERTVAL" $ do+    (tv,ix)   <- getValueTypePair r 0+    (elt,ix') <- getValueTypePair r ix+    ixs       <- parseIndexes r ix'+    result (typedType tv) (InsertValue tv elt ixs) d++  -- 28 is handled lower down, as it's processed the same way as 9++  29 -> label "FUNC_CODE_INST_VSELECT" $ do+    let field = parseField r+    (tv,ix) <- getValueTypePair r 0+    fv      <- getValue (typedType tv) =<< field ix numeric+    (c,_)   <- getValueTypePair r (ix+1)+    result (typedType tv) (Select c tv (typedValue fv)) d++  -- 30 is handled lower down, as it's processed the same way as 4+  30 -> label "FUNC_CODE_INST_INBOUNDS_GEP" (parseGEP True r d)++  31 -> label "FUNC_CODE_INST_INDIRECTBR" $ do+    let field = parseField r+    ty   <- getType     =<< field 0 numeric+    addr <- getValue ty =<< field 1 numeric+    ls   <- parseIndexes r 2+    effect (IndirectBr addr ls) d++  -- 32 is unused++  33 -> label "FUNC_CODE_INST_LOC_AGAIN" $ do+    loc <- getLastLoc+    updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d++  -- [paramattrs, cc, fnty, fnid, arg0 .. arg n]+  34 -> label "FUNC_CODE_INST_CALL" $ do+    (Typed fnty fn,ix) <- getValueTypePair r 2+    label (show fn) $ do+      (ret,as,va) <- elimFunPtr fnty `mplus` fail "invalid CALL record"+      args <- parseCallArgs va r ix as+      result ret (Call False fnty fn args) d++  -- [Line,Col,ScopeVal, IAVal]+  35 -> label "FUNC_CODE_DEBUG_LOC" $ do+    let field = parseField r+    line    <- field 0 numeric+    col     <- field 1 numeric+    scopeId <- field 2 numeric+    iaId    <- field 3 numeric++    scope <- if scopeId > 0+                then getMetadata (scopeId - 1)+                else fail "No scope provided"++    ia <- if iaId > 0+             then Just `fmap` getMetadata (iaId - 1)+             else return Nothing++    let loc = DebugLoc+          { dlLine  = line+          , dlCol   = col+          , dlScope = typedValue scope+          , dlIA    = typedValue `fmap` ia+          }+    setLastLoc loc+    updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d++  -- [ordering, synchscope]+  36 -> label "FUNC_CODE_INST_FENCE" $ do+    notImplemented++  -- [ptrty,ptr,cmp,new, align, vol,+  --  ordering, synchscope]+  37 -> label "FUNC_CODE_INST_CMPXCHG" $ do+    notImplemented++  -- [ptrty,ptr,val, operation,+  --  align, vol,+  --  ordering,synchscope]+  38 -> label "FUNC_CODE_INST_ATOMICRMW" $ do+    notImplemented++  -- [opval]+  39 -> label "FUNC_CODE_RESUME" $ do+    (tv,_) <- getValueTypePair r 0+    effect (Resume tv) d++  -- [ty,val,val,num,id0,val0...]+  40 -> label "FUNC_CODE_LANDINGPAD" $ do+    let field = parseField r+    ty          <- getType =<< field 0 numeric+    (persFn,ix) <- getValueTypePair r 1+    val         <- field ix numeric+    let isCleanup = val /= (0 :: Int)+    len         <- field (ix + 1) numeric+    clauses     <- parseClauses r len (ix + 2)+    result ty (LandingPad ty persFn isCleanup clauses) d++  -- [opty, op, align, vol,+  --  ordering, synchscope]+  41 -> label "FUNC_CODE_LOADATOMIC" $ do+    notImplemented++  -- [ptrty,ptr,val, align, vol+  --  ordering, synchscope]+  42 -> label "FUNC_CODE_STOREATOMIC" $ do+    notImplemented++  -- [opty,opval,opval,pred]+  code+   |  code == 9+   || code == 28 -> label "FUNC_CODE_INST_CMP2" $ do+    let field = parseField r+    (lhs,ix) <- getValueTypePair r 0+    rhs      <- getValue (typedType lhs) =<< field ix numeric++    let ty = typedType lhs+        parseOp | isPrimTypeOf isFloatingPoint ty ||+                  isVectorOf (isPrimTypeOf isFloatingPoint) ty = fcmpOp+                | otherwise                       = icmpOp+    op <- field (ix+1) parseOp++    let boolTy = Integer 1+    let rty = case ty of+          Vector n _ -> Vector n (PrimType boolTy)+          _          -> PrimType boolTy+    result rty (op lhs (typedValue rhs)) d++  -- unknown+   | otherwise -> fail ("instruction code " ++ show code ++ " is unknown")++parseFunctionBlockEntry _ d (valueSymtabBlockId -> Just _) = do+  -- this is parsed before any of the function block+  return d++parseFunctionBlockEntry t d (metadataBlockId -> Just es) = do+  _ <- parseMetadataBlock t es+  return d++parseFunctionBlockEntry _ d (metadataAttachmentBlockId -> Just _) = do+  -- skip the metadata attachment block+  return d++parseFunctionBlockEntry _ d (abbrevDef -> Just _) =+  -- ignore any abbreviation definitions+  return d++parseFunctionBlockEntry _ _ e = do+  fail ("function block: unexpected: " ++ show e)++-- [n x operands]+parseGEP :: Bool -> Record -> PartialDefine -> Parse PartialDefine+parseGEP ib r d = do+  (tv,ix) <- getValueTypePair r 0+  args    <- label "parseGepArgs" (parseGepArgs r ix)+  rty     <- label "interpGep"    (interpGep (typedType tv) args)+  result rty (GEP ib tv args) d++-- | Generate a statement that doesn't produce a result.+effect :: Instr' Int -> PartialDefine -> Parse PartialDefine+effect i d = addStmt (Effect i []) d++-- | Try to name results, fall back on leaving them as effects.+result :: Type -> Instr' Int -> PartialDefine -> Parse PartialDefine+result (PrimType Void) i d = effect i d+result ty              i d = do+  res <- nameNextValue ty+  addStmt (Result res i []) d++-- | Loop, parsing arguments out of a record in pairs, as the arguments to a phi+-- instruction.+parsePhiArgs :: Bool -> ValueTable -> Record -> Parse [(PValue,Int)]+parsePhiArgs relIds t r = loop 1+  where+  field = parseField r+  len   = length (recordFields r)++  getId n+    | relIds    = do+      i   <- field n signed+      pos <- getNextId+      return (pos - i)+    | otherwise =+      field n numeric++  parse n = do+    i   <- getId n+    cxt <- getContext+    let val = forwardRef cxt i t+    bid <- field (n+1) numeric+    return (typedValue val,bid)++  loop n+    | n >= len  = return []+    | otherwise = do+      entry <- parse n+      rest  <- loop (n+2)+      return (entry:rest)++-- | Parse the arguments for a call record.+parseCallArgs :: Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]+parseCallArgs  = parseArgs $ \ ty i ->+  case ty of+    PrimType Label -> return (Typed ty (ValLabel i))+    _              -> getValue ty i++-- | Parse the arguments for an invoke record.+parseInvokeArgs :: Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]+parseInvokeArgs  = parseArgs getValue++-- | Parse arguments for the invoke and call instructions.+parseArgs :: (Type -> Int -> Parse (Typed PValue))+          -> Bool -> Record -> Int -> [Type] -> Parse [Typed PValue]+parseArgs parse va r = loop+  where+  field = parseField r++  len = length (recordFields r)++  loop ix (ty:tys) = do+    tv   <- parse ty =<< field ix numeric+    rest <- loop (ix+1) tys+    return (tv:rest)+  loop ix []+    | va        = varArgs ix+    | otherwise = return []++  varArgs ix+    | ix < len  = do+      (tv,ix') <- getValueTypePair r ix+      rest     <- varArgs ix'+      return (tv:rest)+    | otherwise = return []+++parseGepArgs :: Record -> Int -> Parse [Typed PValue]+parseGepArgs r = loop+  where+  loop n = parse `mplus` return []+    where+    parse = do+      (tv,ix') <- getValueTypePair r n+      rest     <- loop ix'+      return (tv:rest)++-- | Interpret the getelementptr arguments, to determine the final type of the+-- instruction.+interpGep :: Type -> [Typed PValue] -> Parse Type+interpGep ty vs = check (resolveGep ty vs)+  where+  check res = case res of+    HasType rty -> return (PtrTo rty)+    Invalid     -> fail "unable to determine the type of getelementptr"+    Resolve i k -> do+      ty' <- getType' =<< getTypeId i+      check (k ty')++parseIndexes :: Num a => Record -> Int -> Parse [a]+parseIndexes r = loop+  where+  field  = parseField r+  loop n = do+    ix   <- field n numeric+    rest <- loop (n+1) `mplus` return []+    return (ix:rest)++interpValueIndex :: Type -> [Int32] -> Parse Type+interpValueIndex ty is = check (resolveValueIndex ty is)+  where+  check res = case res of+    Invalid     -> fail "unable to determine the type of (extract/insert)value"+    HasType rty -> return rty+    Resolve i k -> do+      ty' <- getType' =<< getTypeId i+      check (k ty')++-- | Parse out the integer values, and jump targets (as Int labels) for a switch+-- instruction.  For example, parsing the following switch instruction+--+-- >  switch i32 %Val, label %truedest [i32 0, label %falsedest]+--+-- yields the list [0,Ident "falsedest"], if labels are just 'Ident's.+parseSwitchLabels :: Type -> Record -> Int -> Parse [(Integer,Int)]+parseSwitchLabels ty r = loop+  where+  field = parseField r+  len   = length (recordFields r)++  loop n+    | n >= len  = return []+    | otherwise = do+      tv <- getFnValueById ty =<< field n numeric+      case typedValue tv of++        ValInteger i -> do+          l    <- field (n+1) numeric+          rest <- loop (n+2)+          return ((i,l):rest)++        _ -> fail "Invalid SWITCH record"++-- | See the comment for 'parseSwitchLabels' for information about what this+-- does.+parseNewSwitchLabels :: Int32 -> Record -> Int -> Int -> Parse [(Integer,Int)]+parseNewSwitchLabels width r = loop+  where+  field = parseField r+  len   = length (recordFields r)++  -- parse each group of cases as one or more numbers, and a basic block.+  loop numCases n+    | numCases <= 0 = return []+    | n >= len      = fail "invalid SWITCH record"+    | otherwise     = do+      numItems <- field n  numeric+      (ls,n')  <- parseItems numItems (n + 1)+      lab      <- field n' numeric+      rest     <- loop (numCases - 1) (n' + 1)+      return ([ (l,lab) | l <- ls ] ++ rest)++  -- different numbers that all target the same basic block+  parseItems :: Int -> Int -> Parse ([Integer],Int)+  parseItems numItems n+    | numItems <= 0 = return ([],n)+    | otherwise     = do+      isSingleNumber <- field n boolean++      -- The number of words used to represent a case is only specified when the+      -- value comes from a large type.+      (activeWords,lowStart) <-+        if width > 64+           then do aw <- field (n + 1) numeric+                   return (aw, n + 2)+           else return (1,n+1)++      -- read the chunks of the number in.  each chunk represents one 64-bit+      -- limb of a big num.+      chunks <- parseSlice r lowStart activeWords signed++      -- decode limbs in big-endian order+      let low = foldr (\l acc -> acc `shiftL` 64 + l) 0 chunks++      (num,n') <-+        if isSingleNumber+           then return (low, lowStart + activeWords)+           else fail "Unhandled case in switch: Please send in this test case!"++      (rest,nFinal) <- parseItems (numItems - 1) n'++      return (num:rest,nFinal)+++++type PClause = Clause' Int++parseClauses :: Record -> Int -> Int -> Parse [PClause]+parseClauses r = loop+  where+  loop n ix+    | n <= 0    = return []+    | otherwise = do+      cty       <- parseField r ix numeric+      (val,ix') <- getValueTypePair r (ix + 1)+      cs        <- loop (n-1) ix'+      case cty :: Int of+        0 -> return (Catch  val : cs)+        1 -> return (Filter val : cs)+        _ -> fail ("Invalid clause type: " ++ show cty)

@@ -0,0 +1,82 @@+{-# LANGUAGE ViewPatterns #-}++module Data.LLVM.BitCode.IR.Globals where++import Data.LLVM.BitCode.IR.Attrs+import Data.LLVM.BitCode.IR.Values+import Data.LLVM.BitCode.Record+import Data.LLVM.BitCode.Parse+import Text.LLVM.AST+import Text.LLVM.Labels++import Control.Monad (guard)+import Data.Bits (bit,shiftR)+import qualified Data.Sequence as Seq+++-- Global Variables ------------------------------------------------------------++type GlobalList = Seq.Seq PartialGlobal++data PartialGlobal = PartialGlobal+  { pgSym     :: Symbol+  , pgAttrs   :: GlobalAttrs+  , pgType    :: Type+  , pgValueIx :: Maybe Int+  , pgAlign   :: Maybe Align+  } deriving Show++-- [ pointer type, isconst, initid+-- , linkage, alignment, section, visibility, threadlocal+-- , unnamed_addr+-- ]+parseGlobalVar :: Int -> Record -> Parse PartialGlobal+parseGlobalVar n r = label "GLOBALVAR" $ do+  let field = parseField r+  ptrty   <- getType =<< field 0 numeric+  isconst <-             field 1 numeric+  initid  <-             field 2 numeric+  link    <-             field 3 linkage++  mbAlign <- if length (recordFields r) > 4+                then Just `fmap` field 4 numeric+                else return Nothing++  ty      <- elimPtrTo ptrty+  name    <- entryName n+  _       <- pushValue (Typed ptrty (ValSymbol (Symbol name)))+  let valid | initid == 0 = Nothing+            | otherwise   = Just (initid - 1)+      attrs = GlobalAttrs+        { gaLinkage    = do+          guard (link /= External)+          return link+        , gaConstant   = isconst == (1 :: Int)+        }++  return PartialGlobal+    { pgSym     = Symbol name+    , pgAttrs   = attrs+    , pgType    = ty+    , pgValueIx = valid+    , pgAlign   = do+        b <- mbAlign+        let aval = bit b `shiftR` 1+        guard (aval > 0)+        return aval+    }++finalizeGlobal :: PartialGlobal -> Parse Global+finalizeGlobal pg = case pgValueIx pg of+  Nothing -> return (mkGlobal ValNull)+  Just ix -> do+    tv <- getFnValueById (pgType pg) (fromIntegral ix)+    mkGlobal `fmap` relabel (const requireBbEntryName) (typedValue tv)+  where+  mkGlobal val = Global+    { globalSym   = pgSym pg+    , globalAttrs = pgAttrs pg+    , globalType  = pgType pg+    , globalValue = val+    , globalAlign = pgAlign pg+    }

@@ -0,0 +1,286 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecursiveDo #-}++module Data.LLVM.BitCode.IR.Metadata (+    parseMetadataBlock+  , PartialUnnamedMd(..)+  , finalizePartialUnnamedMd+  ) where++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record+import Text.LLVM.AST+import Text.LLVM.Labels++import Control.Exception (throw)+import Control.Monad (foldM,guard)+import Data.Maybe (fromMaybe)+import qualified Data.Map as Map+import qualified Data.Traversable as T+++-- Kind Tables -----------------------------------------------------------------++data KindTable = KindTable+  { ktNextId  :: !Int+  , ktNameMap :: Map.Map String Int+  } deriving (Show)++emptyKindTable :: KindTable+emptyKindTable  = KindTable+  { ktNextId  = 5+  , ktNameMap = Map.fromList+    [ ("dbg",    0)+    , ("tbaa",   1)+    , ("prof",   2)+    , ("fpmath", 3)+    , ("range",  4)+    ]+  }++getKindId :: String -> KindTable -> (Int,KindTable)+getKindId str kt = case Map.lookup str (ktNameMap kt) of+  Just i  -> (i,kt)+  Nothing -> (ktNextId kt, kt')+  where+  kt' = kt+    { ktNextId  = ktNextId kt + 1+    , ktNameMap = Map.insert str (ktNextId kt) (ktNameMap kt)+    }+++-- Parsing State ---------------------------------------------------------------++data MetadataTable = MetadataTable+  { mtEntries   :: MdTable+  , mtNextNode  :: !Int+  , mtNodes     :: Map.Map Int (Bool,Int)+  } deriving (Show)++emptyMetadataTable :: MdTable -> MetadataTable+emptyMetadataTable es = MetadataTable+  { mtEntries   = es+  , mtNextNode  = 0+  , mtNodes     = Map.empty+  }++metadata :: PValMd -> Typed PValue+metadata  = Typed (PrimType Metadata) . ValMd++addMetadata :: PValMd  -> MetadataTable -> (Int,MetadataTable)+addMetadata val mt = (ix, mt { mtEntries = es' })+  where+  (ix,es') = addValue' (metadata val) (mtEntries mt)++nameNode :: Bool -> Int -> MetadataTable -> MetadataTable+nameNode fnLocal ix mt = mt+  { mtNodes    = Map.insert ix (fnLocal,mtNextNode mt) (mtNodes mt)+  , mtNextNode = mtNextNode mt + 1+  }++addString :: String -> MetadataTable -> MetadataTable+addString str = snd . addMetadata (ValMdString str)++addNode :: Bool -> [Typed PValue] -> MetadataTable -> MetadataTable+addNode fnLocal vals mt = nameNode fnLocal ix mt'+  where+  (ix,mt') = addMetadata (ValMdNode vals) mt++mdForwardRef :: [String] -> MetadataTable -> Int -> Typed PValue+mdForwardRef cxt mt ix = fromMaybe fallback nodeRef+  where+  fallback  = forwardRef cxt ix (mtEntries mt)+  reference = metadata . ValMdRef . snd+  nodeRef   = reference `fmap` Map.lookup ix (mtNodes mt)++mdNodeRef :: [String] -> MetadataTable -> Int -> Int+mdNodeRef cxt mt ix =+  maybe (throw (BadValueRef cxt ix)) snd (Map.lookup ix (mtNodes mt))++mkMdRefTable :: MetadataTable -> MdRefTable+mkMdRefTable mt = Map.mapMaybe step (mtNodes mt)+  where+  step (fnLocal,ix) = do+    guard (not fnLocal)+    return ix++type KindMap = Map.Map Int Int++data PartialMetadata = PartialMetadata+  { pmEntries       :: MetadataTable+  , pmNamedEntries  :: Map.Map String [Int]+  , pmKindMap       :: KindMap+  , pmKindTable     :: KindTable+  , pmNextName      :: Maybe String+  } deriving (Show)++emptyPartialMetadata :: MdTable -> PartialMetadata+emptyPartialMetadata es = PartialMetadata+  { pmEntries       = emptyMetadataTable es+  , pmNamedEntries  = Map.empty+  , pmKindMap       = Map.empty+  , pmKindTable     = emptyKindTable+  , pmNextName      = Nothing+  }++updateMetadataTable :: (MetadataTable -> MetadataTable)+                    -> (PartialMetadata -> PartialMetadata)+updateMetadataTable f pm = pm { pmEntries = f (pmEntries pm) }++addKind :: Int -> String -> PartialMetadata -> PartialMetadata+addKind ix str pm = pm+  { pmKindMap   = Map.insert ix strId (pmKindMap pm)+  , pmKindTable = kt'+  }+  where+  (strId,kt') = getKindId str (pmKindTable pm)++setNextName :: String -> PartialMetadata -> PartialMetadata+setNextName name pm = pm { pmNextName = Just name }++nameMetadata :: [Int] -> PartialMetadata -> Parse PartialMetadata+nameMetadata val pm = case pmNextName pm of+  Just name -> return $! pm+    { pmNextName     = Nothing+    , pmNamedEntries = Map.insert name val (pmNamedEntries pm)+    }+  Nothing -> fail "Expected a metadata name"++namedEntries :: PartialMetadata -> [NamedMd]+namedEntries  = map (uncurry NamedMd)+              . Map.toList+              . pmNamedEntries++data PartialUnnamedMd = PartialUnnamedMd+  { pumIndex  :: Int+  , pumValues :: [Typed PValue]+  } deriving (Show)++finalizePartialUnnamedMd :: PartialUnnamedMd -> Parse UnnamedMd+finalizePartialUnnamedMd pum = mkUnnamedMd `fmap` fixLabels (pumValues pum)+  where+  -- map through the list and typed PValue to change labels to textual ones+  fixLabels      = mapM (T.mapM (relabel (const requireBbEntryName)))+  mkUnnamedMd vs = UnnamedMd+    { umIndex  = pumIndex pum+    , umValues = vs+    }++unnamedEntries :: PartialMetadata -> ([PartialUnnamedMd],[PartialUnnamedMd])+unnamedEntries pm = foldl resolveNode ([],[]) (Map.toList (mtNodes mt))+  where+  mt = pmEntries pm+  es = valueEntries (mtEntries mt)++  resolveNode (gs,fs) (ref,(fnLocal,ix)) = case lookupNode ref ix of+    Just pum | fnLocal   -> (gs,pum:fs)+             | otherwise -> (pum:gs,fs)+    Nothing              -> (gs,fs)++  lookupNode ref ix = do+    Typed { typedValue = ValMd (ValMdNode vs) } <- Map.lookup ref es+    return PartialUnnamedMd+      { pumIndex  = ix+      , pumValues = vs+      }++type ParsedMetadata = ([NamedMd],([PartialUnnamedMd],[PartialUnnamedMd]))++parsedMetadata :: PartialMetadata -> ParsedMetadata+parsedMetadata pm = (namedEntries pm, unnamedEntries pm)++-- Metadata Parsing ------------------------------------------------------------++parseMetadataBlock :: ValueTable -> [Entry] -> Parse ParsedMetadata+parseMetadataBlock vt es = label "METADATA_BLOCK" $ do+  ms <- getMdTable+  let pm0 = emptyPartialMetadata ms+  rec pm <- foldM (parseMetadataEntry vt (pmEntries pm)) pm0 es+  let entries = pmEntries pm+  setMdTable (mtEntries entries)+  setMdRefs  (mkMdRefTable entries)+  return (parsedMetadata pm)++-- | Parse an entry in the metadata block.+--+-- XXX this currently relies on the constant block having been parsed already.+-- Though most bitcode examples I've seen are ordered this way, it would be nice+-- to not have to rely on it.+parseMetadataEntry :: ValueTable -> MetadataTable -> PartialMetadata -> Entry+                   -> Parse PartialMetadata+parseMetadataEntry vt mt pm (fromEntry -> Just r) = case recordCode r of+  -- [values]+  1 -> label "METADATA_STRING" $ do+    str <- parseFields r 0 char+    return $! updateMetadataTable (addString str) pm++  -- 2 is unused.++  -- 3 is unused.++  -- [values]+  4 -> label "METADATA_NAME" $ do+    name <- parseFields r 0 char+    return $! setNextName name pm++  -- 5 is unused.++  -- [n x [id, name]]+  6 -> label "METADATA_KIND" $ do+    kind <- parseField  r 0 numeric+    name <- parseFields r 1 char+    return $! addKind kind name pm++  -- 7 is unused.++  -- [n x (type num, value num)]+  8 -> label "METADATA_NODE" (parseMetadataNode False vt mt r pm)++  -- [n x (type num, value num)]+  9 -> label "METADATA_FN_NODE" (parseMetadataNode True vt mt r pm)++  -- [n x mdnodes]+  10 -> label "METADATA_NAMED_NODE" $ do+    mdIds <- parseFields r 0 numeric+    cxt   <- getContext+    let ids = map (mdNodeRef cxt mt) mdIds+    nameMetadata ids pm++  -- [m x [value, [n x [id, mdnode]]]+  11 -> label "METADATA_ATTACHMENT" $ do+    fail "not implemented"++  code -> fail ("unknown record code: " ++ show code)++parseMetadataEntry _ _ pm (abbrevDef -> Just _) =+  return pm++parseMetadataEntry _ _ _ r =+  fail ("unexpected: " ++ show r)+++-- | Parse out a metadata node.+parseMetadataNode :: Bool -> ValueTable -> MetadataTable -> Record+                  -> PartialMetadata -> Parse PartialMetadata+parseMetadataNode fnLocal vt mt r pm = do+  values <- loop =<< parseFields r 0 numeric+  return $! updateMetadataTable (addNode fnLocal values) pm+  where+  loop fs = case fs of++    tyId:valId:rest -> do+      cxt <- getContext+      ty  <- getType' tyId+      val <- case ty of+        PrimType Metadata -> return (mdForwardRef cxt mt valId)+        -- XXX need to check for a void type here+        _                 -> return (forwardRef cxt valId vt)++      vals <- loop rest+      return (val:vals)++    [] -> return []++    _ -> fail "Malformed metadata node"

@@ -0,0 +1,236 @@+{-# LANGUAGE ViewPatterns #-}++module Data.LLVM.BitCode.IR.Module where++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.IR.Attrs+import Data.LLVM.BitCode.IR.Blocks+import Data.LLVM.BitCode.IR.Constants+import Data.LLVM.BitCode.IR.Function+import Data.LLVM.BitCode.IR.Globals+import Data.LLVM.BitCode.IR.Metadata+import Data.LLVM.BitCode.IR.Types+import Data.LLVM.BitCode.IR.Values+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record+import Text.LLVM.AST++import Control.Monad (foldM,guard)+import Data.List (sortBy)+import Data.Monoid (mempty)+import Data.Ord (comparing)+import qualified Data.Foldable as F+import qualified Data.Sequence as Seq+import qualified Data.Traversable as T+++-- Module Block Parsing --------------------------------------------------------++data PartialModule = PartialModule+  { partialGlobalIx   :: !Int+  , partialGlobals    :: GlobalList+  , partialDefines    :: DefineList+  , partialDeclares   :: DeclareList+  , partialDataLayout :: DataLayout+  , partialInlineAsm  :: InlineAsm+  , partialAliasIx    :: !Int+  , partialAliases    :: AliasList+  , partialNamedMd    :: [NamedMd]+  , partialUnnamedMd  :: [PartialUnnamedMd]+  }++emptyPartialModule :: PartialModule+emptyPartialModule  = PartialModule+  { partialGlobalIx   = 0+  , partialGlobals    = mempty+  , partialDefines    = mempty+  , partialDeclares   = mempty+  , partialDataLayout = mempty+  , partialInlineAsm  = mempty+  , partialAliasIx    = 0+  , partialAliases    = mempty+  , partialNamedMd    = mempty+  , partialUnnamedMd  = mempty+  }++-- | Fixup the global variables and declarations, and return the completed+-- module.+finalizeModule :: PartialModule -> Parse Module+finalizeModule pm = do+  globals  <- T.mapM finalizeGlobal       (partialGlobals pm)+  declares <- T.mapM finalizeDeclare      (partialDeclares pm)+  aliases  <- T.mapM finalizePartialAlias (partialAliases pm)+  unnamed  <- T.mapM finalizePartialUnnamedMd (partialUnnamedMd pm)+  types    <- resolveTypeDecls+  let lkp = lookupBlockName (partialDefines pm)+  defines  <- T.mapM (finalizePartialDefine lkp) (partialDefines pm)+  return emptyModule+    { modDataLayout = partialDataLayout pm+    , modNamedMd    = partialNamedMd pm+    , modUnnamedMd  = sortBy (comparing umIndex) unnamed+    , modGlobals    = F.toList globals+    , modDefines    = F.toList defines+    , modTypes      = types+    , modDeclares   = F.toList declares+    , modInlineAsm  = partialInlineAsm pm+    , modAliases    = F.toList aliases+    }++-- | Parse an LLVM Module out of the top-level block in a Bitstream.+parseModuleBlock :: [Entry] -> Parse Module+parseModuleBlock ents = label "MODULE_BLOCK" $ do++  -- the explicit type symbol table has been removed in 3.1, so we parse the+  -- type table, and generate the type symbol table from it.+  tsymtab <- label "type symbol table" $ do+    mb <- match (findMatch typeBlockIdNew) ents+    case mb of+      Just es -> parseTypeBlock es+      Nothing -> return mempty++  withTypeSymtab tsymtab $ do+    -- parse the value symbol table out first, if there is one+    symtab <- do+      mb <- match (findMatch valueSymtabBlockId) ents+      case mb of+        Just es -> parseValueSymbolTableBlock es+        Nothing -> return emptyValueSymtab++    pm <- withValueSymtab symtab+        $ foldM parseModuleBlockEntry emptyPartialModule ents++    finalizeModule pm+++-- | Parse the entries in a module block.+parseModuleBlockEntry :: PartialModule -> Entry -> Parse PartialModule++parseModuleBlockEntry pm (blockInfoBlockId -> Just _) =+  -- skip the block info block, as we only use it during Bitstream parsing.+  return pm++parseModuleBlockEntry pm (typeBlockIdNew -> Just _) = do+  -- TYPE_BLOCK_ID_NEW+  -- this is skipped, as it's parsed before anything else, in parseModuleBlock+  return pm++parseModuleBlockEntry pm (constantsBlockId -> Just es) = do+  -- CONSTANTS_BLOCK_ID+  parseConstantsBlock es+  return pm++parseModuleBlockEntry pm (moduleCodeFunction -> Just r) = do+  -- MODULE_CODE_FUNCTION+  parseFunProto r pm++parseModuleBlockEntry pm (functionBlockId -> Just es) = do+  -- FUNCTION_BLOCK_ID+  def <- parseFunctionBlock es+  return pm { partialDefines = partialDefines pm Seq.|> def }++parseModuleBlockEntry pm (paramattrBlockId -> Just _) = do+  -- PARAMATTR_BLOCK_ID+  -- skip for now+  return pm++parseModuleBlockEntry pm (paramattrGroupBlockId -> Just _) = do+  -- PARAMATTR_GROUP_BLOCK_ID+  -- skip for now+  return pm++parseModuleBlockEntry pm (metadataBlockId -> Just es) = do+  -- METADATA_BLOCK_ID+  vt <- getValueTable+  (ns,(gs,_)) <- parseMetadataBlock vt es+  return pm+    { partialNamedMd   = partialNamedMd   pm ++ ns+    , partialUnnamedMd = partialUnnamedMd pm ++ gs+    }++parseModuleBlockEntry pm (valueSymtabBlockId -> Just _) = do+  -- VALUE_SYMTAB_BLOCK_ID+  return pm++parseModuleBlockEntry pm (moduleCodeTriple -> Just _) = do+  -- MODULE_CODE_TRIPLE+  return pm++parseModuleBlockEntry pm (moduleCodeDatalayout -> Just r) = do+  -- MODULE_CODE_DATALAYOUT+  layout <- parseFields r 0 char+  case parseDataLayout layout of+    Nothing -> fail ("unable to parse data layout: ``" ++ layout ++ "''")+    Just dl -> return (pm { partialDataLayout = dl })++parseModuleBlockEntry pm (moduleCodeAsm -> Just r) = do+  -- MODULE_CODE_ASM+  asm <- parseFields r 0 char+  return pm { partialInlineAsm = lines asm }++parseModuleBlockEntry pm (abbrevDef -> Just _) = do+  -- skip abbreviation definitions+  return pm++parseModuleBlockEntry pm (moduleCodeGlobalvar -> Just r) = do+  -- MODULE_CODE_GLOBALVAR+  pg <- parseGlobalVar (partialGlobalIx pm) r+  return pm+    { partialGlobalIx = succ (partialGlobalIx pm)+    , partialGlobals  = partialGlobals pm Seq.|> pg+    }++parseModuleBlockEntry pm (moduleCodeAlias -> Just r) = do+  -- MODULE_CODE_ALIAS+  pa <- parseAlias (partialAliasIx pm) r+  return pm+    { partialAliasIx = succ (partialAliasIx pm)+    , partialAliases = partialAliases pm Seq.|> pa+    }++parseModuleBlockEntry pm (moduleCodeVersion -> Just r) = do+  -- MODULE_CODE_VERSION++  -- please see:+  -- http://llvm.org/docs/BitCodeFormat.html#module-code-version-record+  version <- parseField r 0 numeric+  case version :: Int of+    0 -> setRelIds False  -- Absolute value ids in LLVM <= 3.2+    1 -> setRelIds True   -- Relative value ids in LLVM >= 3.3+    _ -> fail ("unsupported version id: " ++ show version)++  return pm++parseModuleBlockEntry _ e =+  fail ("unexpected: " ++ show e)+++parseFunProto :: Record -> PartialModule -> Parse PartialModule+parseFunProto r pm = label "FUNCTION" $ do+  let field = parseField r+  ty      <- getType =<< field 0 numeric+  isProto <-             field 2 numeric++  link    <-             field 3 linkage++  -- push the function type+  ix   <- nextValueId+  name <- entryName ix+  _    <- pushValue (Typed ty (ValSymbol (Symbol name)))++  let proto = FunProto+        { protoType  = ty+        , protoAttrs = emptyFunAttrs+          { funLinkage = do+            -- we emit a Nothing here to maintain output compatibility with+            -- llvm-dis when linkage is External+            guard (link /= External)+            return link+          }+        , protoName  = name+        , protoIndex = ix+        }++  if isProto == (0 :: Int)+     then pushFunProto proto >> return pm+     else return pm { partialDeclares = partialDeclares pm Seq.|> proto }

@@ -0,0 +1,224 @@+{-# LANGUAGE ViewPatterns #-}++module Data.LLVM.BitCode.IR.Types (+    resolveTypeDecls+  , parseTypeBlock+  ) where++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record+import Text.LLVM.AST++import Control.Monad (when,unless,mplus,(<=<))+import Data.List (sortBy)+import Data.Maybe (catMaybes)+import Data.Monoid (mempty)+import Data.Ord (comparing)+import qualified Data.Map as Map+++-- Type Block ------------------------------------------------------------------++-- | Pattern match the TYPE_CODE_NUMENTRY unabbreviated record.+numEntry :: Match Entry Record+numEntry  = hasRecordCode 1 <=< fromUnabbrev <=< unabbrev++struct :: Match Field ([PType] -> PType)+struct  = fmap decode . boolean+  where+  decode False = Struct+  decode True  = PackedStruct++resolveTypeDecls :: Parse [TypeDecl]+resolveTypeDecls  = do+  symtab <- getTypeSymtab+  decls  <- mapM mkTypeDecl (Map.toList (tsById symtab))+  return (sortBy (comparing typeName) decls)+  where+  mkTypeDecl (ix,alias) = do+    ty <- getType' ix+    return TypeDecl+      { typeName  = alias+      , typeValue = ty+      }+++-- Type Block Parsing ----------------------------------------------------------++-- | Parsing the type block only modifies internal state, introducing a number+-- of entries to the type table.+parseTypeBlock :: [Entry] -> Parse TypeSymtab+parseTypeBlock es = label "TYPE_BLOCK" $ do++  -- drop everything until we hit TYPE_CODE_NUMENTRY+  (r,ents) <- match (dropUntil numEntry) es+  setTypeTableSize =<< label "type-table size" (parseField r 0 numeric)++  -- verify that the type table hasn't been set already+  isEmpty <- isTypeTableEmpty+  unless isEmpty (fail "Multiple TYPE_BLOCKs found!")++  -- resolve the type table, and the type symbol table+  tys <- mapM parseTypeBlockEntry ents+  cxt <- getContext+  let (tt,sym) = deriveTypeTables cxt (catMaybes tys)+  setTypeTable tt+  return sym++deriveTypeTables :: [String] -> [(PType,Maybe Ident)] -> (TypeTable,TypeSymtab)+deriveTypeTables cxt tys = (tt,sym)+  where+  ixs = zip [0 ..] tys++  -- symbol table entries aren't very common+  sym = foldl mkSym mempty ixs+  mkSym sym' (ix,(_,mb)) = case mb of+    Nothing    -> sym'+    Just alias -> addTypeSymbol ix alias sym'++  -- recursively resolve the type table, if they don't already exist in the+  -- symbol table.  if the index entry doesn't exist, throw an error, as that+  -- should be impossible.+  tt = Map.fromList [ (ix,updateAliases resolve ty) | (ix,(ty,_)) <- ixs ]+  resolve ix = case Map.lookup ix (tsById sym) of+    Nothing    -> lookupTypeRef cxt ix tt+    Just ident -> Alias ident+++type PType = Type' Int++type ParseType = Parse (Maybe (PType,Maybe Ident))++typeRef :: Match Field PType+typeRef  = return . Alias <=< numeric++-- | Parsing the type table will only ever effect internal state.+parseTypeBlockEntry :: Entry -> ParseType++parseTypeBlockEntry (fromEntry -> Just r) = case recordCode r of++  1 -> label "TYPE_CODE_NUMENTRY" noType++  2 -> label "TYPE_CODE_VOID" (addType (PrimType Void))++  3 -> label "TYPE_CODE_FLOAT" (addType (PrimType (FloatType Float)))++  4 -> label "TYPE_CODE_DOUBLE" (addType (PrimType (FloatType Double)))++  5 -> label "TYPE_CODE_LABEL" (addType (PrimType Label))++  6 -> label "TYPE_CODE_OPAQUE" (addType Opaque)++  7 -> label "TYPE_CODE_INTEGER" $ do+    let field = parseField r+    width <- field 0 numeric+    addType (PrimType (Integer width))++  8 -> label "TYPE_CODE_POINTER" $ do+    let field = parseField r+    ty <- field 0 typeRef+    when (length (recordFields r) == 2) $ do+      _space <- field 1 keep+      return ()+    addType (PtrTo ty)++  -- [vararg, attrid, [retty, paramty x N]]+  9 -> label "TYPE_CODE_FUNCTION_OLD" $ do+    let field = parseField r+    va  <- field 0 boolean+    tys <- field 2 (fieldArray typeRef)+    case tys of+      rty:ptys -> addType (FunTy rty ptys va)+      _        -> fail "function expects a return type"++  10 -> label "TYPE_CODE_STRUCT_OLD" $ do+    let field = parseField r+    mkStruct <- field 0 struct+    elements <- field 1 (fieldArray typeRef)+    addType (mkStruct elements)++  11 -> label "TYPE_CODE_ARRAY" $ do+    let field = parseField r+    numelts <- field 0 numeric+    eltty   <- field 1 typeRef+    addType (Array numelts eltty)++  12 -> label "TYPE_CODE_VECTOR" $ do+    let field = parseField r+    numelts <- field 0 numeric+    eltty   <- field 1 typeRef+    addType (Vector numelts eltty)++  13 -> label "TYPE_CODE_X86_FP80" (addType (PrimType (FloatType X86_fp80)))++  14 -> label "TYPE_CODE_FP128" (addType (PrimType (FloatType Fp128)))++  15 -> label "TYPE_CODE_PPC_FP128" (addType (PrimType (FloatType PPC_fp128)))++  16 -> label "TYPE_CODE_METADATA" (addType (PrimType Metadata))++  17 -> label "TYPE_CODE_X86_MMX" (addType (PrimType X86mmx))++  -- [ispacked, eltty x N]+  18 -> label "TYPE_CODE_STRUCT_ANON" $ do+    let field = parseField r+    ispacked <- label "is packed"     (field 0 boolean)+    tys      <- label "struct fields" (field 1 (fieldArray typeRef))+    if ispacked+       then addType (PackedStruct tys)+       else addType (Struct tys)++  19 -> label "TYPE_CODE_STRUCT_NAME" $ do+    name <- label "struct name" $ parseField r 0 cstring+        `mplus` parseFields r 0 char+    setTypeName name+    noType++  -- [ispacked, eltty x N]+  20 -> label "TYPE_CODE_STRUCT_NAMED" $ do+    let field = parseField r++    ident    <- getTypeName+    ispacked <- label "ispacked"      (field 0 boolean)+    tys      <- label "element types" (field 1 (fieldArray typeRef))+    if ispacked+       then addTypeWithAlias (PackedStruct tys) ident+       else addTypeWithAlias (Struct tys) ident++  -- [vararg, [retty, paramty x N]]+  21 -> label "TYPE_CODE_FUNCTION" $ do+    let field = parseField r+    vararg <- label "vararg"     (field 0 boolean)+    tys    <- label "parameters" (field 1 (fieldArray typeRef))+    case tys of+      rty:ptys -> addType (FunTy rty ptys vararg)+      []       -> fail "function expects a return type"++  code -> fail ("unknown type code " ++ show code)++-- skip blocks+parseTypeBlockEntry (block -> Just _) =+  return Nothing++-- skip abbrevs+parseTypeBlockEntry (abbrevDef -> Just _) =+  return Nothing++parseTypeBlockEntry e =+  fail ("type block: unexpected: " ++ show e)++++-- | Add a type to the type table.+addType :: PType -> ParseType+addType ty = return (Just (ty,Nothing))++-- | Add a type and an alias to the type table+addTypeWithAlias :: PType -> Ident -> ParseType+addTypeWithAlias ty i = return (Just (ty,Just i))++-- | Return no type for addition to the type table+noType :: ParseType+noType  = return Nothing

@@ -0,0 +1,116 @@+{-# LANGUAGE ViewPatterns #-}++module Data.LLVM.BitCode.IR.Values (+    getValueTypePair+  , getValue+  , getFnValueById+  , parseValueSymbolTableBlock+  ) where++import Data.Word++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.Match+import Data.LLVM.BitCode.Parse+import Data.LLVM.BitCode.Record+import Text.LLVM.AST++import Control.Monad ((<=<),foldM)+import qualified Data.Map as Map+++-- Value Table -----------------------------------------------------------------++-- | Get either a value from the value table, with its value, or parse a value+-- and a type.+getValueTypePair :: Record -> Int -> Parse (Typed PValue, Int)+getValueTypePair r ix = do+  let field = parseField r+  n  <- field ix numeric+  mb <- lookupValue n+  case mb of+    -- value+    Just tv -> return (tv, ix+1)++    -- forward reference+    Nothing -> do+      ty   <- getType =<< field (ix+1) numeric+      name <- entryName =<< adjustId n+      return (Typed ty (ValIdent (Ident name)), ix+2)++-- | Get a single value from the value table.+getValue :: Type -> Int -> Parse (Typed PValue)+getValue ty n = label "getValue" $ do++  useRelIds <- getRelIds+  cur       <- getNextId+  -- The relative conversion has to be done on a Word32 to handle overflow+  -- when n is large the same way BitcodeReaderMDValueList::getValue does.+  let i :: Word32+      i | useRelIds = fromIntegral cur - fromIntegral n+        | otherwise = fromIntegral n+  getFnValueById ty i++-- | Lookup a value by its absolute id, or perhaps some metadata.+getFnValueById :: Type -> Word32 -> Parse (Typed PValue)+getFnValueById ty n = label "getFnValueById" $ case ty of++  PrimType Metadata -> do+    cxt <- getContext+    md  <- getMdTable+    return (forwardRef cxt (fromIntegral n) md)++  _ -> do+    mb <- lookupValueAbs (fromIntegral n)+    -- TODO: lookup in the metadata table+    case mb of++      Just tv -> return tv++      -- forward reference+      Nothing -> do+        name <- entryName (fromIntegral n)+        return (Typed ty (ValIdent (Ident name)))++++-- Value Symbol Table Entries --------------------------------------------------++vstCodeEntry :: Match Entry Record+vstCodeEntry  = hasRecordCode 1 <=< fromEntry++vstCodeBBEntry :: Match Entry Record+vstCodeBBEntry  = hasRecordCode 2 <=< fromEntry+++-- Value Symbol Table Parsing --------------------------------------------------++parseValueSymbolTableBlock :: [Entry] -> Parse ValueSymtab+parseValueSymbolTableBlock  = foldM parseValueSymbolTableBlockEntry Map.empty++parseValueSymbolTableBlockEntry :: ValueSymtab -> Entry -> Parse ValueSymtab++parseValueSymbolTableBlockEntry vs (vstCodeEntry -> Just r) = do+  -- VST_ENTRY: [valid, namechar x N]+  let field = parseField r+  valid <- field 0 numeric+  name  <- field 1 (fieldArray (fieldChar6 ||| char))+  return (addEntry valid name vs)++parseValueSymbolTableBlockEntry vs (vstCodeBBEntry -> Just r) = do+  -- VST_BBENTRY: [bbid, namechar x N]+  let field = parseField r+  bbid <- field 0 numeric+  name <- field 1 (fieldArray (fieldChar6 ||| char))+  return (addBBEntry bbid name vs)++parseValueSymbolTableBlockEntry vs (abbrevDef -> Just _) =+  -- skip abbreviation definitions, they're already resolved+  return vs++parseValueSymbolTableBlockEntry vs (block -> Just _) =+  -- skip blocks, there are no known subblocks.+  return vs++parseValueSymbolTableBlockEntry _ e =+  fail ("value symtab: unexpected entry: " ++ show e)

@@ -0,0 +1,88 @@+module Data.LLVM.BitCode.Match where++import Data.LLVM.BitCode.Bitstream+import Data.LLVM.BitCode.Parse++import Control.Monad (MonadPlus(..),guard)+++-- Matching Predicates ---------------------------------------------------------++type Match i a = i -> Maybe a++-- | Run a match in the context of the parsing monad.+match :: Match i a -> i -> Parse a+match p = maybe (fail "match failed") return . p++-- | The match that always succeeds.+keep :: Match i i+keep  = return++-- | The match that always fails.+skip :: Match i a+skip _ = mzero++infixr 8 |||++-- | Try to apply one match, and fall back on the other if it fails.+(|||) :: Match a b -> Match a b -> Match a b+(|||) l r a = l a `mplus` r a++-- | Attempt to apply a match.  This always succeeds, but the result of the+-- match will be a @Maybe@.+tryMatch :: Match a b -> Match a (Maybe b)+tryMatch m = fmap Just . m ||| const (return Nothing)++-- | Require that a list has only one element.+oneChild :: Match [a] a+oneChild [a] = keep a+oneChild _   = mzero++findMatch :: Match a b -> Match [a] (Maybe b)+findMatch p (a:as) = (Just `fmap` p a) `mplus` findMatch p as+findMatch _ []     = return Nothing++-- | Get the nth element of a list.+index :: Int -> Match [a] a+index n as = do+  guard (n < length as)+  return (as !! n)++-- | Drop elements of a list until a predicate matches.+dropUntil :: Match a b -> Match [a] (b,[a])+dropUntil p (a:as) = success `mplus` dropUntil p as+  where+  success = do+    b <- p a+    return (b,as)+dropUntil _ []     = mzero++-- | Require that an @Entry@ be a @Block@.+block :: Match Entry Block+block (EntryBlock b) = keep b+block _              = mzero++-- | Require that an @Entry@ be an @UnabbrevRecord@.+unabbrev :: Match Entry UnabbrevRecord+unabbrev (EntryUnabbrevRecord r) = keep r+unabbrev _                       = mzero++-- | Require that an @Entry@ be an @AbbrevRecord@+abbrev :: Match Entry AbbrevRecord+abbrev (EntryAbbrevRecord r) = keep r+abbrev _                     = mzero++-- | Require than an @Entry@ be a @DefineAbbrev@.+abbrevDef :: Match Entry DefineAbbrev+abbrevDef (EntryDefineAbbrev d) = keep d+abbrevDef _                     = mzero++-- | Require that the block has the provided block id.+hasBlockId :: BlockId -> Match Block Block+hasBlockId bid b | blockId b == bid = keep b+                 | otherwise        = mzero++-- | Require that the unabbreviated record has the provided record id.+hasUnabbrevCode :: RecordId -> Match UnabbrevRecord UnabbrevRecord+hasUnabbrevCode rid r | unabbrevCode r == rid = keep r+                      | otherwise             = mzero

@@ -0,0 +1,580 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecursiveDo #-}++module Data.LLVM.BitCode.Parse where++import Text.LLVM.AST++import Control.Applicative (Applicative(..),Alternative(..),(<$>))+import Control.Monad.Fix (MonadFix)+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(..))+import Data.Typeable (Typeable)+import Data.Word ( Word32 )+import MonadLib+import qualified Control.Exception as X+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+++-- Error Collection Parser -----------------------------------------------------++data Error = Error+  { errContext :: [String]+  , errMessage :: String+  } deriving (Show)++formatError :: Error -> String+formatError err+  | null (errContext err) = errMessage err+  | otherwise             = unlines+                          $ errMessage err+                          : "from:"+                          : map ('\t' :) (errContext err)++newtype Parse a = Parse+  { unParse :: ReaderT Env (StateT ParseState (ExceptionT Error Lift)) a+  } deriving (Functor,Applicative,MonadFix)++instance Monad Parse where+  {-# INLINE return #-}+  return  = Parse . return++  {-# INLINE (>>=) #-}+  Parse m >>= f = Parse (m >>= unParse . f)++  {-# INLINE fail #-}+  fail = failWithContext++instance Alternative Parse where+  {-# INLINE empty #-}+  empty = failWithContext "empty"++  {-# INLINE (<|>) #-}+  a <|> b = Parse (either (const (unParse b)) return =<< try (unParse a))++instance MonadPlus Parse where+  {-# INLINE mzero #-}+  mzero = failWithContext "mzero"++  {-# INLINE mplus #-}+  mplus = (<|>)++runParse :: Parse a -> Either Error a+runParse (Parse m) = case runM m emptyEnv emptyParseState of+  Left err    -> Left err+  Right (a,_) -> Right a++notImplemented :: Parse a+notImplemented  = fail "not implemented"++-- Parse State -----------------------------------------------------------------++data ParseState = ParseState+  { psTypeTable     :: TypeTable+  , psTypeTableSize :: !Int+  , psValueTable    :: ValueTable+  , psMdTable       :: ValueTable+  , psMdRefs        :: MdRefTable+  , psFunProtos     :: Seq.Seq FunProto+  , psNextResultId  :: !Int+  , psTypeName      :: Maybe String+  , psNextTypeId    :: !Int+  , psLastLoc       :: Maybe PDebugLoc+  } deriving (Show)++-- | The initial parsing state.+emptyParseState :: ParseState+emptyParseState  = ParseState+  { psTypeTable     = Map.empty+  , psTypeTableSize = 0+  , psValueTable    = emptyValueTable False+  , psMdTable       = emptyValueTable False+  , psMdRefs        = Map.empty+  , psFunProtos     = Seq.empty+  , psNextResultId  = 0+  , psTypeName      = Nothing+  , psNextTypeId    = 0+  , psLastLoc       = Nothing+  }++-- | The next implicit result id.+nextResultId :: Parse Int+nextResultId  = Parse $ do+  ps <- get+  set ps { psNextResultId = psNextResultId ps + 1 }+  return (psNextResultId ps)++type PDebugLoc = DebugLoc' Int++setLastLoc :: PDebugLoc -> Parse ()+setLastLoc loc = Parse $ do+  ps <- get+  set $! ps { psLastLoc = Just loc }++setRelIds :: Bool -> Parse ()+setRelIds b = Parse $ do+  ps <- get+  set $! ps { psValueTable = (psValueTable ps) { valueRelIds = b }}++getRelIds :: Parse Bool+getRelIds  = Parse $ do+  ps <- get+  return (valueRelIds (psValueTable ps))++getLastLoc :: Parse PDebugLoc+getLastLoc  = Parse $ do+  ps <- get+  case psLastLoc ps of+    Just loc -> return loc+    Nothing  -> fail "No last location available"++-- | Sort of a hack to preserve state between function body parses.  It would+-- really be nice to separate this into a different monad, that could just run+-- under the Parse monad, but sort of unnecessary in the long run.+enterFunctionDef :: Parse a -> Parse a+enterFunctionDef m = Parse $ do+  ps  <- get+  set ps+    { psNextResultId = 0+    }+  res <- unParse m+  ps' <- get+  set ps'+    { psValueTable = psValueTable ps+    , psMdTable    = psMdTable ps+    , psMdRefs     = psMdRefs ps+    , psLastLoc    = Nothing+    }+  return res+++-- Type Table ------------------------------------------------------------------++type TypeTable = Map.Map Int Type++-- | Generate a type table, and a type symbol table.+mkTypeTable :: [Type] -> TypeTable+mkTypeTable  = Map.fromList . zip [0 ..]++data BadForwardRef+  = BadTypeRef [String] Int+  | BadValueRef [String] Int+    deriving (Show,Typeable)++instance X.Exception BadForwardRef++badRefError :: BadForwardRef -> Error+badRefError ref = case ref of+  BadTypeRef  c i -> Error c ("bad forward reference to type: " ++ show i)+  BadValueRef c i -> Error c ("bad forward reference to value: " ++ show i)++-- | As type tables are always pre-allocated, looking things up should never+-- fail.  As a result, the worst thing that could happen is that the type entry+-- causes a runtime error.  This is pretty bad, but it's an acceptable trade-off+-- for the complexity of the forward references in the type table.+lookupTypeRef :: [String] -> Int -> TypeTable -> Type+lookupTypeRef cxt n = fromMaybe (X.throw (BadTypeRef cxt n)) . Map.lookup n++setTypeTable :: TypeTable -> Parse ()+setTypeTable table = Parse $ do+  ps <- get+  set ps { psTypeTable = table }++getTypeTable :: Parse TypeTable+getTypeTable  = Parse (psTypeTable <$> get)++setTypeTableSize :: Int -> Parse ()+setTypeTableSize n = Parse $ do+  ps <- get+  set ps { psTypeTableSize = n }++-- | Retrieve the current type name, failing if it hasn't been set.+getTypeName :: Parse Ident+getTypeName  = Parse $ do+  ps  <- get+  str <- case psTypeName ps of+    Just tn -> do+      set ps { psTypeName = Nothing }+      return tn+    Nothing -> do+      set ps { psNextTypeId = psNextTypeId ps + 1 }+      return (show (psNextTypeId ps))+  return (Ident str)++setTypeName :: String -> Parse ()+setTypeName name = Parse $ do+  ps <- get+  set ps { psTypeName = Just name }++-- | Lookup the value of a type; don't attempt to resolve to an alias.+getType' :: Int -> Parse Type+getType' ref = do+  ps <- Parse get+  unless (ref < psTypeTableSize ps)+    (fail ("type reference " ++ show ref ++ " is too large"))+  cxt <- getContext+  return (lookupTypeRef cxt ref (psTypeTable ps))++-- | Test to see if the type table has been added to already.+isTypeTableEmpty :: Parse Bool+isTypeTableEmpty  = Parse (Map.null . psTypeTable <$> get)+++-- Value Tables ----------------------------------------------------------------++-- | Values that have an identifier instead of a string label+type PValue = Value' Int++type PInstr = Instr' Int++data ValueTable = ValueTable+  { valueNextId  :: !Int+  , valueEntries :: Map.Map Int (Typed PValue)+  , valueRelIds  :: Bool+  } deriving (Show)++emptyValueTable :: Bool -> ValueTable+emptyValueTable rel = ValueTable+  { valueNextId  = 0+  , valueEntries = Map.empty+  , valueRelIds  = rel+  }++addValue :: Typed PValue -> ValueTable -> ValueTable+addValue tv vs = snd (addValue' tv vs)++addValue' :: Typed PValue -> ValueTable -> (Int,ValueTable)+addValue' tv vs = (valueNextId vs,vs')+  where+  vs' = vs+    { valueNextId  = valueNextId vs + 1+    , valueEntries = Map.insert (valueNextId vs) tv (valueEntries vs)+    }++-- | Push a value into the value table, and return its index.+pushValue :: Typed PValue -> Parse Int+pushValue tv = Parse $ do+  ps <- get+  let vt = psValueTable ps+  set ps { psValueTable = addValue tv vt }+  return (valueNextId vt)++-- | Get the index for the next value.+nextValueId :: Parse Int+nextValueId  = Parse (valueNextId . psValueTable <$> get)++-- | Depending on whether or not relative ids are in use, adjust the id.+adjustId :: Int -> Parse Int+adjustId n = do+  vt <- getValueTable+  return (translateValueId vt n)++-- | Translate an id, relative to the value table it references.+translateValueId :: ValueTable -> Int -> Int+translateValueId vt n | valueRelIds vt = fromIntegral adjusted+                      | otherwise      = n+  where+  adjusted :: Word32+  adjusted  = fromIntegral (valueNextId vt - n)++-- | Lookup an absolute address in the value table.+lookupValueTableAbs :: Int -> ValueTable -> Maybe (Typed PValue)+lookupValueTableAbs n values = Map.lookup n (valueEntries values)++-- | When you know you have an absolute index.+lookupValueAbs :: Int -> Parse (Maybe (Typed PValue))+lookupValueAbs n = lookupValueTableAbs n `fmap` getValueTable++-- | Lookup either a relative id, or an absolute id.+lookupValueTable :: Int -> ValueTable -> Maybe (Typed PValue)+lookupValueTable n values =+  lookupValueTableAbs (translateValueId values n) values++-- | Lookup a value in the value table.+lookupValue :: Int -> Parse (Maybe (Typed PValue))+lookupValue n = lookupValueTable n `fmap` getValueTable++-- | Lookup lazily, hiding an error in the result if the entry doesn't exist by+-- the time it's needed.  NOTE: This always looks up an absolute index, never a+-- relative one.+forwardRef :: [String] -> Int -> ValueTable -> Typed PValue+forwardRef cxt n vt =+  fromMaybe (X.throw (BadValueRef cxt n)) (lookupValueTableAbs n vt)++-- | Require that a value be present.+requireValue :: Int -> Parse (Typed PValue)+requireValue n = do+  mb <- lookupValue n+  case mb of+    Just tv -> return tv+    Nothing -> fail ("value " ++ show n ++ " is not defined")++-- | Get the current value table.+getValueTable :: Parse ValueTable+getValueTable  = Parse (psValueTable <$> get)++-- | Retrieve the name for the next value.  Note that this doesn't assume that+-- the name gets used, and doesn't update the next id in the value table.+getNextId :: Parse Int+getNextId  = valueNextId <$> getValueTable++-- | Set the current value table.+setValueTable :: ValueTable -> Parse ()+setValueTable vt = Parse $ do+  ps <- get+  set ps { psValueTable = vt }++-- | Update the value table, giving a lazy reference to the final table.+fixValueTable :: (ValueTable -> Parse (a,[Typed PValue])) -> Parse a+fixValueTable k = do+  vt <- getValueTable+  rec let vt' = foldr addValue vt vs+      (a,vs) <- k vt'+  setValueTable vt'+  return a++fixValueTable_ :: (ValueTable -> Parse [Typed PValue]) -> Parse ()+fixValueTable_ k = fixValueTable $ \ vt -> do+  vs <- k vt+  return ((),vs)+++type PValMd = ValMd' Int++type MdTable = ValueTable++getMdTable :: Parse MdTable+getMdTable  = Parse (psMdTable <$> get)++setMdTable :: MdTable -> Parse ()+setMdTable md = Parse $ do+  ps <- get+  set $! ps { psMdTable = md }++getMetadata :: Int -> Parse (Typed PValMd)+getMetadata ix = do+  ps <- Parse get+  case resolveMd ix ps of+    Just tv -> case typedValue tv of+      ValMd val -> return tv { typedValue = val }+      _         -> fail "unexpected non-metadata value in metadata table"+    Nothing -> fail ("metadata index " ++ show ix ++ " is not defined")++resolveMd :: Int -> ParseState -> Maybe (Typed PValue)+resolveMd ix ps = nodeRef `mplus` mdValue+  where+  reference = Typed (PrimType Metadata) . ValMd . ValMdRef+  nodeRef   = reference `fmap` Map.lookup ix (psMdRefs ps)+  mdValue   = Map.lookup ix (valueEntries (psMdTable ps))+++type MdRefTable = Map.Map Int Int++setMdRefs :: MdRefTable -> Parse ()+setMdRefs refs = Parse $ do+  ps <- get+  set $! ps { psMdRefs = refs `Map.union` psMdRefs ps }+++-- Function Prototypes ---------------------------------------------------------++data FunProto = FunProto+  { protoType  :: Type+  , protoAttrs :: FunAttrs+  , protoName  :: String+  , protoIndex :: Int+  } deriving (Show)++-- | Push a function prototype on to the prototype stack.+pushFunProto :: FunProto -> Parse ()+pushFunProto p = Parse $ do+  ps <- get+  set ps { psFunProtos = psFunProtos ps Seq.|> p }++-- | Take a single function prototype off of the prototype stack.+popFunProto :: Parse FunProto+popFunProto  = do+  ps <- Parse get+  case Seq.viewl (psFunProtos ps) of+    Seq.EmptyL   -> fail "empty function prototype stack"+    p Seq.:< ps' -> do+      Parse (set ps { psFunProtos = ps' })+      return p+++-- Parsing Environment ---------------------------------------------------------++data Env = Env+  { envSymtab  :: Symtab+  , envContext :: [String]+  } deriving Show++emptyEnv :: Env+emptyEnv  = Env+  { envSymtab  = mempty+  , envContext = mempty+  }++-- | Extend the symbol table for an environment, yielding a new environment.+extendSymtab :: Symtab -> Env -> Env+extendSymtab symtab env = env { envSymtab = envSymtab env `mappend` symtab }++-- | Add a label to the context of an environment, yielding a new environment.+addLabel :: String -> Env -> Env+addLabel l env = env { envContext = l : envContext env }++getContext :: Parse [String]+getContext  = Parse (envContext `fmap` ask)+++data Symtab = Symtab+  { symValueSymtab :: ValueSymtab+  , symTypeSymtab  :: TypeSymtab+  } deriving (Show)++instance Monoid Symtab where+  mempty = Symtab+    { symValueSymtab = emptyValueSymtab+    , symTypeSymtab  = mempty+    }++  mappend l r = Symtab+    { symValueSymtab = symValueSymtab l `Map.union` symValueSymtab r+    , symTypeSymtab  = symTypeSymtab  l `mappend`   symTypeSymtab  r+    }++withSymtab :: Symtab -> Parse a -> Parse a+withSymtab symtab body = Parse $ do+  env <- ask+  local (extendSymtab symtab env) (unParse body)++-- | Run a computation with an extended value symbol table.+withValueSymtab :: ValueSymtab -> Parse a -> Parse a+withValueSymtab symtab = withSymtab (mempty { symValueSymtab = symtab })++-- | Retrieve the value symbol table.+getValueSymtab :: Parse ValueSymtab+getValueSymtab  = Parse (symValueSymtab . envSymtab <$> ask)++-- | Run a computation with an extended type symbol table.+withTypeSymtab :: TypeSymtab -> Parse a -> Parse a+withTypeSymtab symtab = withSymtab (mempty { symTypeSymtab = symtab })++-- | Retrieve the type symbol table.+getTypeSymtab :: Parse TypeSymtab+getTypeSymtab  = Parse (symTypeSymtab . envSymtab <$> ask)++-- | Label a sub-computation with its context.+label :: String -> Parse a -> Parse a+label l m = Parse $ do+  env <- ask+  local (addLabel l env) (unParse m)++-- | Fail, taking into account the current context.+failWithContext :: String -> Parse a+failWithContext msg = Parse $ do+  env <- ask+  raise Error+    { errMessage = msg+    , errContext = envContext env+    }++-- | Attempt to find the type id in the type symbol table, when that fails,+-- look it up in the type table.+getType :: Int -> Parse Type+getType ref = do+  symtab <- getTypeSymtab+  case Map.lookup ref (tsById symtab) of+    Just i  -> return (Alias i)+    Nothing -> getType' ref++-- | Find the id associated with a type alias.+getTypeId :: Ident -> Parse Int+getTypeId n = do+  symtab <- getTypeSymtab+  case Map.lookup n (tsByName symtab) of+    Just ix -> return ix+    Nothing -> fail ("unknown type alias " ++ show (ppIdent n))+++-- Value Symbol Table ----------------------------------------------------------++type SymName = Either String Int++type ValueSymtab = Map.Map SymTabEntry SymName++data SymTabEntry+  = SymTabEntry !Int+  | SymTabBBEntry !Int+    deriving (Eq,Ord,Show)++renderName :: SymName -> String+renderName  = either id show++mkBlockLabel :: SymName -> BlockLabel+mkBlockLabel  = either (Named . Ident) Anon++emptyValueSymtab :: ValueSymtab+emptyValueSymtab  = Map.empty++addEntry :: Int -> String -> ValueSymtab -> ValueSymtab+addEntry i n = Map.insert (SymTabEntry i) (Left n)++addBBEntry :: Int -> String -> ValueSymtab -> ValueSymtab+addBBEntry i n = Map.insert (SymTabBBEntry i) (Left n)++addBBAnon :: Int -> Int -> ValueSymtab -> ValueSymtab+addBBAnon i n = Map.insert (SymTabBBEntry i) (Right n)++-- | Lookup the name of an entry.+entryName :: Int -> Parse String+entryName n = do+  symtab <- getValueSymtab+  case Map.lookup (SymTabEntry n) symtab of+    Just i  -> return (renderName i)+    Nothing -> fail ("entry " ++ show n ++ " is missing from the symbol table"+             ++ "\n" ++ show symtab)++-- | Lookup the name of a basic block.+bbEntryName :: Int -> Parse (Maybe BlockLabel)+bbEntryName n = do+  symtab <- getValueSymtab+  return (mkBlockLabel <$> Map.lookup (SymTabBBEntry n) symtab)++-- | Lookup the name of a basic block.+requireBbEntryName :: Int -> Parse BlockLabel+requireBbEntryName n = do+  mb <- bbEntryName n+  case mb of+    Just l  -> return l+    Nothing -> fail ("basic block " ++ show n ++ " has no id")+++-- Type Symbol Tables ----------------------------------------------------------++data TypeSymtab = TypeSymtab+  { tsById   :: Map.Map Int Ident+  , tsByName :: Map.Map Ident Int+  } deriving Show++instance Monoid TypeSymtab where+  mempty = TypeSymtab+    { tsById   = Map.empty+    , tsByName = Map.empty+    }++  mappend l r = TypeSymtab+    { tsById   = tsById   l `Map.union` tsById r+    , tsByName = tsByName l `Map.union` tsByName r+    }++addTypeSymbol :: Int -> Ident -> TypeSymtab -> TypeSymtab+addTypeSymbol ix n ts = ts+  { tsById   = Map.insert ix n (tsById ts)+  , tsByName = Map.insert n ix (tsByName ts)+  }

@@ -0,0 +1,130 @@+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 Data.Bits (Bits,testBit,shiftR,bit)+import Data.Char (chr)+import Control.Monad ((<=<),MonadPlus(..),guard)+++-- 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+  guard (not (null (abbrevFields a)))+  let (f:fs) = 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 Char+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++type LookupField a = Int -> Match Field a -> Parse a++-- | 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+    [ "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+        ["unable to parse record field", show n, "of record", show r]++  loop []     = return []++-- | Parse a @Field@ as a numeric value.+numeric :: Num a => Match Field a+numeric  = fmap fromBitString . (fieldLiteral ||| fieldFixed ||| fieldVbr)++-- | Parse a @Field@ as a sign-encoded number.+signed :: (Bits a, Num a) => Match Field a+signed  = 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++boolean :: Match Field Bool+boolean  = decode <=< (fieldFixed ||| fieldLiteral ||| fieldVbr)+  where+  decode bs+    | bsData bs == 1 = return True+    | bsData bs == 0 = return False+    | otherwise      = mzero++char :: Match Field Char+char  = fmap chr . numeric++string :: Match Field String+string  = fieldArray (fmap chr . numeric)++cstring :: Match Field String+cstring  = fieldArray (fieldChar6 ||| char)

@@ -0,0 +1,254 @@+{- |+Module           : $Header$+Description      : LLVM control flow graphs and related utilities+Stability        : provisional+Point-of-contact : jstanley+-}+{-# LANGUAGE BangPatterns                #-}+{-# LANGUAGE EmptyDataDecls              #-}+{-# LANGUAGE OverloadedStrings           #-}+{-# LANGUAGE ScopedTypeVariables         #-}+{-# LANGUAGE ViewPatterns                #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Data.LLVM.CFG+  ( CFG(..)+  , BB+  , BBId+  , blockId+  , blockName+  , buildCFG+  , dummyExitName+  )+where++import           Control.Applicative+import           Control.Arrow++import qualified Data.Graph.Inductive.Query.Dominators as Dom+import qualified Data.Graph.Inductive                  as G+import qualified Data.Map                              as M++import           Text.LLVM                             hiding (BB)++-- import Debug.Trace++newtype BBId = BBId { unBBId :: G.Node } deriving (Eq)++type BB = BasicBlock' (BBId, BlockLabel)++-- | The control-flow graph for LLVM functions+data CFG = CFG+  { cfgGraph :: G.Gr BB ()+  -- | The @BBId@ of the entry node in the control-flow graph+  , entryId :: BBId+  -- | The @BBId@ of the exit node from the control-flow graph+  , exitId :: BBId+  -- | All basic blocks in the CFG+  , allBBs :: [BB]+  -- | Obtain a basic block from a @BBId@ (runtime error if it DNE)+  , bbById :: BBId -> BB+  -- | Obtain the @BBId@ of a block from its name (runtime error if it DNE)+  , asId :: BlockLabel -> BBId+  -- | Obtain the name of a block from a @BBId@ (runtime error if it DNE)+  , asName :: BBId -> BlockLabel+  -- | Obtain all predecessor basic blocks from a @BBId@+  , bbPreds :: BBId -> [BBId]+  -- | Obtain all successor basic blocks from a @BBId@+  , bbSuccs :: BBId -> [BBId]+  -- | @dom x y@ yields True iff x dominates y in the CFG (i.e., all paths from+  -- the entry node to y must pass through x)+  , dom :: BBId -> BBId -> Bool+  -- | @idom x@ yields the unique immediate dominator of x in the CFG+  -- (intuitively, the "nearest" dominator of x; formally, y immediately+  -- dominates x iff y dominates x and there is no intervening block z such that+  -- y dominates z and z dominates x).  The entry node has no immediate+  -- dominator.+  , idom :: BBId -> Maybe BBId+    -- | @pdom x y@ yields True iff x postdominates y in the CFG (i.e., all+    -- paths in the CFG from y to the exit node pass through x)+  , pdom :: BBId -> BBId -> Bool+    -- | @ipdom x@ yields the unique immediate postdominator of x in the CFG+    -- (intuitively, the "nearest" postdominator; formally, y immediately+    -- postdominates x iff y postdominates x and there is no intervening block z+    -- such that y postdominates z and z postdominates x).  The exit node has no+    -- immediate postdominator.+  , ipdom :: BBId -> Maybe BBId+    -- | @pdom@ yields post-dominator analysis for the entire CFG; the resulting+    -- list associates each node with a list of its postdominators.  The+    -- postdominator list is sorted in order of ascending immediacy; i.e., the+    -- last element of the list associated with a node @n@ is @n@'s immediate+    -- dominator, the penultimate element of the list is the immediate+    -- postdominator of @n@'s immediate postdominator, and so forth.  NB: note+    -- the postdominator lists do not explicitly reflect that a node+    -- postdominates itself.+  , pdoms :: [(BBId, [BBId])]+  }++dummyExitName :: String+dummyExitName = "_dummy_exit"++-- | Builds the control-flow graph of a function.  Assumes that the entry node+-- is the first basic block in the list. Note that when multiple exit nodes are+-- present in the list, they will all end up connected to a single, unique+-- "dummy" exit node.  Note, also, that the CFG basic blocks are of type+-- @BasicBlock' (BBId, Ident)@; that is, they are all named, which is not the+-- case with the input BBs.  It is expected that clients use these versions of+-- the basic blocks rather than those that are passed in.+buildCFG :: [BasicBlock] -> CFG+buildCFG bs = cfg+  where+    cfg = CFG+          { cfgGraph = gr+          , entryId  = BBId 0+          , exitId   = BBId (either id id exit)+          , allBBs   = getBBs gr (G.nodes gr)++          , bbById   = \(BBId x) ->+                       case bbFromCtx <$> fst (G.match x gr) of+                         Nothing -> error "buildCFG: bbById: invalid BBId"+                         Just bb -> bb++          , asId     = \ident ->+                       case BBId <$> M.lookup ident nodeByName of+                         Nothing   -> error "buildCFG: asId: invalid ident"+                         Just bbid -> bbid++          , asName   = \bbid              -> blockName $ bbById cfg bbid+          , bbPreds  = \(BBId x)          -> BBId <$> G.pre gr x+          , bbSuccs  = \(BBId x)          -> BBId <$> G.suc gr x+          , dom      = \(BBId x) (BBId y) -> lkupDom domInfo x y+          , idom     = \(BBId x)          -> BBId <$> lookup x idomInfo+          , pdom     = \(BBId x) (BBId y) -> lkupDom pdomInfo x y+          , ipdom    = \(BBId x)          -> BBId <$> lookup x ipdomInfo+          , pdoms    = map (BBId *** map BBId . reverse . drop 1) pdomInfo+          }++    -- Dominance and post-dominance relations+    cdom g (BBId root)    = (Dom.dom g root, Dom.iDom g root)+    (domInfo, idomInfo)   = cdom gr          (entryId cfg)+    (pdomInfo, ipdomInfo) = cdom (G.grev gr) (exitId cfg)+    lkupDom info x y      = maybe False id (elem x <$> lookup y info)++    -- Graph construction+    (exit, gr)    = stitchDummyExit lab (G.mkGraph nodes' edges')+                      where lab n = BasicBlock (BBId n, Named $ Ident dummyExitName)+                                      [Effect Unreachable []]+    nodes'        = map (nodeId &&& id) bs'+    edges'        = concatMap bbOutEdges bs'+    bbOutEdges bb = edgesTo (brTargets bb)+      where+        edgesTo  = map (\tgt -> nodeId bb `to` lkup tgt)+        lkup x   = maybe (err x) id (M.lookup x nodeByName)+        err x    = error $ "Data.LLVM.CFG internal: "+                           ++ "failed to find ident "+                           ++ show (ppLabel x)+                           ++ " in name map"++    -- Relabeling and aux data structures; note that unnamed basic blocks get a+    -- generated name here so that clients don't have to deal with extraneous+    -- checks.+    (nodeByName, bs', _, _) = foldr relabel (M.empty, [], length bs - 1, 0) bs+      where+        relabel (BasicBlock mid stmts) (mp, acc, n, s :: Int) =+--           trace ("relabel: mid = " ++ show mid)+--           $+          let (s', nm) = case mid of+                           Nothing ->  (s + 1, Named $ Ident $ "__anon_" ++ show s)+                           Just nm' -> (s, nm')+          in+            ( M.insert nm n mp+            , BasicBlock (BBId n, nm) stmts : acc+            , n - 1+            , s'+            )++--------------------------------------------------------------------------------+-- Utility functions++bbFromCtx :: G.Context BB () -> BB+bbFromCtx (_, _, bb, _) = bb++to :: G.Node -> G.Node -> G.LEdge ()+u `to` v = (u, v, ())++blockId :: BB -> BBId+blockId = fst . bbLabel++blockName :: BB -> BlockLabel+blockName = snd . bbLabel++nodeId :: BB -> G.Node+nodeId = unBBId . blockId++getBBs :: G.Gr BB () -> [G.Node] -> [BB]+getBBs gr ns =+  case mapM (G.lab gr) ns of+    Just bbs -> bbs+    Nothing  -> error "internal: encountered unlabeled node"++newNode :: G.Graph gr => gr a b -> G.Node+newNode = head . G.newNodes 1++exitNodes :: G.DynGraph gr => gr a b -> [G.Node]+exitNodes gr = map G.node' $ G.gsel (null . G.suc gr . G.node') gr++-- | @stitchDummyExit labf gr@ adds to graph @gr@ a dummy terminal node with a+-- caller-generated label (parameterized by the new exit node id) and connects+-- all other terminal nodes to it, if needed.  The first element of the returned+-- tuple is the id of the exit node (Left: already present, Right: added). The+-- second element of the returned tuple is the (un)modified graph.++stitchDummyExit :: G.DynGraph gr =>+                   (G.Node -> a) -> gr a () -> (Either G.Node G.Node, gr a ())+stitchDummyExit exitLabelF gr = case exitNodes gr of+  []    -> error "internal: input graph contains no exit nodes"+  [n]   -> (Left n, gr)+  exits ->+    let new = newNode gr+        !g0 = G.insNode (new, exitLabelF new) gr+        !g1 = foldr G.insEdge g0 $ map (`to` new) exits+    in (Right new, g1)++instance Show CFG where+  show cfg = unlines [ "Entry : " ++ show (entryId cfg)+                     , "Exit  : " ++ show (exitId cfg)+                     , "Graph : " ++ ( unlines+                                     . map (\s -> replicate 8 ' ' ++ s)+                                     . lines+                                     $ show (cfgGraph cfg)+                                     )+                     ]++instance Show BBId where show (BBId n) = "BB#" ++ show n++--------------------------------------------------------------------------------+-- Debug pretty printing++ppBBBrief :: BasicBlock' (G.Node, Maybe Ident) -> String+ppBBBrief (BasicBlock (n, mid) _) =+  "BB#"+  ++ show n+  ++ (maybe "" (\ident -> " (" ++ show (ppIdent ident) ++ ")") mid)++ppCtxBrief :: G.Context (BasicBlock' (G.Node, Maybe Ident)) () -> String+ppCtxBrief (p, n, bb, s) = show (p, n, ppBBBrief bb, s)++--------------------------------------------------------------------------------+-- Testing++test :: Module -> CFG+test m = buildCFG blks where [defBody -> blks] = modDefines m++-- Very cursory check for now+domSanity :: Module -> Bool+domSanity m =+  and $ map (\x -> dom cfg (entryId cfg) (blockId x)) (allBBs cfg)+        +++        map (\x -> pdom cfg (exitId cfg) (blockId x)) (allBBs cfg)+  where+    cfg = test m++_nowarn_unused :: forall t. t+_nowarn_unused = undefined+  test domSanity ppBBBrief ppCtxBrief