llvm-pretty-bc-parser 0.4.2.0 → 0.5.0.0

raw patch · 13 files changed

+703/−180 lines, 13 filesdep ~llvm-prettynew-uploaderPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: llvm-pretty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• disasm-test/Main.hs +16/−9
• disasm-test/tests/localstatic.ll +146/−0
• doc/developing.md +100/−0
• llvm-disasm/LLVMDis.hs +7/−5
• llvm-pretty-bc-parser.cabal +3/−3
• src/Data/LLVM/BitCode.hs +111/−8
• src/Data/LLVM/BitCode/IR/Function.hs +23/−44
• src/Data/LLVM/BitCode/IR/Globals.hs +5/−5
• src/Data/LLVM/BitCode/IR/Metadata.hs +29/−32
• src/Data/LLVM/BitCode/IR/Module.hs +22/−20
• src/Data/LLVM/BitCode/IR/Values.hs +5/−3
• src/Data/LLVM/BitCode/Parse.hs +223/−51

@@ -1,5 +1,18 @@ # Revision history for llvm-pretty-bc-parser +## 0.5.0.0 (March 2025)++* `Data.LLVM.BitCode` now defines funtions (whose names all end with+  `*WithWarnings`) that return any parser-related warnings (`ParseWarning`s)+  alongside the parsed `Module`. Users can decide whether or not to display+  these warnings (e.g., by printing them to `stderr` using `ppParseWarnings`).++  The existing functions which do not return warnings have been deprecated in+  favor of the their `*WithWarnings` variants.+* The functions in `Data.LLVM.BitCode` no longer produce a fatal error when+  encountering metadata records of unexpected sizes. Instead, these are now+  treated as warnings.+ ## 0.4.2.0 (August 2024)  * Add support for GHC 9.8 and drop official support of 9.2.

@@ -6,7 +6,9 @@  module Main where -import           Data.LLVM.BitCode (parseBitCodeLazyFromFile,Error(..),formatError)+import           Data.LLVM.BitCode (parseBitCodeLazyFromFileWithWarnings,+                                    Error(..),formatError,+                                    ParseWarning,ppParseWarnings) import qualified Text.LLVM.AST as AST import           Text.LLVM.PP ( ppLLVM, ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38, llvmPP ) @@ -25,6 +27,7 @@ import qualified Data.Map as Map import           Data.Maybe ( fromMaybe ) import           Data.Proxy ( Proxy(..) )+import           Data.Sequence ( Seq ) import           Data.String.Interpolate import qualified Data.Text as T import           Data.Typeable (Typeable)@@ -39,7 +42,8 @@                                   , removeFile ) import           System.Exit (ExitCode(..), exitFailure, exitSuccess) import           System.FilePath ( (</>), (<.>) )-import           System.IO (openBinaryTempFile,hClose,openTempFile,hPutStrLn)+import           System.IO (openBinaryTempFile,hClose,openTempFile,hPrint,+                            hPutStrLn,stderr) import qualified System.IO as IO (stderr) import qualified System.Process as Proc import           Test.Tasty@@ -460,13 +464,13 @@ diffCmp :: FilePath -> FilePath -> TestM () diffCmp file1 file2 = do   let assertF = liftIO . assertFailure . unlines-  (code, stdout, stderr) <- liftIO $+  (code, stdOut, stdErr) <- liftIO $     Proc.readCreateProcessWithExitCode (Proc.proc "diff" ["-u", file1, file2]) ""   case code of-    ExitFailure _ -> assertF ["diff failed", stdout, stderr]+    ExitFailure _ -> assertF ["diff failed", stdOut, stdErr]     ExitSuccess   ->-      if stdout /= "" || stderr /= ""-      then assertF ["non-empty diff", stdout, stderr]+      if stdOut /= "" || stdErr /= ""+      then assertF ["non-empty diff", stdOut, stdErr]       else do Details det <- gets showDetails               when det $ liftIO                 $ mapM_ putStrLn ["success: empty diff: ", file1, file2]@@ -723,7 +727,8 @@ -- fails. processBitCode :: FilePath -> FilePath -> TestM (FilePath, Maybe FilePath) processBitCode pfx file = do-  let handler :: X.SomeException -> IO (Either Error AST.Module)+  let handler ::+        X.SomeException -> IO (Either Error (AST.Module, Seq ParseWarning))       handler se = return (Left (Error [] (show se)))       printToTempFile sufx stuff = do         tmp        <- getTemporaryDirectory@@ -731,10 +736,12 @@         hPutStrLn h stuff         hClose h         return parsed-  e <- liftIO $ parseBitCodeLazyFromFile file `X.catch` handler+  e <- liftIO $ parseBitCodeLazyFromFileWithWarnings file `X.catch` handler   case e of     Left err -> X.throwM (ParseError err)-    Right m  -> do+    Right (m, warnings) -> do+      unless (null warnings) $+        liftIO $ hPrint stderr $ ppParseWarnings warnings       let m' = AST.fixupOpaquePtrs m       postParseTests m'       llvmVersion <- gets llvmVer

@@ -0,0 +1,146 @@+; ModuleID = 'localstatic.bc'+source_filename = "localstatic.c"+target datalayout = "e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128"+target triple = "x86_64-unknown-linux-gnu"++@has_local_static.disptab = internal constant [3 x i8*] [i8* blockaddress(@has_local_static, %10), i8* blockaddress(@has_local_static, %17), i8* blockaddress(@has_local_static, %20)], align 16, !dbg !0+@.str = private unnamed_addr constant [6 x i8] c"= %d\0A\00", align 1++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define i32 @has_local_static(i32 %0) #0 !dbg !2 {+  %2 = alloca i32, align 4+  %3 = alloca i32, align 4+  store i32 %0, i32* %2, align 4+  call void @llvm.dbg.declare(metadata i32* %2, metadata !21, metadata !DIExpression()), !dbg !22+  call void @llvm.dbg.declare(metadata i32* %3, metadata !23, metadata !DIExpression()), !dbg !24+  %4 = load i32, i32* %2, align 4, !dbg !25+  store i32 %4, i32* %3, align 4, !dbg !26+  br label %5, !dbg !27++5:                                                ; preds = %17, %1+  call void @llvm.dbg.label(metadata !28), !dbg !29+  %6 = load i32, i32* %3, align 4, !dbg !30+  %7 = sext i32 %6 to i64, !dbg !31+  %8 = getelementptr [3 x i8*], [3 x i8*]* @has_local_static.disptab, i64 0, i64 %7, !dbg !31+  %9 = load i8*, i8** %8, align 8, !dbg !31+  br label %22, !dbg !32++10:                                               ; preds = %22+  call void @llvm.dbg.label(metadata !33), !dbg !34+  %11 = load i32, i32* %3, align 4, !dbg !35+  %12 = add i32 %11, 1, !dbg !35+  store i32 %12, i32* %3, align 4, !dbg !35+  %13 = load i32, i32* %3, align 4, !dbg !36+  %14 = sext i32 %13 to i64, !dbg !37+  %15 = getelementptr [3 x i8*], [3 x i8*]* @has_local_static.disptab, i64 0, i64 %14, !dbg !37+  %16 = load i8*, i8** %15, align 8, !dbg !37+  br label %22, !dbg !38++17:                                               ; preds = %22+  call void @llvm.dbg.label(metadata !39), !dbg !40+  %18 = load i32, i32* %3, align 4, !dbg !41+  %19 = mul i32 %18, 3, !dbg !41+  store i32 %19, i32* %3, align 4, !dbg !41+  br label %5, !dbg !42++20:                                               ; preds = %22+  call void @llvm.dbg.label(metadata !43), !dbg !44+  %21 = load i32, i32* %3, align 4, !dbg !45+  ret i32 %21, !dbg !46++22:                                               ; preds = %10, %5+  %23 = phi i8* [ %9, %5 ], [ %16, %10 ]+  indirectbr i8* %23, [label %10, label %17, label %20]+}++; Function Attrs: nounwind readnone speculatable willreturn+declare void @llvm.dbg.declare(metadata, metadata, metadata) #1++; Function Attrs: nounwind readnone speculatable willreturn+declare void @llvm.dbg.label(metadata) #1++; Function Attrs: noinline nounwind optnone sspstrong uwtable+define i32 @main(i32 %0, i8** %1) #0 !dbg !47 {+  %3 = alloca i32, align 4+  %4 = alloca i8**, align 8+  store i32 %0, i32* %3, align 4+  call void @llvm.dbg.declare(metadata i32* %3, metadata !53, metadata !DIExpression()), !dbg !54+  store i8** %1, i8*** %4, align 8+  call void @llvm.dbg.declare(metadata i8*** %4, metadata !55, metadata !DIExpression()), !dbg !56+  %5 = load i32, i32* %3, align 4, !dbg !57+  %6 = call i32 @has_local_static(i32 %5), !dbg !58+  %7 = call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([6 x i8], [6 x i8]* @.str, i64 0, i64 0), i32 %6), !dbg !59+  ret i32 0, !dbg !60+}++declare i32 @printf(i8*, ...) #2++attributes #0 = { noinline nounwind optnone sspstrong uwtable "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "frame-pointer"="all" "less-precise-fpmad"="false" "min-legal-vector-width"="0" "no-infs-fp-math"="false" "no-jump-tables"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="true" "stack-protector-buffer-size"="4" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }+attributes #1 = { nounwind readnone speculatable willreturn }+attributes #2 = { "correctly-rounded-divide-sqrt-fp-math"="false" "disable-tail-calls"="false" "frame-pointer"="all" "less-precise-fpmad"="false" "no-infs-fp-math"="false" "no-nans-fp-math"="false" "no-signed-zeros-fp-math"="false" "no-trapping-math"="true" "stack-protector-buffer-size"="4" "target-cpu"="x86-64" "target-features"="+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "unsafe-fp-math"="false" "use-soft-float"="false" }++!llvm.dbg.cu = !{!7}+!llvm.module.flags = !{!16, !17, !18, !19}+!llvm.ident = !{!20}++!0 = !DIGlobalVariableExpression(var: !1, expr: !DIExpression())+!1 = distinct !DIGlobalVariable(name: "disptab", scope: !2, file: !3, line: 7, type: !10, isLocal: true, isDefinition: true)+!2 = distinct !DISubprogram(name: "has_local_static", scope: !3, file: !3, line: 5, type: !4, scopeLine: 5, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !7, retainedNodes: !8)+!3 = !DIFile(filename: "localstatic.c", directory: "/home/kquick/work/DFAMS/tp241209/sources/llvm-pretty-bc-parser/disasm-test/tests")+!4 = !DISubroutineType(types: !5)+!5 = !{!6, !6}+!6 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!7 = distinct !DICompileUnit(language: DW_LANG_C99, file: !3, producer: "clang version 11.1.0", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !8, globals: !9, splitDebugInlining: false, nameTableKind: None)+!8 = !{}+!9 = !{!0}+!10 = !DICompositeType(tag: DW_TAG_array_type, baseType: !11, size: 192, elements: !14)+!11 = !DIDerivedType(tag: DW_TAG_const_type, baseType: !12)+!12 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !13, size: 64)+!13 = !DIDerivedType(tag: DW_TAG_const_type, baseType: null)+!14 = !{!15}+!15 = !DISubrange(count: 3)+!16 = !{i32 7, !"Dwarf Version", i32 4}+!17 = !{i32 2, !"Debug Info Version", i32 3}+!18 = !{i32 1, !"wchar_size", i32 4}+!19 = !{i32 7, !"PIC Level", i32 2}+!20 = !{!"clang version 11.1.0"}+!21 = !DILocalVariable(name: "x", arg: 1, scope: !2, file: !3, line: 5, type: !6)+!22 = !DILocation(line: 5, column: 26, scope: !2)+!23 = !DILocalVariable(name: "y", scope: !2, file: !3, line: 6, type: !6)+!24 = !DILocation(line: 6, column: 9, scope: !2)+!25 = !DILocation(line: 8, column: 9, scope: !2)+!26 = !DILocation(line: 8, column: 7, scope: !2)+!27 = !DILocation(line: 8, column: 5, scope: !2)+!28 = !DILabel(scope: !2, name: "start", file: !3, line: 9)+!29 = !DILocation(line: 9, column: 1, scope: !2)+!30 = !DILocation(line: 10, column: 19, scope: !2)+!31 = !DILocation(line: 10, column: 11, scope: !2)+!32 = !DILocation(line: 10, column: 5, scope: !2)+!33 = !DILabel(scope: !2, name: "fn1", file: !3, line: 11)+!34 = !DILocation(line: 11, column: 1, scope: !2)+!35 = !DILocation(line: 12, column: 7, scope: !2)+!36 = !DILocation(line: 13, column: 19, scope: !2)+!37 = !DILocation(line: 13, column: 11, scope: !2)+!38 = !DILocation(line: 13, column: 5, scope: !2)+!39 = !DILabel(scope: !2, name: "fn2", file: !3, line: 14)+!40 = !DILocation(line: 14, column: 1, scope: !2)+!41 = !DILocation(line: 15, column: 7, scope: !2)+!42 = !DILocation(line: 16, column: 5, scope: !2)+!43 = !DILabel(scope: !2, name: "fn3", file: !3, line: 17)+!44 = !DILocation(line: 17, column: 1, scope: !2)+!45 = !DILocation(line: 18, column: 12, scope: !2)+!46 = !DILocation(line: 18, column: 5, scope: !2)+!47 = distinct !DISubprogram(name: "main", scope: !3, file: !3, line: 21, type: !48, scopeLine: 21, flags: DIFlagPrototyped, spFlags: DISPFlagDefinition, unit: !7, retainedNodes: !8)+!48 = !DISubroutineType(types: !49)+!49 = !{!6, !6, !50}+!50 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !51, size: 64)+!51 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !52, size: 64)+!52 = !DIBasicType(name: "char", size: 8, encoding: DW_ATE_signed_char)+!53 = !DILocalVariable(name: "argc", arg: 1, scope: !47, file: !3, line: 21, type: !6)+!54 = !DILocation(line: 21, column: 14, scope: !47)+!55 = !DILocalVariable(name: "argv", arg: 2, scope: !47, file: !3, line: 21, type: !50)+!56 = !DILocation(line: 21, column: 27, scope: !47)+!57 = !DILocation(line: 22, column: 39, scope: !47)+!58 = !DILocation(line: 22, column: 22, scope: !47)+!59 = !DILocation(line: 22, column: 5, scope: !47)+!60 = !DILocation(line: 23, column: 1, scope: !47)

@@ -0,0 +1,100 @@+# Developers' documentation++<!-- markdown-toc start - Don't edit this section. Run M-x markdown-toc-refresh-toc -->+**Table of Contents**++- [Developers' documentation](#developers-documentation)+    - [Upstream documentation](#upstream-documentation)+    - [Building](#building)+    - [Running the tests](#running-the-tests)+        - [`llvm-disasm-test`](#llvm-disasm-test)+            - [description](#description)+            - [use](#use)+        - [`regression-test`](#regression-test)+        - [`unit-test`](#unit-test)+    - [Travis CI build](#travis-ci-build)++<!-- markdown-toc end -->++## Upstream documentation++Official (yet incomplete) reference: https://llvm.org/docs/BitCodeFormat.html++Relevant parts of the upstream C++ implementation:+ + [Parser (14.x)](https://github.com/llvm/llvm-project/blob/release/14.x/llvm/lib/Bitcode/Reader/BitcodeReader.cpp)+ + Record codes:+   * [Bitstream enum values (14.x)](https://github.com/llvm/llvm-project/blob/release/14.x/llvm/include/llvm/Bitstream/BitCodes.h)+   * [LLVM bitcode enum values (14.x)](https://github.com/llvm/llvm-project/blob/release/14.x/llvm/include/llvm/Bitcode/LLVMBitCodes.h)++## Building++Make sure you have cloned the `llvm-pretty` submodule before building:++```bash+$ git submodule update --init+$ cabal build+```++## Running the tests++### `llvm-disasm-test`++#### description++This test compares the behavior of `llvm-disasm` against that of `llvm-dis`, by+having them both disassemble the same file and diffing their output (in general,+we don't expect them to exactly match).++Additionally, by default this test does a "round-trip" comparison of+`llvm-disasm` against itself. After disassembling the first time, it reassembles+the output of `llvm-disasm` and runs it again. It then compares both the+ASTs and the LLVM assembly generated by the first and second run of+`llvm-disasm`, to ensure that the printer/parser combo is idempotent.++#### use++To compare the behavior of `llvm-disasm` against that of `llvm-dis`:+```bash+cabal build+./dist/build/disasm-test/disasm-test ./disasm-test/tests/fun-attrs.ll++# When using cabal new-build, the binary locations aren't so nice.+$(find . -name disasm-test -type f) disasm-test/tests/*.ll+```+To see all the options,+```bash+./dist/build/disasm-test/disasm-test --help+```++If you have [Nix](https://nixos.org/nix/) installed, you can easily compare+against multiple versions of `llvm-dis`, e.g.+```bash+nix-shell --pure -p llvm_6 --run "./dist/build/disasm-test/disasm-test ./disasm-test/tests/fun-attrs.ll"+```++### `regression-test`++See [the README in that directory](../regression-test/README.md).++### `fuzzing`++See [the README in that directory](../fuzzing/README.md).++### `unit-test`++These are run with `cabal test` or `cabal new-test`.++## Supported GHC Versions++A policy on which GHC versions to support must balance the benefits of wide+applicability/support against the drawbacks of additional costs of development,+including developer time and CI budgets. Our policy is to support three versions+of GHC at a time. We try to support new versions of GHC as soon as they are+supported by all of libraries that llvm-pretty-bc-parser depends on.++When updating the supported GHC versions, remember to update:++- [The README](../README.md)+- [The Cabal file](../llvm-pretty-bc-parser.cabal)'s `Tested-with` field+- [The Nix flake](../flake.nix)+- [CI workflows](../.github/workflows)

@@ -1,9 +1,9 @@-import Data.LLVM.BitCode (parseBitCode, formatError)+import Data.LLVM.BitCode (parseBitCodeWithWarnings, formatError, ppParseWarnings) import Data.LLVM.CFG (buildCFG, CFG(..), blockId) import Text.LLVM.AST (defBody, modDefines,Module) import Text.LLVM.PP (ppLLVM, ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38, llvmPP, llvmVlatest) -import Control.Monad (when)+import Control.Monad (unless, when) import Data.Graph.Inductive.Graph (nmap, emap) import Data.Graph.Inductive.Dot (fglToDotString, showDot) import Data.Monoid (Endo(..))@@ -14,7 +14,7 @@   (ArgOrder(..), ArgDescr(..), OptDescr(..), getOpt, usageInfo) import System.Environment (getArgs,getProgName) import System.Exit (exitFailure, exitSuccess)-import System.IO (stderr,hPutStrLn)+import System.IO (stderr,hPrint,hPutStrLn) import qualified Data.ByteString as S  data Options = Options {@@ -91,14 +91,16 @@ disasm opts file = do   putStrLn (replicate 80 ';' ++ "\n")   putStrLn ("; " ++ file)-  e <- parseBitCode =<< S.readFile file+  e <- parseBitCodeWithWarnings =<< S.readFile file   case e of      Left err -> do       hPutStrLn stderr (formatError err)       exitFailure -    Right m  -> do+    Right (m, warnings) -> do+        unless (null warnings) $+          hPrint stderr $ ppParseWarnings warnings         if optAST opts           then pPrint m           else renderLLVM opts m

@@ -1,6 +1,6 @@ cabal-version:       2.4 Name:                llvm-pretty-bc-parser-Version:             0.4.2.0+Version:             0.5.0.0 License:             BSD-3-Clause License-file:        LICENSE Author:              Trevor Elliott <trevor@galois.com>@@ -18,7 +18,7 @@  Extra-source-files:  disasm-test/tests/*.ll -extra-doc-files: CHANGELOG.md, README.md+extra-doc-files: CHANGELOG.md, README.md, doc/developing.md  Flag fuzz   Description:         Enable fuzzing harness@@ -75,7 +75,7 @@                        bytestring  >= 0.10,                        containers  >= 0.4,                        fgl         >= 5.5,-                       llvm-pretty >= 0.12.1.0 && < 0.13,+                       llvm-pretty >= 0.13.0.0 && < 0.14,                        mtl         >= 2.2.2,                        pretty      >= 1.0.1,                        uniplate    >= 1.6,

@@ -1,40 +1,143 @@+{-# LANGUAGE OverloadedStrings #-}+ module Data.LLVM.BitCode (     -- * Bitcode Parsing+    -- ** Without 'ParseWarning's     parseBitCode,     parseBitCodeFromFile   , parseBitCodeLazy, parseBitCodeLazyFromFile+    -- ** With 'ParseWarning's+  , parseBitCodeWithWarnings,     parseBitCodeFromFileWithWarnings+  , parseBitCodeLazyWithWarnings, parseBitCodeLazyFromFileWithWarnings      -- * Re-exported   , Error(..), formatError+  , ParseWarning(..), MetadataRecordSizeRange(..)+  , ppParseWarnings, ppParseWarning   ) 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 Data.LLVM.BitCode.Parse (runParse,badRefError,Error(..),formatError,+                                MetadataRecordSizeRange(..),ParseWarning(..),+                                ParseState(..),ppParseWarning,ppParseWarnings) 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+import Data.Sequence (Seq) +-- | Parse the contents of an LLVM bitcode file as a strict 'S.ByteString'. If+-- parsing succeeds, return the parsed 'Module'. Otherwise, return an 'Error'+-- describing what went wrong.+--+-- See also 'parseBitCodeWithWarnings' for a version that also returns any+-- warnings that arise during parsing. This function will simply discard all+-- such warnings, which is why this function is deprecated. parseBitCode :: S.ByteString -> IO (Either Error Module)-parseBitCode  = parseBitstream . parseBitCodeBitstream+parseBitCode =+  fmap (fmap fst) . parseBitstream . parseBitCodeBitstream+{-# DEPRECATED+      parseBitCode+      "Use parseBitCodeWithWarnings instead." #-} +-- | Load an LLVM bitcode file as a strict 'S.ByteString' and parse its+-- contents. If parsing succeeds, return the parsed 'Module'. Otherwise, return+-- an 'Error' describing what went wrong.+--+-- See also 'parseBitCodeFromFileWithWarnings' for a version that also returns+-- any warnings that arise during parsing. This function will simply discard all+-- such warnings, which is why this function is deprecated. parseBitCodeFromFile :: FilePath -> IO (Either Error Module)-parseBitCodeFromFile  = parseBitCode <=< S.readFile+parseBitCodeFromFile =+  parseBitCode <=< S.readFile+{-# DEPRECATED+      parseBitCodeFromFile+      "Use parseBitCodeFromFileWithWarnings instead." #-} +-- | Parse the contents of an LLVM bitcode file as a lazy 'L.ByteString'. If+-- parsing succeeds, return the parsed 'Module'. Otherwise, return an 'Error'+-- describing what went wrong.+--+-- See also 'parseBitCodeLazyWithWarnings' for a version that also returns any+-- warnings that arise during parsing. This function will simply discard all+-- such warnings, which is why this function is deprecated. parseBitCodeLazy :: L.ByteString -> IO (Either Error Module)-parseBitCodeLazy  = parseBitstream . parseBitCodeBitstreamLazy+parseBitCodeLazy =+  fmap (fmap fst) . parseBitstream . parseBitCodeBitstreamLazy+{-# DEPRECATED+      parseBitCodeLazy+      "Use parseBitCodeLazyWithWarnings instead." #-} +-- | Load an LLVM bitcode file as a lazy 'L.ByteString' and parse its contents.+-- If parsing succeeds, return the parsed 'Module'. Otherwise, return an 'Error'+-- describing what went wrong in a 'Left' value.+--+-- See also 'parseBitCodeLazyFromFileWithWarnings' for a version that also+-- returns any warnings that arise during parsing. This function will simply+-- discard all such warnings, which is why this function is deprecated. parseBitCodeLazyFromFile :: FilePath -> IO (Either Error Module)-parseBitCodeLazyFromFile  = parseBitCodeLazy <=< L.readFile+parseBitCodeLazyFromFile =+  parseBitCodeLazy <=< L.readFile+{-# DEPRECATED+      parseBitCodeLazyFromFile+      "Use parseBitCodeLazyFromFileWithWarnings instead." #-} -parseBitstream :: Either String Bitstream -> IO (Either Error Module)+-- | Parse the contents of an LLVM bitcode file as a strict 'S.ByteString'. If+-- parsing succeeds, return the parsed 'Module' and any 'ParseWarning's that+-- were emitted. Otherwise, return an 'Error' describing what went wrong.+--+-- See also 'parseBitCode' for a version that discards any warnings that arise+-- during parsing.+parseBitCodeWithWarnings ::+  S.ByteString -> IO (Either Error (Module, Seq ParseWarning))+parseBitCodeWithWarnings =+  parseBitstream . parseBitCodeBitstream++-- | Load an LLVM bitcode file as a strict 'S.ByteString' and parse its+-- contents. If parsing succeeds, return the parsed 'Module' and any+-- 'ParseWarnings' that were emitted. Otherwise, return an 'Error' describing+-- what went wrong.+--+-- See also 'parseBitCodeFromFile' for a version that discards any warnings that+-- arise during parsing.+parseBitCodeFromFileWithWarnings ::+  FilePath -> IO (Either Error (Module, Seq ParseWarning))+parseBitCodeFromFileWithWarnings =+  parseBitCodeWithWarnings <=< S.readFile++-- | Parse the contents of an LLVM bitcode file as a lazy 'L.ByteString'. If+-- parsing succeeds, return the parsed 'Module' and any 'ParseWarning's that+-- were emitted. Otherwise, return an 'Error' describing what went wrong.+--+-- See also 'parseBitCodeLazy' for a version that discards any warnings that+-- arise during parsing.+parseBitCodeLazyWithWarnings ::+  L.ByteString -> IO (Either Error (Module, Seq ParseWarning))+parseBitCodeLazyWithWarnings =+  parseBitstream . parseBitCodeBitstreamLazy++-- | Load an LLVM bitcode file as a lazy 'L.ByteString' and parse its contents.+-- If parsing succeeds, return the parsed 'Module' and any 'ParseWarnings' that+-- were emitted. Otherwise, return an 'Error' describing what went wrong.+--+-- See also 'parseBitCodeLazyFromFile' for a version that discards any warnings+-- that arise during parsing.+parseBitCodeLazyFromFileWithWarnings ::+  FilePath -> IO (Either Error (Module, Seq ParseWarning))+parseBitCodeLazyFromFileWithWarnings =+  parseBitCodeLazyWithWarnings <=< L.readFile++parseBitstream ::+  Either String Bitstream -> IO (Either Error (Module, Seq ParseWarning)) parseBitstream e = case e of   Left err   -> mkError ["Bitstream"] err-  Right bits -> X.handle (return . Left . badRefError)-                         (X.evaluate (runParse (parseModule bits)))+  Right bits -> do+    res <- X.handle (return . Left . badRefError)+                    (X.evaluate (runParse (parseModule bits)))+    pure $ fmap (\(m, st) -> (m, psWarnings st)) res   where   mkError cxt msg = return $ Left Error     { errMessage = msg

@@ -26,7 +26,6 @@ import           Data.Int (Int32) import           Data.Word (Word32) import qualified Data.Foldable as F-import qualified Data.IntMap as IntMap import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Traversable as T@@ -101,11 +100,11 @@     , paTarget     = tgt     } -finalizePartialAlias :: PartialAlias -> Parse GlobalAlias-finalizePartialAlias pa = label "finalizePartialAlias" $ do+finalizePartialAlias :: PartialAlias -> Finalize GlobalAlias+finalizePartialAlias pa = do   -- aliases refer to absolute offsets   tv  <- getFnValueById (paType pa) (fromIntegral (paTarget pa))-  tgt <- liftFinalize $ relabel (const requireBbEntryName) (typedValue tv)+  tgt <- relabel requireBbEntryName (typedValue tv)   return GlobalAlias     { aliasLinkage    = paLinkage pa     , aliasVisibility = paVisibility pa@@ -120,7 +119,7 @@ type DeclareList = Seq.Seq FunProto  -- | Turn a function prototype into a declaration.-finalizeDeclare :: FunProto -> Parse Declare+finalizeDeclare :: FunProto -> Finalize Declare finalizeDeclare fp = case protoType fp of   PtrTo (FunTy ret args va) -> return Declare     { decLinkage    = protoLinkage fp@@ -196,7 +195,7 @@  initialPartialSymtab :: Parse ValueSymtab initialPartialSymtab  = do-  mb <- liftFinalize $ bbEntryName 0+  mb <- liftFinalize mempty $ bbEntryName Nothing 0   case mb of     Just{}  -> return emptyValueSymtab     Nothing -> do@@ -221,28 +220,15 @@     Seq.EmptyR        -> mzero  --type BlockLookup = Symbol -> Int -> Finalize 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 " ++ prettySym fn ++ " is not defined")-    Just st -> case IntMap.lookup bid (bbSymtab 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 =+finalizePartialDefine :: FuncSymTabs -> PartialDefine -> Parse Define+finalizePartialDefine defs pd =   label "finalizePartialDefine" $   -- augment the symbol table with implicitly named anonymous blocks, and   -- generate basic blocks.   withValueSymtab (partialSymtab pd) $ do-    body <- liftFinalize $ finalizeBody lkp (partialBody pd)-    md <- finalizeMetadata (partialMetadata pd)+    body <- liftFinalize defs $ finalizeBody (partialBody pd)+    md <- finalizeMetadata defs (partialMetadata pd)     return Define       { defLinkage    = partialLinkage pd       , defVisibility = partialVisibility pd@@ -258,15 +244,9 @@       , defComdat     = partialComdatName pd       } -finalizeMetadata :: PFnMdAttachments -> Parse FnMdAttachments-finalizeMetadata patt = Map.fromList <$> mapM f (Map.toList patt)-  where f (k,md) = (,) <$> getKind k <*> liftFinalize (finalizePValMd md)---- | Individual label resolution step.-resolveBlockLabel :: BlockLookup -> Maybe Symbol -> Int -> Finalize BlockLabel-resolveBlockLabel lkp mbSym = case mbSym of-  Nothing  -> requireBbEntryName-  Just sym -> lkp sym+finalizeMetadata :: FuncSymTabs -> PFnMdAttachments -> Parse FnMdAttachments+finalizeMetadata defs patt = Map.fromList <$> mapM f (Map.toList patt)+  where f (k,md) = (,) <$> getKind k <*> (liftFinalize defs $ finalizePValMd md)  -- | Name the next result with either its symbol, or the next available -- anonymous result id.@@ -298,7 +278,7 @@ terminateBlock :: PartialDefine -> Parse PartialDefine terminateBlock d = do   let next = partialBlockId d + 1-  mb <- liftFinalize $ bbEntryName next+  mb <- liftFinalize mempty $ bbEntryName Nothing next   d' <- case mb of     Just _  -> return d     Nothing -> do@@ -318,8 +298,8 @@ type BlockList = Seq.Seq PartialBlock  -- | Process a @BlockList@, turning it into a list of basic blocks.-finalizeBody :: BlockLookup -> BlockList -> Finalize [BasicBlock]-finalizeBody lkp = fmap F.toList . T.mapM (finalizePartialBlock lkp)+finalizeBody :: BlockList -> Finalize [BasicBlock]+finalizeBody = fmap F.toList . T.mapM finalizePartialBlock  data PartialBlock = PartialBlock   { partialLabel :: !Int@@ -330,10 +310,10 @@ setPartialStmts stmts pb = pb { partialStmts = stmts }  -- | Process a partial basic block into a full basic block.-finalizePartialBlock :: BlockLookup -> PartialBlock -> Finalize BasicBlock-finalizePartialBlock lkp pb = BasicBlock-                          <$> bbEntryName (partialLabel pb)-                          <*> finalizeStmts lkp (partialStmts pb)+finalizePartialBlock :: PartialBlock -> Finalize BasicBlock+finalizePartialBlock pb = BasicBlock+                          <$> bbEntryName Nothing (partialLabel pb)+                          <*> finalizeStmts (partialStmts pb)  type PStmt = Stmt' Int @@ -341,12 +321,11 @@  -- | Process a list of statements with explicit block id labels into one with -- textual labels.-finalizeStmts :: BlockLookup -> StmtList -> Finalize [Stmt]-finalizeStmts lkp = mapM (finalizeStmt lkp) . F.toList--finalizeStmt :: BlockLookup -> Stmt' Int -> Finalize Stmt-finalizeStmt lkp = relabel (resolveBlockLabel lkp)+finalizeStmts :: StmtList -> Finalize [Stmt]+finalizeStmts = mapM finalizeStmt . F.toList +finalizeStmt :: Stmt' Int -> Finalize Stmt+finalizeStmt = relabel requireBbEntryName  -- Function Block Parsing ------------------------------------------------------ 

@@ -77,16 +77,16 @@     , pgMd      = Map.empty     } -finalizeGlobal :: PartialGlobal -> Parse Global+finalizeGlobal :: PartialGlobal -> Finalize Global finalizeGlobal pg = case pgValueIx pg of-  Nothing -> liftFinalize $ mkGlobal Nothing+  Nothing -> mkGlobal Nothing   Just ix -> do     tv <- getFnValueById (pgType pg) (fromIntegral ix)-    val <- liftFinalize $ relabel (const requireBbEntryName) (typedValue tv)-    liftFinalize $ mkGlobal (Just val)+    val <- relabel requireBbEntryName (typedValue tv)+    mkGlobal (Just val)   where   mkGlobal mval =-    do md <- mapM (relabel (const requireBbEntryName)) (pgMd pg)+    do md <- mapM (relabel requireBbEntryName) (pgMd pg)        return Global { globalSym   = pgSym pg                      , globalAttrs = pgAttrs pg                      , globalType  = pgType pg

@@ -328,7 +328,7 @@     }  finalizePValMd :: PValMd -> Finalize ValMd-finalizePValMd = relabel (const requireBbEntryName)+finalizePValMd = relabel requireBbEntryName  -- | Partition unnamed entries into global and function local unnamed entries. unnamedEntries :: PartialMetadata -> (Seq PartialUnnamedMd, Seq PartialUnnamedMd)@@ -402,28 +402,35 @@ parseMetadataEntry :: ValueTable -> MetadataTable -> PartialMetadata -> Entry                    -> Parse PartialMetadata parseMetadataEntry vt mt pm (fromEntry -> Just r) =-  let msg = [ "Are you sure you're using a supported version of LLVM/Clang?"-            , "Check here: https://github.com/GaloisInc/llvm-pretty-bc-parser"-            ]-      assertRecordSizeBetween lb ub =+  let -- The assert* functions below check if a metadata record size matches+      -- what is expected, and if not, emit a warning.+      --+      -- In the past, we made these fatal errors instead of warnings, but we+      -- downgraded them to a warning due to how frequently LLVM adds new+      -- metadata record fields. Moreover, it is usually not a serious problem+      -- for downstream users that llvm-pretty-bc-parser lacks newer metadata+      -- fields, since they usually do not affect the semantics of the overall+      -- LLVM bitcode.+      assertRecordSizeBetween lb ub = do+        cxt <- getContext         let len = length (recordFields r)-        in when (len < lb || ub < len) $-             fail $ unlines $ [ "Invalid record size: " ++ show len-                              , "Expected size between " ++ show lb ++ " and " ++ show ub-                              ] ++ msg-      assertRecordSizeIn ns =+        when (len < lb || ub < len) $+          addParseWarning $+          InvalidMetadataRecordSize len (MetadataRecordSizeBetween lb ub) cxt++      assertRecordSizeIn ns = do+        cxt <- getContext         let len = length (recordFields r)-        in when (not (len `elem` ns)) $-             fail $ unlines $ [ "Invalid record size: " ++ show len-                              , "Expected one of: " ++ show ns-                              ] ++ msg+        when (not (len `elem` ns)) $+          addParseWarning $+          InvalidMetadataRecordSize len (MetadataRecordSizeIn ns) cxt -      assertRecordSizeAtLeast lb =+      assertRecordSizeAtLeast lb = do+        cxt <- getContext         let len = length (recordFields r)-        in when (len < lb) $-             fail $ unlines $ [ "Invalid record size: " ++ show len-                              , "Expected size of " ++ show lb ++ " or greater"-                              ] ++ msg+        when (len < lb) $+          addParseWarning $+          InvalidMetadataRecordSize len (MetadataRecordSizeAtLeast lb) cxt        -- Helper for a common pattern which appears below in the parsing       ron n = do ctx <- getContext@@ -897,11 +904,7 @@      24 -> label "METADATA_NAMESPACE" $ do       assertRecordSizeIn [3, 5]-      let isNew =-            case length (recordFields r) of-              3 -> True-              5 -> False-              _ -> error "Impossible (METADATA_NAMESPACE)" -- see assertion+      let isNew = length (recordFields r) == 3       let nameIdx = if isNew then 2 else 3        cxt        <- getContext@@ -918,10 +921,7 @@      25 -> label "METADATA_TEMPLATE_TYPE" $ do       assertRecordSizeIn [3, 4]-      let recordLength = length (recordFields r)-      let hasIsDefault | recordLength == 3 = False-                       | recordLength == 4 = True-                       | otherwise = error "Impossible (METADATA_TEMPLATE_TYPE)" -- see assertion+      let hasIsDefault = length (recordFields r) == 4       cxt <- getContext       isDistinct <- parseField r 0 nonzero       dittpName <- mdStringOrNull cxt pm <$> parseField r 1 numeric@@ -935,10 +935,7 @@      26 -> label "METADATA_TEMPLATE_VALUE" $ do       assertRecordSizeIn [5, 6]-      let recordLength = length (recordFields r)-      let hasIsDefault | recordLength == 5 = False-                       | recordLength == 6 = True-                       | otherwise = error "Impossible (METADATA_TEMPLATE_TYPE)" -- see assertion+      let hasIsDefault = length (recordFields r) == 6       cxt        <- getContext       isDistinct <- parseField r 0 nonzero       ditvpTag <- parseField r 1 numeric

@@ -70,27 +70,29 @@ -- module. finalizeModule :: PartialModule -> Parse Module finalizeModule pm = label "finalizeModule" $ do-  globals  <- T.mapM finalizeGlobal       (partialGlobals pm)-  declares <- T.mapM finalizeDeclare      (partialDeclares pm)-  aliases  <- T.mapM finalizePartialAlias (partialAliases pm)-  unnamed  <- liftFinalize $ T.mapM finalizePartialUnnamedMd (dedupMetadata (partialUnnamedMd pm))   types    <- resolveTypeDecls-  let lkp = lookupBlockName (partialDefines pm)-  defines <- T.mapM (finalizePartialDefine lkp) (partialDefines pm)-  return emptyModule-    { modSourceName = partialSourceName pm-    , modTriple     = partialTriple pm-    , modDataLayout = partialDataLayout pm-    , modNamedMd    = F.toList (partialNamedMd pm)-    , modUnnamedMd  = sortOn umIndex (F.toList unnamed)-    , modGlobals    = F.toList globals-    , modDefines    = F.toList defines-    , modTypes      = types-    , modDeclares   = F.toList declares-    , modInlineAsm  = partialInlineAsm pm-    , modAliases    = F.toList aliases-    , modComdat     = Map.fromList (F.toList (partialComdat pm))-    }+  let defs = Map.fromList [ (partialName d, partialSymtab d)+                          | d <- F.toList (partialDefines pm) ]+  defines <- T.mapM (finalizePartialDefine defs) (partialDefines pm)+  liftFinalize defs $ do+    globals  <- T.mapM finalizeGlobal (partialGlobals pm)+    declares <- T.mapM finalizeDeclare (partialDeclares pm)+    aliases  <- T.mapM finalizePartialAlias (partialAliases pm)+    unnamed  <- T.mapM finalizePartialUnnamedMd (dedupMetadata (partialUnnamedMd pm))+    return emptyModule+      { modSourceName = partialSourceName pm+      , modTriple     = partialTriple pm+      , modDataLayout = partialDataLayout pm+      , modNamedMd    = F.toList (partialNamedMd pm)+      , modUnnamedMd  = sortOn umIndex (F.toList unnamed)+      , modGlobals    = F.toList globals+      , modDefines    = F.toList defines+      , modTypes      = types+      , modDeclares   = F.toList declares+      , modInlineAsm  = partialInlineAsm pm+      , modAliases    = F.toList aliases+      , modComdat     = Map.fromList (F.toList (partialComdat pm))+      }  -- | Parse an LLVM Module out of the top-level block in a Bitstream. parseModuleBlock :: [Entry] -> Parse Module

@@ -44,15 +44,17 @@ --getValueNoFwdRef :: Type -> Int -> Parse (Typed PValue) --getValueNoFwdRef ty n = label "getValueNoFwdRef" (getFnValueById ty =<< adjustId n) -getFnValueById :: Type -> Int -> Parse (Typed PValue)+getFnValueById :: (HasMdTable m, HasParseEnv m, HasValueTable m, MonadFail m)+               => Type -> Int -> m (Typed PValue) getFnValueById  = getFnValueById' Nothing  getValue :: ValueTable -> Type -> Int -> Parse (Typed PValue) getValue vt ty n = label "getValue" (getFnValueById' (Just vt) ty =<< adjustId n)  -- | Lookup a value by its absolute id, or perhaps some metadata.-getFnValueById' :: Maybe ValueTable -> Type -> Int -> Parse (Typed PValue)-getFnValueById' mbVt ty n = label "getFnValueById'" $ case ty of+getFnValueById' :: (HasMdTable m, HasParseEnv m, HasValueTable m, MonadFail m)+                => Maybe ValueTable -> Type -> Int -> m (Typed PValue)+getFnValueById' mbVt ty n = case ty of    PrimType Metadata -> do     cxt <- getContext

@@ -4,6 +4,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE RecordWildCards #-} @@ -20,8 +21,10 @@ #endif import           Control.Monad.Fix (MonadFix) import           Control.Monad.Except (MonadError(..), Except, runExcept)-import           Control.Monad.Reader (MonadReader(..), ReaderT(..))-import           Control.Monad.State.Strict (MonadState(..), StateT(..))+import           Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)+import           Control.Monad.State.Strict (MonadState(..), StateT(..)+                                            , gets, modify)+import qualified Data.Foldable as F import           Data.Maybe (fromMaybe) import           Data.Semigroup import           Data.Typeable (Typeable)@@ -34,6 +37,8 @@ import qualified Data.Map as Map import qualified Data.Sequence as Seq import           GHC.Stack (HasCallStack, CallStack, callStack, prettyCallStack)+import qualified Text.PrettyPrint.HughesPJ as PP+import qualified Text.PrettyPrint.HughesPJClass as PP  import           Prelude @@ -50,12 +55,18 @@   | null (errContext err) = errMessage err   | otherwise             = unlines                           $ errMessage err-                          : "from:"-                          : map ('\t' :) (errContext err)+                          : formatContext (errContext err) +formatContext :: [String] -> [String]+formatContext cxt = "from:" : map ('\t' :) cxt+ newtype Parse a = Parse   { unParse :: ReaderT Env (StateT ParseState (Except Error)) a-  } deriving (Functor, Applicative, MonadFix)+  } deriving ( Functor, Applicative, MonadFix+             , MonadReader Env+             , MonadState ParseState+             , MonadError Error+             )  instance Monad Parse where #if !MIN_VERSION_base(4,11,0)@@ -89,11 +100,11 @@   {-# INLINE mplus #-}   mplus = (<|>) -runParse :: Parse a -> Either Error a+runParse :: Parse a -> Either Error (a, ParseState) runParse (Parse m) =   case runExcept (runStateT (runReaderT m emptyEnv) emptyParseState) of-    Left err     -> Left err-    Right (a, _) -> Right a+    Left err  -> Left err+    Right res -> Right res  notImplemented :: Parse a notImplemented  = fail "not implemented"@@ -114,6 +125,7 @@   , psLastLoc       :: Maybe PDebugLoc   , psKinds         :: !KindTable   , psModVersion    :: !Int+  , psWarnings      :: Seq.Seq ParseWarning   } deriving (Show)  -- | The initial parsing state.@@ -132,6 +144,7 @@   , psLastLoc       = Nothing   , psKinds         = emptyKindTable   , psModVersion    = 0+  , psWarnings      = Seq.empty   }  -- | The next implicit result id.@@ -153,10 +166,8 @@   ps <- get   put $! ps { psValueTable = (psValueTable ps) { valueRelIds = b }} -getRelIds :: Parse Bool-getRelIds  = do-  ps <- Parse get-  return (valueRelIds (psValueTable ps))+getRelIds :: HasValueTable m => m Bool+getRelIds  = valueRelIds <$> getValueTable  getLastLoc :: Parse PDebugLoc getLastLoc  = do@@ -327,7 +338,7 @@  -- | Get the index for the next value. nextValueId :: Parse Int-nextValueId  = Parse (valueNextId . psValueTable <$> get)+nextValueId = valueNextId <$> getValueTable  -- | Depending on whether or not relative ids are in use, adjust the id. adjustId :: Int -> Parse Int@@ -350,7 +361,7 @@ lookupValueTableAbs n values = IntMap.lookup n (valueEntries values)  -- | When you know you have an absolute index.-lookupValueAbs :: Int -> Parse (Maybe (Typed PValue))+lookupValueAbs :: HasValueTable m => Int -> m (Maybe (Typed PValue)) lookupValueAbs n = lookupValueTableAbs n `fmap` getValueTable  -- | Lookup either a relative id, or an absolute id.@@ -379,10 +390,13 @@     Just tv -> return tv     Nothing -> fail ("value " ++ show n ++ " is not defined") --- | Get the current value table.-getValueTable :: Parse ValueTable-getValueTable  = Parse (psValueTable <$> get)+class Monad m => HasValueTable m where+  -- | Get the current value table.+  getValueTable :: m ValueTable +instance HasValueTable Parse where+  getValueTable  = gets psValueTable+ -- | 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@@ -413,13 +427,14 @@  type MdTable = ValueTable -getMdTable :: Parse MdTable-getMdTable  = Parse (psMdTable <$> get)+class Monad m => HasMdTable m where+  getMdTable :: m MdTable +instance HasMdTable Parse where+  getMdTable = gets psMdTable+ setMdTable :: MdTable -> Parse ()-setMdTable md = Parse $ do-  ps <- get-  put $! ps { psMdTable = md }+setMdTable md = modify $ \ps -> ps { psMdTable = md }  getMetadata :: Int -> Parse (Typed PValMd) getMetadata ix = do@@ -478,9 +493,10 @@  -- Parsing Environment --------------------------------------------------------- +-- | The Reader environment information maintained in the 'Parse' monad. data Env = Env-  { envSymtab  :: Symtab-  , envContext :: [String]+  { envSymtab  :: Symtab  -- ^ the global symbol table+  , envContext :: [String] -- ^ the stack of "label" strings (a "stacktrace")   } deriving Show  emptyEnv :: Env@@ -497,9 +513,20 @@ addLabel :: String -> Env -> Env addLabel l env = env { envContext = l : envContext env } -getContext :: Parse [String]-getContext  = Parse (envContext `fmap` ask)+class Monad m => HasParseEnv m where+  -- | Gets the "stacktrace" for what is currently being evaluated (as set by the+  -- 'label' function, which calls 'addLabel' above).  Note that the label+  -- referenced here is the parsing processing notation, and NOT the llvm-pretty+  -- AST 'lab' type argument which references the Basic Block label and which is+  -- set with the 'llvm-pretty.relabel' function... an unfortunate overloading of+  -- the term "label".+  getContext :: m [String]+  -- | Retrieve the value symbol table+  getValueSymtab :: m ValueSymtab +instance HasParseEnv Parse where+  getContext = asks envContext+  getValueSymtab = asks $ symValueSymtab . envSymtab  data Symtab = Symtab   { symValueSymtab :: ValueSymtab@@ -528,10 +555,6 @@ withValueSymtab :: ValueSymtab -> Parse a -> Parse a withValueSymtab symtab = withSymtab (mempty { symValueSymtab = symtab }) --- | Retrieve the value symbol table.-getValueSymtab :: Finalize ValueSymtab-getValueSymtab = Finalize (symValueSymtab . envSymtab <$> ask)- -- | Run a computation with an extended type symbol table. withTypeSymtab :: TypeSymtab -> Parse a -> Parse a withTypeSymtab symtab = withSymtab (mempty { symTypeSymtab = symtab })@@ -574,7 +597,32 @@  -- Value Symbol Table ---------------------------------------------------------- -type SymName = Either String Int+-- | An LLVM Bitcode file, it is comprised of nested Blocks of information,+-- with records available at each block.  Different blocks hold different+-- types of information, and the nesting represents program scope and what is+-- defined/accessible at a particular point within the program.+--+-- The `Parse` and `Finalize` monads maintain a set of symbol tables to use+-- for lookups, as stored in the `Env` structure referenced by those monads:+--+--   * `valSymtab` for value references+--+--   * `fnSymtab` for function references+--+--   * `bbSymTab` for basic-block references, either "named" by association+--     with a symbol name (like the function's entry block) or "anonymous",+--     where there is no direct symbol but there may be a block label (like+--     for a goto statement or similar surface language construct.)+--+-- These lookups are necessary to "relabel" values that reference symbol or+-- label addresses in the code with the actual targets as resolved by+-- processing the entirety of the LLVM bitcode file.  The+-- llvm-pretty-bc-parser runs in two phases: the initial phase where it+-- processes the LLVM bitcode stream to create "Partial" representations of+-- all of the elements, followed by a "finalization" phase where it performs+-- all of the label references above (via the llvm-pretty `relabel`+-- operation), as well as other fixups to convert the "Partial" data+-- structures into the structures defined by the `llvm-pretty` AST.  data ValueSymtab =   ValueSymtab@@ -583,6 +631,8 @@   , fnSymtab  :: IntMap.IntMap SymName   } deriving (Show) +type SymName = Either String Int+ instance Semigroup ValueSymtab where   l <> r = ValueSymtab     { valSymtab = valSymtab l `IntMap.union` valSymtab r@@ -624,40 +674,48 @@ addFwdFNEntry i o t = t { fnSymtab = IntMap.insert i (Right o) (fnSymtab t) }  -- | Lookup the name of an entry. Returns @Nothing@ when it's not present.-entryNameMb :: Int -> Parse (Maybe String)+entryNameMb :: HasParseEnv m => Int -> m (Maybe String) entryNameMb n = do-  symtab <- liftFinalize getValueSymtab+  symtab <- getValueSymtab   return $! fmap renderName          $  IntMap.lookup n (valSymtab symtab) `mplus`             IntMap.lookup n (fnSymtab symtab)  -- | Lookup the name of an entry.-entryName :: Int -> Parse String+entryName :: (HasParseEnv m, HasValueTable m, MonadFail m) => Int -> m String entryName n = do   mentry <- entryNameMb n   case mentry of     Just name -> return name     Nothing   ->       do isRel  <- getRelIds-         symtab <- liftFinalize getValueSymtab+         symtab <- getValueSymtab          fail $ unlines            [ "entry " ++ show n ++ (if isRel then " (relative)" else "")               ++ " is missing from the symbol table"            , show symtab ]  -- | Lookup the name of a basic block.-bbEntryName :: Int -> Finalize (Maybe BlockLabel)-bbEntryName n = do-  symtab <- getValueSymtab-  return (mkBlockLabel <$> IntMap.lookup n (bbSymtab symtab))+bbEntryName :: Maybe Symbol -> Int -> Finalize (Maybe BlockLabel)+bbEntryName mbSym n =+  fmap mkBlockLabel+  <$> case mbSym of+        Just fn -> do+          -- Lookup entry in a function (Defines) symbol table+          funcSyms <- asks parsedFuncSymtabs+          return (IntMap.lookup n . bbSymtab =<< Map.lookup fn funcSyms)+        Nothing -> do+          -- Lookup entry in global (top-level) symbol table+          symtab <- getValueSymtab+          return (IntMap.lookup n (bbSymtab symtab))  -- | Lookup the name of a basic block.-requireBbEntryName :: Int -> Finalize BlockLabel-requireBbEntryName n = do-  mb <- bbEntryName n+requireBbEntryName :: Maybe Symbol -> Int -> Finalize BlockLabel+requireBbEntryName mbSym n = do+  mb <- bbEntryName mbSym n   case mb of     Just l  -> return l-    Nothing -> fail ("basic block " ++ show n ++ " has no id")+    Nothing -> fail ("basic block " ++ show n ++ " / " ++ show mbSym ++ " has no id")  -- Type Symbol Tables ---------------------------------------------------------- @@ -734,11 +792,103 @@ resolveStrtabSymbol (Strtab bs) start len =   Symbol $ UTF8.decode $ BS.unpack $ BS.take len $ BS.drop start bs +-- Parser Warnings -------------------------------------------------------------++-- | Warnings about non-fatal issues that arise during parsing.+data ParseWarning+  = -- | The parser encountered a metadata record with an unexpected size.+    -- The 'Int' is the actual record size that was encountered, the+    -- 'MetadataRecordSizeRange' is the expected range of possible sizes, and+    -- the @[String]@ is the stack trace at the point where the warning was+    -- emitted.+    InvalidMetadataRecordSize !Int !MetadataRecordSizeRange ![String]+  deriving Show++-- | The expected size of a metadata record.+data MetadataRecordSizeRange+  = -- | The size is expected between a lower bound (the first 'Int') and an+    -- upper bound (the second 'Int'), inclusive.+    MetadataRecordSizeBetween !Int !Int++  | -- | The size is expected to be within a certain list of possible values.+    MetadataRecordSizeIn ![Int]++  | -- The size is expected to be greater than or equal to a certain value.+    MetadataRecordSizeAtLeast !Int+  deriving Show++-- | Append a 'ParseWarning' to the end of the currently accumulated warnings.+addParseWarning :: ParseWarning -> Parse ()+addParseWarning pw = Parse $ do+  ps <- get+  put $! ps { psWarnings = psWarnings ps Seq.|> pw }++-- | Pretty-print a single 'ParseWarning' in a format suitable for user-facing+-- messages. (See also 'ppParseWarnings', which pretty-prints several+-- 'ParseWarnings's in a cohesive way.)+ppParseWarning :: ParseWarning -> PP.Doc+ppParseWarning (InvalidMetadataRecordSize len range cxt) =+  PP.vcat $+    [ "Invalid record size:" PP.<+> PP.pPrint len+    , expectedSizeMsg+    ] ++ map PP.text (formatContext cxt)+  where+    expectedSizeMsg :: PP.Doc+    expectedSizeMsg =+      case range of+        MetadataRecordSizeBetween lb ub ->+          "Expected size between" PP.<+> PP.pPrint lb+            PP.<+> "and" PP.<+> PP.pPrint ub+        MetadataRecordSizeIn ns ->+          "Expected one of:" PP.<+> PP.pPrint ns+        MetadataRecordSizeAtLeast lb ->+          "Expected size of" PP.<+> PP.pPrint lb PP.<+> "or greater"++-- | Pretty-print a group of 'ParseWarning's in a format suitable for+-- user-facing messages.+ppParseWarnings :: Seq.Seq ParseWarning -> PP.Doc+ppParseWarnings warnings+  | null warnings+  = PP.empty+  | otherwise+  = PP.vcat $+      ["Encountered the following warnings during parsing:"] +++      map+        (\warning ->+          PP.nest 4 $ PP.vcat [ppParseWarning warning, ""])+        (F.toList warnings) +++      [supportMsg | any isInvalidMetadataRecordSize warnings]+  where+    isInvalidMetadataRecordSize :: ParseWarning -> Bool+    isInvalidMetadataRecordSize (InvalidMetadataRecordSize {}) = True++    supportMsg :: PP.Doc+    supportMsg =+      PP.vcat+        [ "Are you sure you're using a supported version of LLVM/Clang?"+        , "Check here: https://github.com/GaloisInc/llvm-pretty-bc-parser"+        ]+ -- Finalize Monad -------------------------------------------------------------- +-- | During the "finalization" pass, all references should be resolved, including+-- actual Block label value references, which may be to either global or+-- function-local targets.  The 'Finalize' Monad provides access to the tables+-- needed to perform this resolution via the 'FinalizeEnv' data in a Reader monad+-- context.++data FinalizeEnv = FinalizeEnv+                   { parsedEnv :: Env+                   , parsedMdTable :: ValueTable+                   , parsedValueTable :: ValueTable+                   , parsedFuncSymtabs :: FuncSymTabs+                   }++type FuncSymTabs = Map.Map Symbol ValueSymtab+ newtype Finalize a = Finalize-  { unFinalize :: ReaderT Env (Except Error) a-  } deriving (Functor, Applicative)+  { unFinalize :: ReaderT FinalizeEnv (Except Error) a+  } deriving (Functor, Applicative, MonadReader FinalizeEnv)  instance Monad Finalize where #if !MIN_VERSION_base(4,11,0)@@ -772,19 +922,41 @@   {-# INLINE mplus #-}   mplus = (<|>) +instance HasParseEnv Finalize where+  getContext = asks $ envContext . parsedEnv+  getValueSymtab = asks $ symValueSymtab . envSymtab . parsedEnv++instance HasMdTable Finalize where+  getMdTable = asks parsedMdTable++instance HasValueTable Finalize where+  getValueTable = asks parsedValueTable+ -- | Fail, taking into account the current context. failWithContext' :: String -> Finalize a failWithContext' msg =   Finalize $-  do env <- ask+  do env <- asks parsedEnv      throwError Error        { errMessage = msg        , errContext = envContext env        } -liftFinalize :: Finalize a -> Parse a-liftFinalize (Finalize m) =-  do env <- Parse ask-     case runExcept (runReaderT m env) of-       Left err -> Parse (throwError err)+-- | Run a Finalize Monad operation in the context of a Parse monad.  The+-- information for the 'FinalizeEnv' is obtained from the Parse monad's 'Env',+-- plus the VALUE_SYMTAB_BLOCK information for each function as mapped by the+-- function's name.++liftFinalize :: FuncSymTabs -> Finalize a -> Parse a+liftFinalize defs (Finalize m) =+  do env <- ask+     mdt <- getMdTable+     valt <- getValueTable+     let fenv = FinalizeEnv { parsedEnv = env+                            , parsedMdTable = mdt+                            , parsedValueTable = valt+                            , parsedFuncSymtabs = defs+                            }+     case runExcept (runReaderT m fenv) of+       Left err -> throwError err        Right a -> return a