diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/disasm-test/Main.hs b/disasm-test/Main.hs --- a/disasm-test/Main.hs +++ b/disasm-test/Main.hs @@ -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 diff --git a/disasm-test/tests/localstatic.ll b/disasm-test/tests/localstatic.ll new file mode 100644 --- /dev/null +++ b/disasm-test/tests/localstatic.ll @@ -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) diff --git a/doc/developing.md b/doc/developing.md new file mode 100644 --- /dev/null +++ b/doc/developing.md @@ -0,0 +1,100 @@ +# Developers' documentation + + +**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) + + + +## 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) diff --git a/llvm-disasm/LLVMDis.hs b/llvm-disasm/LLVMDis.hs --- a/llvm-disasm/LLVMDis.hs +++ b/llvm-disasm/LLVMDis.hs @@ -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 diff --git a/llvm-pretty-bc-parser.cabal b/llvm-pretty-bc-parser.cabal --- a/llvm-pretty-bc-parser.cabal +++ b/llvm-pretty-bc-parser.cabal @@ -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 @@ -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, diff --git a/src/Data/LLVM/BitCode.hs b/src/Data/LLVM/BitCode.hs --- a/src/Data/LLVM/BitCode.hs +++ b/src/Data/LLVM/BitCode.hs @@ -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 diff --git a/src/Data/LLVM/BitCode/IR/Function.hs b/src/Data/LLVM/BitCode/IR/Function.hs --- a/src/Data/LLVM/BitCode/IR/Function.hs +++ b/src/Data/LLVM/BitCode/IR/Function.hs @@ -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 ------------------------------------------------------ diff --git a/src/Data/LLVM/BitCode/IR/Globals.hs b/src/Data/LLVM/BitCode/IR/Globals.hs --- a/src/Data/LLVM/BitCode/IR/Globals.hs +++ b/src/Data/LLVM/BitCode/IR/Globals.hs @@ -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 diff --git a/src/Data/LLVM/BitCode/IR/Metadata.hs b/src/Data/LLVM/BitCode/IR/Metadata.hs --- a/src/Data/LLVM/BitCode/IR/Metadata.hs +++ b/src/Data/LLVM/BitCode/IR/Metadata.hs @@ -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 diff --git a/src/Data/LLVM/BitCode/IR/Module.hs b/src/Data/LLVM/BitCode/IR/Module.hs --- a/src/Data/LLVM/BitCode/IR/Module.hs +++ b/src/Data/LLVM/BitCode/IR/Module.hs @@ -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 diff --git a/src/Data/LLVM/BitCode/IR/Values.hs b/src/Data/LLVM/BitCode/IR/Values.hs --- a/src/Data/LLVM/BitCode/IR/Values.hs +++ b/src/Data/LLVM/BitCode/IR/Values.hs @@ -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 diff --git a/src/Data/LLVM/BitCode/Parse.hs b/src/Data/LLVM/BitCode/Parse.hs --- a/src/Data/LLVM/BitCode/Parse.hs +++ b/src/Data/LLVM/BitCode/Parse.hs @@ -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