llvm-pretty-bc-parser 0.5.1.0 → 0.6.0.0
raw patch · 29 files changed
+1089/−355 lines, 29 filesdep +prettyprinter-convert-ansi-wl-pprintdep +tree-diffdep ~llvm-prettydep ~optparse-applicativePVP ok
version bump matches the API change (PVP)
Dependencies added: prettyprinter-convert-ansi-wl-pprint, tree-diff
Dependency ranges changed: llvm-pretty, optparse-applicative
API changes (from Hackage documentation)
+ Data.LLVM.Internal: assertRecordSizeAtLeast :: Record -> Int -> Parse ()
+ Data.LLVM.Internal: assertRecordSizeBetween :: Record -> Int -> Int -> Parse ()
+ Data.LLVM.Internal: assertRecordSizeIn :: Record -> [Int] -> Parse ()
+ Data.LLVM.Internal: parseDebugLoc :: (Num scope, Bits scope, Num ia, Bits ia) => Int -> (scope -> Parse (ValMd' r)) -> (ia -> Parse (Maybe (ValMd' r))) -> Record -> Parse (DebugLoc' r)
Files
- CHANGELOG.md +28/−0
- README.md +46/−32
- disasm-test/Instances.hs +95/−0
- disasm-test/Main.hs +162/−90
- disasm-test/tests/T258.ll +59/−0
- disasm-test/tests/T258.pre-llvm17.ll +4/−0
- disasm-test/tests/T266-constant-icmp.ll +1/−7
- disasm-test/tests/T266-constant-icmp.pre-llvm19.ll +7/−0
- disasm-test/tests/icmp-samesign.ll +5/−0
- disasm-test/tests/icmp-samesign.pre-llvm20.ll +4/−0
- disasm-test/tests/inrange_arg.post-llvm18.ll +7/−0
- disasm-test/tests/inrange_arg.pre-llvm19.ll +3/−0
- disasm-test/tests/trunc-nuw-nsw.ll +8/−0
- disasm-test/tests/trunc-nuw-nsw.pre-llvm20.ll +4/−0
- disasm-test/tests/uitofp-nneg.ll +5/−0
- disasm-test/tests/uitofp-nneg.pre-llvm19.ll +4/−0
- disasm-test/tests/zext-nneg.ll +5/−0
- disasm-test/tests/zext-nneg.pre-llvm18.ll +4/−0
- doc/developing.md +21/−0
- fuzzing/Main.hs +83/−30
- llvm-pretty-bc-parser.cabal +15/−3
- src/Data/LLVM/BitCode/Bitstream.hs +10/−2
- src/Data/LLVM/BitCode/IR/Constants.hs +117/−31
- src/Data/LLVM/BitCode/IR/Function.hs +166/−45
- src/Data/LLVM/BitCode/IR/Metadata.hs +186/−105
- src/Data/LLVM/BitCode/IR/Values.hs +10/−3
- src/Data/LLVM/BitCode/Parse.hs +17/−5
- src/Data/LLVM/CFG.hs +1/−1
- unit-test/Tests/ExpressionInstances.hs +12/−1
CHANGELOG.md view
@@ -1,5 +1,33 @@ # Revision history for llvm-pretty-bc-parser +## 0.6.0.0 -- 2026-01-23++* Updates for supporting LLVM-19:+ * Parsing of new `DebugRecord` values.+ * Parsing of new `GEPAttrs` flags for `GEP` instruction and constant+ expression.+ * Parsing for new `DICompositeType` fields added in LLVM 19.+ * Parsing of `num_extra_inhabitants` in `DIBasicType`.+* Updates for supporting new flags in cast-related instructions:+ * Support parsing `zext` instructions that use the `nneg` flag, indicating+ that the argument must be non-negative.+ * Support parsing `zext` and `uitofp` instructions that use the `nneg` flag,+ indicating that the argument must be non-negative.+ * Support parsing `trunc` instructions that use the `nuw` or `nsw` flags,+ indicating that the result should not result in unsigned or signed overflow,+ respectively.+* Support parsing `icmp` instructions that use the `samesign` flag (introduced+ in LLVM 20), indicating that the arguments must have the same sign.+* Support parsing `atomGroup` and `atomRank` fields in `DebugLoc` values+ (introduced in LLVM 21).+* Support parsing `column`, `isArtificial`, and `coroSuspendIdx` fields in+ `DILabel` values (introduced in LLVM 21).+* Support parsing non-constant sizes and offsets in `DIBasicType`,+ `DICompositeType`, and `DIDerivedType` values (a feature introduced in LLVM+ 21).+* Fix a bug in which `i1 true` literals would be parsed as+ `i1 18446744073709551615` in certain cases.+ ## 0.5.1.0 (October 2025) * Support parsing data layout strings that specify function pointer alignment.
README.md view
@@ -13,38 +13,32 @@ - A check in the manual tests column indicates that the parser seems to work on some code that was generated by this compiler. -| Compiler | Version | [Randomized tests](./fuzzing) | Manual tests | Notes |-|-----------|---------|-------------------------------|--------------|----------------------|-| `clang` | v3.4 | ✓ | | |-| | v3.5 | ✓ | | |-| | v3.6 | ✓ | | |-| | v3.7 | ✓ | | |-| | v3.8 | ✓ | ✓ | |-| | v3.9 | ✓ | | |-| | v4.0 | ✓ | | |-| | v5.0 | ✓ | | |-| | v6.0 | ✓ | ✓ | |-| | v7.0 | ✓ | | |-| | v8.0 | ✓ | | |-| | v9.0 | ✓ | | |-| | v10.0 | ✓ | | |-| | v11.0 | ✓ | | |-| | v12.0 | ✓ | | |-| | v13.0 | ✓ | | See [issues][llvm13] |-| | v14.0 | ✓ | | See [issues][llvm14] |-| | v15.0 | ✓ | | See [issues][llvm15] |-| | v16.0 | ✓ | | See [issues][llvm16] |-| `clang++` | v3.4 | | | |-| | v3.5 | | | |-| | v3.6 | | | |-| | v3.7 | | | |-| | v3.8 | | | |-| | v3.9 | | | |-| | v4.0 | | | |-| | v5.0 | | | |-| | v6.0 | | | |-| | v7.0 | | ✓ | |-| | v8.0 | | | |+| Compiler | Version | [Randomized tests](./fuzzing) | Manual tests | Notes |+|-----------|---------|-------------------------------|--------------|-----------------------|+| `clang` | v3.4 | ✓ | | See [issues][llvm3.4] |+| | v3.5 | ✓ | | See [issues][llvm3.5] |+| | v3.6 | ✓ | | See [issues][llvm3.6] |+| | v3.7 | ✓ | | See [issues][llvm3.7] |+| | v3.8 | ✓ | ✓ | See [issues][llvm3.8] |+| | v3.9 | ✓ | | See [issues][llvm3.9] |+| | v4 | ✓ | | See [issues][llvm4] |+| | v5 | ✓ | | See [issues][llvm5] |+| | v6 | ✓ | ✓ | See [issues][llvm6] |+| | v7 | ✓ | | See [issues][llvm7] |+| | v8 | ✓ | | See [issues][llvm8] |+| | v9 | ✓ | | See [issues][llvm9] |+| | v10 | ✓ | ✓ | See [issues][llvm10] |+| | v11 | ✓ | ✓ | See [issues][llvm11] |+| | v12 | ✓ | ✓ | See [issues][llvm12] |+| | v13 | ✓ | ✓ | See [issues][llvm13] |+| | v14 | ✓ | ✓ | See [issues][llvm14] |+| | v15 | ✓ | ✓ | See [issues][llvm15] |+| | v16 | ✓ | ✓ | See [issues][llvm16] |+| | v17 | ✓ | ✓ | See [issues][llvm17] |+| | v18 | ✓ | ✓ | See [issues][llvm18] |+| | v19 | ✓ | ✓ | See [issues][llvm19] |+| | v20 | ✓ | ✓ | See [issues][llvm20] |+| | v21 | ✓ | ✓ | See [issues][llvm21] | If you encounter problems with the output of *any* compiler, please file [an issue](https://github.com/GaloisInc/llvm-pretty-bc-parser/issues).@@ -64,7 +58,27 @@ - GHC 9.10.1 [fuzz-workflow]: https://github.com/GaloisInc/llvm-pretty-bc-parser/blob/master/.github/workflows/llvm-quick-fuzz.yml+[llvm3.4]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F3.4+[llvm3.5]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F3.5+[llvm3.6]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F3.6+[llvm3.7]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F3.7+[llvm3.8]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F3.8+[llvm3.9]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F3.9+[llvm4]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F4.0+[llvm5]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F5.0+[llvm6]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F6.0+[llvm7]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F7.0+[llvm8]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F8.0+[llvm9]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F9.0+[llvm10]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F10.0+[llvm11]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F11.0+[llvm12]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F12.0 [llvm13]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F13.0 [llvm14]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F14.0 [llvm15]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F15.0 [llvm16]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F16.0+[llvm17]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F17.0+[llvm18]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F18.0+[llvm19]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F19.0+[llvm20]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F20.0+[llvm21]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F21.0
+ disasm-test/Instances.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Instances where++import Data.TreeDiff+import qualified Text.LLVM.AST as AST+import Text.LLVM.Triple as Triple++deriving instance ToExpr (AST.Type' AST.Ident)+deriving instance ToExpr (AST.Typed AST.Ident)+deriving instance ToExpr (AST.Typed AST.Value)+deriving instance ToExpr AST.Alignment+deriving instance ToExpr AST.ArithOp+deriving instance ToExpr AST.AtomicOrdering+deriving instance ToExpr AST.AtomicRWOp+deriving instance ToExpr AST.BasicBlock+deriving instance ToExpr AST.BitOp+deriving instance ToExpr AST.BlockLabel+deriving instance ToExpr AST.Clause+deriving instance ToExpr AST.ConstExpr+deriving instance ToExpr AST.ConvOp+deriving instance ToExpr AST.DIArgList+deriving instance ToExpr AST.DIBasicType+deriving instance ToExpr AST.DICompileUnit+deriving instance ToExpr AST.DICompositeType+deriving instance ToExpr AST.DIDerivedType+deriving instance ToExpr AST.DIExpression+deriving instance ToExpr AST.DIFile+deriving instance ToExpr AST.DIGlobalVariable+deriving instance ToExpr AST.DIGlobalVariableExpression+deriving instance ToExpr AST.DIImportedEntity+deriving instance ToExpr AST.DILabel+deriving instance ToExpr AST.DILexicalBlock+deriving instance ToExpr AST.DILexicalBlockFile+deriving instance ToExpr AST.DILocalVariable+deriving instance ToExpr AST.DINameSpace+deriving instance ToExpr AST.DISubprogram+deriving instance ToExpr AST.DISubrange+deriving instance ToExpr AST.DISubroutineType+deriving instance ToExpr AST.DITemplateTypeParameter+deriving instance ToExpr AST.DITemplateValueParameter+deriving instance ToExpr AST.DbgRecAssign+deriving instance ToExpr AST.DbgRecDeclare+deriving instance ToExpr AST.DbgRecLabel+deriving instance ToExpr AST.DbgRecValue+deriving instance ToExpr AST.DbgRecValueSimple+deriving instance ToExpr AST.DebugInfo+deriving instance ToExpr AST.DebugLoc+deriving instance ToExpr AST.DebugRecord+deriving instance ToExpr AST.Declare+deriving instance ToExpr AST.Define+deriving instance ToExpr AST.FCmpOp+deriving instance ToExpr AST.FP80Value+deriving instance ToExpr AST.FloatType+deriving instance ToExpr AST.FunAttr+deriving instance ToExpr AST.FunctionPointerAlignType+deriving instance ToExpr AST.GC+deriving instance ToExpr AST.GEPAttr+deriving instance ToExpr AST.Global+deriving instance ToExpr AST.GlobalAlias+deriving instance ToExpr AST.GlobalAttrs+deriving instance ToExpr AST.ICmpOp+deriving instance ToExpr AST.Ident+deriving instance ToExpr AST.Instr+deriving instance ToExpr AST.LayoutSpec+deriving instance ToExpr AST.Linkage+deriving instance ToExpr AST.Mangling+deriving instance ToExpr AST.Module+deriving instance ToExpr AST.NamedMd+deriving instance ToExpr AST.PointerSize+deriving instance ToExpr AST.PrimType+deriving instance ToExpr AST.RangeSpec+deriving instance ToExpr AST.SelectionKind+deriving instance ToExpr AST.Stmt+deriving instance ToExpr AST.Storage+deriving instance ToExpr AST.Symbol+deriving instance ToExpr AST.TypeDecl+deriving instance ToExpr AST.UnaryArithOp+deriving instance ToExpr AST.UnnamedMd+deriving instance ToExpr AST.ValMd+deriving instance ToExpr AST.Value+deriving instance ToExpr AST.Visibility+deriving instance ToExpr Arch+deriving instance ToExpr Environment+deriving instance ToExpr OS+deriving instance ToExpr ObjectFormat+deriving instance ToExpr SubArch+deriving instance ToExpr Triple.TargetTriple+deriving instance ToExpr Vendor+++-- deriving instance ToExpr AST.DwarfAttrEncoding
disasm-test/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}@@ -21,8 +22,9 @@ import Data.Bifunctor (first) import qualified Data.ByteString.Lazy as L import Data.Char (ord,isLetter,isSpace,chr)+import Data.Function ( on ) import Data.Generics (everywhere, mkT) -- SYB-import Data.List ( find, isInfixOf, isPrefixOf, isSuffixOf, nub, sort )+import Data.List ( find, isInfixOf, isPrefixOf, isSuffixOf, nub, sort , groupBy, sortBy ) import Data.Map ( (!), (!?) ) import qualified Data.Map as Map import Data.Maybe ( fromMaybe )@@ -30,6 +32,7 @@ import Data.Sequence ( Seq ) import Data.String.Interpolate import qualified Data.Text as T+import Data.TreeDiff import Data.Typeable (Typeable) import Data.Versions (Versioning, versioning, prettyV, major, minor) import qualified GHC.IO.Exception as GE@@ -40,7 +43,8 @@ import System.Directory ( doesFileExist, getTemporaryDirectory , listDirectory , removeFile )-import System.Exit (ExitCode(..), exitFailure, exitSuccess)+import System.Environment ( lookupEnv )+import System.Exit (exitFailure, exitSuccess) import System.FilePath ( (</>), (<.>) ) import System.IO (openBinaryTempFile,hClose,openTempFile,hPrint, hPutStrLn,stderr)@@ -49,16 +53,22 @@ import Test.Tasty import Test.Tasty.ExpectedFailure ( ignoreTestBecause , expectFailBecause )-import Test.Tasty.HUnit ( assertFailure, testCase )+import Test.Tasty.HUnit ( assertFailure, testCase, assertBool ) import qualified Test.Tasty.Options as TO import qualified Test.Tasty.Runners as TR import qualified Test.Tasty.Sugar as TS import Text.Read (readMaybe) import Text.Show.Pretty (ppShow) +import Instances () +#if MIN_VERSION_optparse_applicative(0, 18, 0) descr :: PP.Doc ann-descr = PP.vcat $+descr = PP.align $ PP.vcat $+#else+import Data.Text.Prettyprint.Convert.AnsiWlPprint+descr = toAnsiWlPprint $ PP.align $ PP.vcat $+#endif let block = PPU.reflow in [ block [iii| This test verifies that the llvm-pretty-bc-parser is capable of@@ -136,6 +146,14 @@ This mode ensures that the llvm-disasm will not fail, but it does not validate the results. |]+ , ""+ , block+ [iii|The DISASM_TEST_DIR environment variable can be set to the+ location of the disasm-test directory; this defaults to+ "disasm-test", but that is not useful unless the test is+ run from the top level of the llvm-pretty-bc-parser+ repository.+ |] ] -- Option Parsing --------------------------------------------------------------@@ -209,8 +227,8 @@ optionCLParser = TO.mkOptionCLParser $ OA.short 'd' -disasmTestIngredients :: VersionCheck -> [TR.Ingredient]-disasmTestIngredients llvmver =+disasmTestIngredients :: FilePath -> VersionCheck -> [TR.Ingredient]+disasmTestIngredients rootPath llvmver = includingOptions [ TO.Option (Proxy @LLVMAs) , TO.Option (Proxy @LLVMDis) , TO.Option (Proxy @Clang)@@ -218,19 +236,20 @@ , TO.Option (Proxy @Keep) , TO.Option (Proxy @Details) ] :- TS.sugarIngredients [ assemblyCube llvmver- , cCompilerCube llvmver- , ccCompilerCube llvmver ]+ TS.sugarIngredients [ assemblyCube rootPath llvmver+ , cCompilerCube rootPath llvmver+ , ccCompilerCube rootPath llvmver ] <> defaultIngredients parseCmdLine :: IO TO.OptionSet parseCmdLine = do TR.installSignalHandlers llvmver <- getLLVMAsVersion defaultLLVMAs+ rootPth <- getRootPath let disasmOptDescrs = TO.uniqueOptionDescriptions $ TR.coreOptions ++ TS.sugarOptions ++- TR.ingredientsOptions (disasmTestIngredients llvmver)+ TR.ingredientsOptions (disasmTestIngredients rootPth llvmver) (disasmOptWarns, disasmOptParser) = TR.optionParser disasmOptDescrs mapM_ (hPutStrLn IO.stderr) disasmOptWarns ts <- maybe 80 Term.width <$> Term.size@@ -239,7 +258,7 @@ OA.info (OA.helper <*> disasmOptParser) ( OA.fullDesc <> OA.header "llvm-pretty-bc-parser disassembly test suite"- <> OA.footerDoc (Just $ PP.align descr)+ <> OA.footerDoc (Just descr) ) @@ -308,6 +327,7 @@ -- | Run all provided tests. main :: IO () main = do+ rootPth <- getRootPath -- This is a bit more involved than a typical tasty `main` function. The -- problem is that the number of tests that we generate (via -- `withSugarGroups`) depends on the version of the --llvm-as argument,@@ -334,11 +354,11 @@ , "* clang version: " ++ showVC clangVC ] - knownBugs <- getKnownBugs- sweets1 <- TS.findSugar $ assemblyCube llvmAsVC- sweets2 <- TS.findSugar $ cCompilerCube llvmAsVC- sweets3 <- TS.findSugar $ ccCompilerCube llvmAsVC- sweets4 <- TS.findSugar $ bitcodeCube llvmAsVC+ knownBugs <- getKnownBugs rootPth+ sweets1 <- TS.findSugar $ assemblyCube rootPth llvmAsVC+ sweets2 <- TS.findSugar $ cCompilerCube rootPth llvmAsVC+ sweets3 <- TS.findSugar $ ccCompilerCube rootPth llvmAsVC+ sweets4 <- TS.findSugar $ bitcodeCube rootPth llvmAsVC atests <- TS.withSugarGroups sweets1 testGroup $ \s _ e -> runAssemblyTest llvmAsVC knownBugs s e ctests <- TS.withSugarGroups sweets2 testGroup@@ -349,7 +369,7 @@ $ \s _ e -> runRawBCTest llvmAsVC knownBugs s e let tests = atests <> ctests case TR.tryIngredients- (disasmTestIngredients llvmAsVC)+ (disasmTestIngredients rootPth llvmAsVC) disasmOpts (testGroup "Disassembly tests" [ testGroup ("llvm-as " <> showVC llvmAsVC) atests@@ -364,15 +384,18 @@ ok <- act if ok then exitSuccess else exitFailure - defaultMainWithIngredients (disasmTestIngredients llvmAsVC) $+ defaultMainWithIngredients (disasmTestIngredients rootPth llvmAsVC) $ testGroup "Disassembly tests" tests ---------------------------------------------------------------------- -- Assembly/disassembly tests -assemblyCube :: VersionCheck -> TS.CUBE-assemblyCube llvmver = TS.mkCUBE- { TS.inputDirs = ["disasm-test/tests"]+getRootPath :: IO FilePath+getRootPath = maybe "disasm-test" id <$> lookupEnv "DISASM_TEST_DIR"++assemblyCube :: FilePath -> VersionCheck -> TS.CUBE+assemblyCube rootPath llvmver = TS.mkCUBE+ { TS.inputDirs = [rootPath </> "tests"] , TS.rootName = "*.ll" , TS.separators = "." , TS.validParams = [ ("llvm-range", Just [ "recent-llvm"@@ -382,6 +405,11 @@ , "pre-llvm14" , "pre-llvm15" , "pre-llvm16"+ , "pre-llvm17"+ , "pre-llvm18"+ , "post-llvm18"+ , "pre-llvm19"+ , "pre-llvm20" ]) ] -- Somewhat unusually for tasty-sugar, we make the expectedSuffix the same@@ -397,21 +425,68 @@ -- (e.g. remove: root=poison.ll with exp=poison.pre-llvm12.ll). let rootExpSame s e = TS.rootFile s == TS.expectedFile e addExpFilter s = s { TS.expected = filter (rootExpSame s) $ TS.expected s }- in fmap (fmap addExpFilter) . rangeMatch llvmver cb+ in rangeMatch llvmver cb . fmap addExpFilter } +-- | This function is used to ensure that the ranges of the various Sweet+-- Expected files (e.g. pre-llvmX, post-llvmX) match the current LLVM tooling+-- version, filtering out all Sweets and Expecteds that do not match. rangeMatch :: MonadIO m => VersionCheck -> TS.CUBE -> [TS.Sweets] -> m [TS.Sweets] rangeMatch llvmver cb swts = do -- Perform ranged-matching of the llvm-range parameter against the version of -- llvm (reported by llvm-as) to filter the tasty-sugar expectations. Note -- that there is a built-in expectation here that there is only one llvm -- version available to the test.- TS.rangedParamAdjuster "llvm-range"- (readMaybe . drop (length ("pre-llvm" :: String)))- (<)- (vcVersioning llvmver ^? (_Right . major))- cb swts+ let llvmMajorVer = vcVersioning llvmver ^? (_Right . major)+ let getPreVer = readMaybe . drop (length ("pre-llvm" :: String))+ let getPostVer = readMaybe . drop (length ("post-llvm" :: String))+ -- Filter any expected entries for each sweet where the expected needs an+ -- /earlier/ version of LLVM than the available version of the LLVM tools.+ ts1 <- TS.rangedParamAdjuster "llvm-range" getPreVer (<) llvmMajorVer cb swts+ -- Filter any expected entries for each sweet where the expected needs a+ -- /later/ version of LLVM than the available version of the LLVM tools.+ ts2 <- TS.rangedParamAdjuster "llvm-range" getPostVer (>) llvmMajorVer cb ts1+ -- Only expect a single expected file for a particular LLVM range. For+ -- example, given two files: foo.pre-llvm18.ll and foo.pre-llvm15.ll, then if+ -- the available LLVM tool is version 16, use the former, and if the available+ -- LLVM tool is version 10, then use the latter. In other words, ranges+ -- occlude each other and use the strictest range match.+ let tightestLLVMMatch :: TS.Sweets -> TS.Sweets -> Ordering+ tightestLLVMMatch a b =+ let getLLVMRange s = case TS.expected s of+ -- Just expect one, and empties should be+ -- filtered, but make this total.+ (e:_) -> lookup "llvm-range" $ TS.expParamsMatch e+ [] -> Nothing+ better s1 s2 =+ -- if both pre-llvm, lower is better (sort is lowest-to-highest),+ -- and if both post-llvm, higher is better; if both match, either+ -- should work, so arbitrarily just compare the strings for a bias.+ if "pre-llvm" `isPrefixOf` s1+ then if "pre-llvm" `isPrefixOf` s2+ then (compare `on` getPreVer) s1 s2+ else compare s1 s2 -- arbitrary preference with consistent bias+ else if "post-llvm" `isPrefixOf` s1+ then if "post-llvm" `isPrefixOf` s2+ then (compare `on` getPostVer) s2 s1+ else compare s1 s2 -- arbitrary preference with consistent bias+ else compare s1 s2 -- arbitrary preference with consistent bias+ in case (getLLVMRange a, getLLVMRange b) of+ (Just (TS.Explicit as), Just (TS.Explicit bs)) -> better as bs+ (Just (TS.Assumed as), Just (TS.Assumed bs)) -> better as bs+ (Just (TS.Explicit _), _) -> LT+ (_, Just (TS.Explicit _)) -> GT+ (al, bl) -> compare al bl+ let selectFromGroup :: [TS.Sweets] -> [TS.Sweets]+ selectFromGroup = take 1 -- only the first element of each group+ . sortBy tightestLLVMMatch -- preferred ordering+ -- remove any group member with no targets+ . filter (not . null . TS.expected)+ return+ $ concat+ $ fmap selectFromGroup+ $ groupBy ((==) `on` TS.rootBaseName) ts2 -- group by base name -- | Returns true if this particular test should be skipped, which is signalled@@ -438,15 +513,15 @@ return $ (:[]) $ tmod $ testCaseM llvmVersion pfx $ with2Files (processLL pfx $ TS.rootFile sweet)- $ \(parsed1, ast) ->- case ast of+ $ \(parsed1, mb'ast) ->+ case mb'ast of Nothing -> return ()- Just ast1 ->+ Just (ast1, _) -> -- Re-assemble and re-disassemble with2Files (processLL pfx parsed1) $ \(_, mb'ast2) -> case mb'ast2 of- Just ast2 -> diffCmp ast1 ast2 -- Ensure that the ASTs match+ Just (ast2, _) -> cmpASTs ast1 ast2 -- Ensure that the ASTs match -- Ensure that the disassembled files match. -- This is usually too strict (and doesn't@@ -457,31 +532,29 @@ -- assembly: we need llvm-as to be able to -- re-assemble it. --- -- diffCmp parsed1 parsed2+ -- diff parsed1 parsed2 Nothing -> error "Failed processLL" -diffCmp :: FilePath -> FilePath -> TestM ()-diffCmp file1 file2 = do- let assertF = liftIO . assertFailure . unlines- (code, stdOut, stdErr) <- liftIO $- Proc.readCreateProcessWithExitCode (Proc.proc "diff" ["-u", file1, file2]) ""- case code of- ExitFailure _ -> assertF ["diff failed", stdOut, stdErr]- ExitSuccess ->- 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] +-- | Compare two ASTs to see if they are the same. Fundamentally this is just done+-- via (==) on the normalized ASTs, but this first uses the tree-diff package to+-- generate nicer output to allow focusing on the actual diffs rather than+-- leaving it to the user to analyze the large blobs to find out where.+cmpASTs :: AST.Module -> AST.Module -> TestM ()+cmpASTs ast1 ast2 = do+ let d = ediff ast1 ast2+ msg = "Differences (marked with + and - line prefixes:\n"+ <> show (prettyEditExprCompact d)+ liftIO $ assertBool msg $ ast1 == ast2 + -- Assembles the specified .ll file to bitcode, then disassembles it with -- llvm-dis. Also parses the bitcode with this library (effectively llvm-disasm) -- and prints the difference between the parsed version and the .ll file. -- Returns the library parsed version and the serialized AST from the library. -processLL :: FilePath -> FilePath -> TestM (FilePath, Maybe FilePath)+processLL :: FilePath -> FilePath -> TestM (FilePath, Maybe (AST.Module, FilePath)) processLL pfx f = do Details det <- gets showDetails when det $ liftIO $ putStrLn (showString f ": ")@@ -493,7 +566,7 @@ liftIO $ assertFailure $ unlines $ "failure" : map ("; " ++) (lines (formatError msg)) -parseBC :: FilePath -> FilePath -> TestM (FilePath, Maybe FilePath)+parseBC :: FilePath -> FilePath -> TestM (FilePath, Maybe (AST.Module, FilePath)) parseBC pfx bc = do withFile (X.handle (\(_ :: GE.IOException) -> return "LLVM llvm-dis failed to parse this file")@@ -503,15 +576,7 @@ Details dets <- gets showDetails when dets $ liftIO $ do -- Informationally display if there are differences between the llvm-dis- -- and llvm-disasm outputs, but no error if they differ. Note that the- -- arguments to this diff are not the same as those supplied to the diffCmp- -- function. The diff here is intended to supply additional information to- -- the user for diagnostics, and whitespace changes are likely unimportant- -- in that context; this diff does not determine the pass/fail status of- -- the testing. On the other hand, the diffCmp *does* determine if the- -- tests pass or fail, so ignoring whitespace in that determination would- -- potentially weaken the testing to an unsatisfactory degree and would- -- need more careful evaluation.+ -- and llvm-disasm outputs, but no error if they differ. putStrLn "## Output differences: LLVM's llvm-dis <--> this llvm-disasm" ignore (Proc.callProcess "diff" ["-u", "-b", "-B", "-w", norm, parsed]) putStrLn ("successfully parsed " ++ show pfx ++ " bitcode")@@ -536,14 +601,16 @@ -- assemblyCube always generates a superset of the compilerCube tests (i.e. when -- no .c or .cc file is present). -cCompilerCube :: VersionCheck -> TS.CUBE-cCompilerCube llvmver = (assemblyCube llvmver)- { TS.rootName = "*.(c|cc|cpp)"- , TS.sweetAdjuster = rangeMatch llvmver- }+cCompilerCube :: FilePath -> VersionCheck -> TS.CUBE+cCompilerCube rootPath llvmver =+ (assemblyCube rootPath llvmver)+ { TS.rootName = "*.(c|cc|cpp)"+ , TS.sweetAdjuster = rangeMatch llvmver+ } -ccCompilerCube :: VersionCheck -> TS.CUBE-ccCompilerCube llvmver = (cCompilerCube llvmver) { TS.rootName = "*.cc"}+ccCompilerCube :: FilePath -> VersionCheck -> TS.CUBE+ccCompilerCube rootPath llvmver =+ (cCompilerCube rootPath llvmver) { TS.rootName = "*.cc"} runCompileTest :: VersionCheck -> KnownBugs -> TS.Sweets -> TS.Expectation@@ -568,12 +635,12 @@ -- No round trip, so this just verifies that the bitcode could be -- parsed without generating an error. return ()- Just ast1 ->+ Just (ast1, _) -> -- Assemble and re-parse the bitcode to make sure it can be -- round-tripped successfully. with2Files (processLL pfx parsed1) $ \(_, mb'ast2) -> case mb'ast2 of- Just ast2 -> diffCmp ast1 ast2+ Just (ast2, _) -> cmpASTs ast1 ast2 Nothing -> error "failed processLL" -- fst is ignored because .ll files are not compared; see -- runAssemblyTest for details.@@ -582,12 +649,13 @@ ---------------------------------------------------------------------- -- Pre-existing bitcode tests tests -bitcodeCube :: VersionCheck -> TS.CUBE-bitcodeCube llvmver = (assemblyCube llvmver)- { TS.rootName = "*.bc"- , TS.inputDirs = ["disasm-test/bc_src_tests"]- , TS.sweetAdjuster = rangeMatch llvmver- }+bitcodeCube :: FilePath -> VersionCheck -> TS.CUBE+bitcodeCube rootPath llvmver =+ (assemblyCube rootPath llvmver)+ { TS.rootName = "*.bc"+ , TS.inputDirs = [rootPath </> "bc_src_tests"]+ , TS.sweetAdjuster = rangeMatch llvmver+ } runRawBCTest :: VersionCheck -> KnownBugs -> TS.Sweets -> TS.Expectation -> IO [TestTree]@@ -610,12 +678,12 @@ -- No round trip, so this just verifies that the bitcode could be -- parsed without generating an error. return ()- Just ast1 ->+ Just (ast1, _) -> -- Assemble and re-parse the bitcode to make sure it can be -- round-tripped successfully. with2Files (processLL pfx parsed1) $ \(_, mb'ast2) -> case mb'ast2 of- Just ast2 -> diffCmp ast1 ast2+ Just (ast2, _) -> cmpASTs ast1 ast2 Nothing -> error "Failed processLL" -- fst is ignored because .ll files are not compared; see -- runAssemblyTest for details.@@ -705,10 +773,13 @@ -- stripComments norm return norm --- | Usually, the ASTs aren't "on the nose" identical.--- The big thing is that the metadata numbering differs, so we zero out all--- metadata indices and sort the unnamed metadata list.--- Done with SYB (Scrap Your Boilerplate).+-- | Usually, the ASTs aren't "on the nose" identical. This applies some+-- normalization to the AST tree to remove AST items that are not important to+-- the semantic comparisons. Done with SYB (Scrap Your Boilerplate).+--+-- * The big thing is that the metadata numbering differs, so we zero out all+-- metadata indices and sort the unnamed metadata list.+-- normalizeModule :: AST.Module -> AST.Module normalizeModule = sorted . everywhere (mkT zeroValMdRef) . everywhere (mkT zeroNamedMd)@@ -725,7 +796,7 @@ -- | Parse a bitcode file using llvm-pretty, failing the test if the parser -- fails.-processBitCode :: FilePath -> FilePath -> TestM (FilePath, Maybe FilePath)+processBitCode :: FilePath -> FilePath -> TestM (FilePath, Maybe (AST.Module, FilePath)) processBitCode pfx file = do let handler :: X.SomeException -> IO (Either Error (AST.Module, Seq ParseWarning))@@ -768,9 +839,10 @@ Details det <- gets showDetails if roundtrip then do- tmp2 <- liftIO $ printToTempFile "ast" (ppShow (normalizeModule m'))+ let nM = normalizeModule m'+ tmp2 <- liftIO $ printToTempFile "ast" (ppShow nM) when det $ liftIO $ putStrLn $ "## parsed Bitcode to " <> parsed <> " and " <> tmp2- return (parsed, Just tmp2)+ return (parsed, Just (nM,tmp2)) else do when det $ liftIO $ putStrLn $ "## parsed Bitcode to " <> parsed return (parsed, Nothing)@@ -849,13 +921,13 @@ withFile :: TestM FilePath -> (FilePath -> TestM r) -> TestM r withFile iofile f = X.bracket iofile rmFile f -with2Files :: TestM (FilePath, Maybe FilePath)- -> ((FilePath, Maybe FilePath) -> TestM r)+with2Files :: TestM (FilePath, Maybe (AST.Module, FilePath))+ -> ((FilePath, Maybe (AST.Module, FilePath)) -> TestM r) -> TestM r with2Files iofiles f = let cleanup (tmp1, mbTmp2) = do rmFile tmp1- traverse rmFile mbTmp2+ traverse rmFile (snd <$> mbTmp2) in X.bracket iofiles cleanup f rmFile :: FilePath -> TestM ()@@ -882,9 +954,9 @@ -- markers and values in that file. This returned value should be passed to the -- isKnownBug function, along with the test information to determine if the test -- is associated with a known bug.-getKnownBugs :: IO KnownBugs-getKnownBugs = do- let kbdir = "disasm-test/known_bugs"+getKnownBugs :: FilePath -> IO KnownBugs+getKnownBugs rootPath = do+ let kbdir = rootPath </> "known_bugs" known <- listDirectory kbdir let interestingLine = ("##> " `isPrefixOf`) let addInterestingLine l = case words l of@@ -920,8 +992,8 @@ Nothing -> const False _ -> const True found = find matchOf $ Map.assocs knownBugs- getSummary (f,_) = (f- , head (fromMaybe [] (knownBugs ! f !? "summary:")- <> ["this is a known bug"])- )+ msg f = case fromMaybe [] (knownBugs ! f !? "summary:") of+ [] -> "this is a known bug"+ (h:_) -> h+ getSummary (f,_) = (f, msg f) in getSummary <$> found
+ disasm-test/tests/T258.ll view
@@ -0,0 +1,59 @@+; ModuleID = 'T258.c'+source_filename = "T258.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"++; Function Attrs: mustprogress nofree noinline norecurse nosync nounwind willreturn memory(none) uwtable+define dso_local void @f(ptr nocapture noundef %0) local_unnamed_addr #0 !dbg !10 {+ call void @llvm.dbg.value(metadata ptr %0, metadata !16, metadata !DIExpression()), !dbg !17+ ret void, !dbg !18+}++; Function Attrs: mustprogress nofree norecurse nosync nounwind willreturn memory(none) uwtable+define dso_local i32 @main() local_unnamed_addr #1 !dbg !19 {+ call void @llvm.dbg.assign(metadata i1 undef, metadata !23, metadata !DIExpression(), metadata !24, metadata ptr undef, metadata !DIExpression()), !dbg !25+ ret i32 0, !dbg !26+}++; Function Attrs: mustprogress nocallback nofree nosync nounwind speculatable willreturn memory(none)+declare void @llvm.dbg.assign(metadata, metadata, metadata, metadata, metadata, metadata) #2++; Function Attrs: nocallback nofree nosync nounwind speculatable willreturn memory(none)+declare void @llvm.dbg.value(metadata, metadata, metadata) #3++attributes #0 = { mustprogress nofree noinline norecurse nosync nounwind willreturn memory(none) uwtable "min-legal-vector-width"="0" "no-trapping-math"="true" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+cmov,+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "tune-cpu"="generic" }+attributes #1 = { mustprogress nofree norecurse nosync nounwind willreturn memory(none) uwtable "min-legal-vector-width"="0" "no-trapping-math"="true" "stack-protector-buffer-size"="8" "target-cpu"="x86-64" "target-features"="+cmov,+cx8,+fxsr,+mmx,+sse,+sse2,+x87" "tune-cpu"="generic" }+attributes #2 = { mustprogress nocallback nofree nosync nounwind speculatable willreturn memory(none) }+attributes #3 = { nocallback nofree nosync nounwind speculatable willreturn memory(none) }++!llvm.dbg.cu = !{!0}+!llvm.module.flags = !{!2, !3, !4, !5, !6, !7, !8}+!llvm.ident = !{!9}++!0 = distinct !DICompileUnit(language: DW_LANG_C11, file: !1, producer: "clang version 17.0.2 (https://github.com/llvm/llvm-project b2417f51dbbd7435eb3aaf203de24de6754da50e)", isOptimized: true, runtimeVersion: 0, emissionKind: FullDebug, splitDebugInlining: false, nameTableKind: None)+!1 = !DIFile(filename: "T258.c", directory: "/home/ryanscott/Documents/Hacking/Haskell/llvm-pretty-bc-parser/disasm-test/tests", checksumkind: CSK_MD5, checksum: "f929e28f718c84761ea699b3ede6b85d")+!2 = !{i32 7, !"Dwarf Version", i32 5}+!3 = !{i32 2, !"Debug Info Version", i32 3}+!4 = !{i32 1, !"wchar_size", i32 4}+!5 = !{i32 8, !"PIC Level", i32 2}+!6 = !{i32 7, !"PIE Level", i32 2}+!7 = !{i32 7, !"uwtable", i32 2}+!8 = !{i32 7, !"debug-info-assignment-tracking", i1 true}+!9 = !{!"clang version 17.0.2 (https://github.com/llvm/llvm-project b2417f51dbbd7435eb3aaf203de24de6754da50e)"}+!10 = distinct !DISubprogram(name: "f", scope: !1, file: !1, line: 1, type: !11, scopeLine: 1, flags: DIFlagPrototyped | DIFlagAllCallsDescribed, spFlags: DISPFlagDefinition | DISPFlagOptimized, unit: !0, retainedNodes: !15)+!11 = !DISubroutineType(types: !12)+!12 = !{null, !13}+!13 = !DIDerivedType(tag: DW_TAG_pointer_type, baseType: !14, size: 64)+!14 = !DIBasicType(name: "int", size: 32, encoding: DW_ATE_signed)+!15 = !{!16}+!16 = !DILocalVariable(name: "x", arg: 1, scope: !10, file: !1, line: 1, type: !13)+!17 = !DILocation(line: 0, scope: !10)+!18 = !DILocation(line: 1, column: 47, scope: !10)+!19 = distinct !DISubprogram(name: "main", scope: !1, file: !1, line: 3, type: !20, scopeLine: 3, flags: DIFlagPrototyped | DIFlagAllCallsDescribed, spFlags: DISPFlagDefinition | DISPFlagOptimized, unit: !0, retainedNodes: !22)+!20 = !DISubroutineType(types: !21)+!21 = !{!14}+!22 = !{!23}+!23 = !DILocalVariable(name: "x", scope: !19, file: !1, line: 4, type: !14)+!24 = distinct !DIAssignID()+!25 = !DILocation(line: 0, scope: !19)+!26 = !DILocation(line: 6, column: 3, scope: !19)
+ disasm-test/tests/T258.pre-llvm17.ll view
@@ -0,0 +1,4 @@+SKIP_TEST++This test case requires the use of the DIAssignID metadata node, which is only+available with LLVM 17 or later.
disasm-test/tests/T266-constant-icmp.ll view
@@ -1,7 +1,1 @@-@global_var = external constant [1 x i8]--define i64 @h() {- br i1 icmp ne (i32 ptrtoint (ptr @global_var to i32), i32 1), label %pc_1, label %pc_1-pc_1:- ret i64 0-}+SKIP_TEST icmp constexprs are no longer supported as of llvm-19
+ disasm-test/tests/T266-constant-icmp.pre-llvm19.ll view
@@ -0,0 +1,7 @@+@global_var = external constant [1 x i8]++define i64 @h() {+ br i1 icmp ne (i32 ptrtoint (ptr @global_var to i32), i32 1), label %pc_1, label %pc_1+pc_1:+ ret i64 0+}
+ disasm-test/tests/icmp-samesign.ll view
@@ -0,0 +1,5 @@+define void @test_icmp(i32 %a, i32 %b) {+ %res1 = icmp samesign ult i32 %a, %b+ %res2 = icmp ult i32 %a, %b+ ret void+}
+ disasm-test/tests/icmp-samesign.pre-llvm20.ll view
@@ -0,0 +1,4 @@+SKIP_TEST++This test case uses a samesign flag with an icmp instruction, which requires+LLVM 20 or later.
+ disasm-test/tests/inrange_arg.post-llvm18.ll view
@@ -0,0 +1,7 @@+; ModuleID = 'kwq_18.bc'+source_filename = "disasm-test/tests/inrange_arg.pre-llvm19.ll"++define ptr @constexpr() {+ ret ptr getelementptr inbounds ({ [4 x ptr], [4 x ptr] }, ptr null, i32 0, i32 1, i32 2)+ ret ptr getelementptr inbounds nuw inrange(-8, 8) (i8, ptr null, i64 16)+}
+ disasm-test/tests/inrange_arg.pre-llvm19.ll view
@@ -0,0 +1,3 @@+define i8** @constexpr() {+ ret i8** getelementptr inbounds ({ [4 x i8*], [4 x i8*] }, { [4 x i8*], [4 x i8*] }* null, i32 0, inrange i32 1, i32 2)+}
+ disasm-test/tests/trunc-nuw-nsw.ll view
@@ -0,0 +1,8 @@+define void @test_trunc(i64 %a) {+ %res1 = trunc nuw i64 %a to i32+ %res2 = trunc nsw i64 %a to i32+ %res3 = trunc nuw nsw i64 %a to i32+ %res4 = trunc nsw nuw i64 %a to i32+ %res5 = trunc i64 %a to i32+ ret void+}
+ disasm-test/tests/trunc-nuw-nsw.pre-llvm20.ll view
@@ -0,0 +1,4 @@+SKIP_TEST++This test case uses nuw/nsw flags with a trunc instruction, which requires LLVM+20 or later.
+ disasm-test/tests/uitofp-nneg.ll view
@@ -0,0 +1,5 @@+define void @test_uitofp(i32 %a) {+ %res1 = uitofp nneg i32 %a to float+ %res2 = uitofp i32 %a to float+ ret void+}
+ disasm-test/tests/uitofp-nneg.pre-llvm19.ll view
@@ -0,0 +1,4 @@+SKIP_TEST++This test case uses an nneg flag with a uitofp instruction, which requires LLVM+19 or later.
+ disasm-test/tests/zext-nneg.ll view
@@ -0,0 +1,5 @@+define void @test_zext(i32 %a) {+ %res1 = zext nneg i32 %a to i64+ %res2 = zext i32 %a to i64+ ret void+}
+ disasm-test/tests/zext-nneg.pre-llvm18.ll view
@@ -0,0 +1,4 @@+SKIP_TEST++This test case uses an nneg flag with an zext instruction, which requires LLVM+18 or later.
doc/developing.md view
@@ -97,4 +97,25 @@ - [The README](../README.md) - [The Cabal file](../llvm-pretty-bc-parser.cabal)'s `Tested-with` field - [The Nix flake](../flake.nix)++ Run `nix flake update [input-pkg ...]` (installing [`nix`](https://nixos.org)+ first if necessary) which will update the `flake.lock` file in the top level+ directory. If no `input-pkg` is specified, *all* inputs are updated.+ Optionally run `nix build ./#TESTS` to run the nix-based tests locally. Then+ commit the updated `flake.lock` file.++ Newer GHC versions are automatically available to the nix build, but may+ require updating the flake lockfile as described above to become visible.++ 1. To add new GHC versions to the `nix` builds, see the `ghc-version` list in+ the `nix-ci.yml` file.++ 2. Sometimes GHC versions are deprecated and removed from the latest `nix`+ builds. When this occurs, add a `nixpkgs` override in the `nix-ci.yml`+ file for the `build_old_GHC` job.++ The `flake.nix` file also specifies the range of LLVM versions that will be+ tested. See the comments in that file for updating this version range,+ beginning with the comment at the top of the file.+ - [CI workflows](../.github/workflows)
fuzzing/Main.hs view
@@ -13,9 +13,9 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe)-import Data.Monoid (mconcat, Endo(..))-import Data.Time- (defaultTimeLocale, formatTime, getZonedTime, iso8601DateFormat)+import Data.Monoid (Endo(..))+import Data.Time ( getZonedTime )+import Data.Time.Format.ISO8601 ( iso8601Show ) import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics (Generic)@@ -49,6 +49,14 @@ -- ^ Specific seeds to use in fuzzing; overrides 'optNumTests' , optSaveTests :: Maybe FilePath -- ^ Location to save failed tests+ , optDisasm :: FilePath+ -- ^ Command to run llvm-disasm. Default is "llvm-disasm" but can contain+ -- multiple words (e.g. "cabal run llvm-disasm").+ --+ -- Note that using "cabal run" is not recommended as it is slower and+ -- parallel invocations of "cabal run" can interfere with each other and+ -- cause spurious errors. Instead, do a "cabal build llvm-disasm" and then+ -- run $fuzz-llvm-disasm --disasm=$(cabal list-bin llvm-disasm) ...$ , optClangs :: [FilePath] -- ^ Clangs to use with the fuzzer , optClangFlags :: [String]@@ -80,6 +88,7 @@ optNumTests = 100 , optSeeds = Nothing , optSaveTests = Nothing+ , optDisasm = "llvm-disasm" , optClangs = ["clang"] , optClangFlags = ["-O -g -w"] , optIncludeDirs = []@@ -102,6 +111,8 @@ "specific Csmith seed to use; overrides -n" , Option "o" ["output"] (ReqArg setSaveTests "DIRECTORY") "directory to save failed tests"+ , Option "d" ["disasm"] (ReqArg setDisasm "STRING/FILEPATH")+ "specify the filepath or command words to run llvm-disasm" , Option "c" ["clang"] (ReqArg addClang "CLANG") "specify clang executables to use, e.g., `-c clang-3.8 -c clang-3.9'" , Option "" ["clang-flags"] (ReqArg addClangFlags "ARGS") $@@ -150,6 +161,9 @@ setSaveTests :: String -> Endo Options setSaveTests str = Endo (\opt -> opt { optSaveTests = Just str }) +setDisasm :: String -> Endo Options+setDisasm str = Endo $ \opt -> opt { optDisasm = str }+ addClang :: String -> Endo Options addClang str = Endo $ \opt -> if optClangs opt == optClangs defaultOptions@@ -214,6 +228,17 @@ let banner = "Usage: " ++ prog ++ " [OPTIONS]" putStrLn (usageInfo (unlines (errs ++ [banner])) options) +-- | The overall process for testing here is to run a number of tests+--+-- 1. Uses csmith to generate a random C program from a seed+-- 2. Compile the program with clang into a bitcode file+-- 3. Run our llvm-disasm to disassemble the bitcode file to a .ll file+-- 4. Run clang on the .ll file to create an "ours" executable+-- 5. Run clang on the .bc file to create a "golden" executable+-- 6. Run both executables with a timeout on each of 10 seconds+-- 7. Compare the stdout, stderr, and exit codes to ensure both+-- executables behave identically.+-- main :: IO () main = withTempDirectory "." ".fuzz." $ \tmpDir -> do opts <- getOptions@@ -242,14 +267,16 @@ let allResults' = Map.unions (concat resultMaps) allResults | optCollapse opts = collapseResults allResults' | otherwise = allResults'- forM_ (Map.toList allResults) $ \((clangExe, _, flags), results) -> do- let (_passes, fails) = partition isPass results- when (not (null fails)) $ do- putStrLn $ "[" ++ clangExe ++ " " ++ flags ++ "] " ++- show (length fails) ++ " failing cases identified:"- forM_ fails $ \case- TestFail st s _ _ -> putStrLn ("[" ++ show st ++ "] " ++ show s)- _ -> error "non-fail cases in fails"+ hadFails <- fmap or+ $ forM (Map.toList allResults) $ \((clangExe, _, flags), results) ->+ let (_passes, fails) = partition isPass results+ in do unless (null fails)+ $ do putStrLn $ "[" ++ clangExe ++ " " ++ flags ++ "] " +++ show (length fails) ++ " failing cases identified:"+ forM_ fails $ \case+ TestFail st s _ _ -> putStrLn ("[" ++ show st ++ "] " ++ show s)+ _ -> error "non-fail cases in fails"+ return $ not (null fails) case optSaveTests opts of Nothing -> return () Just root -> do@@ -279,6 +306,8 @@ Just f -> do xml <- mkJUnitXml allResults writeFile f (ppTopElement xml)+ when hadFails exitFailure+ exitSuccess reduce :: TestResult -> Clang -> Options -> FilePath -> IO () reduce (TestFail st _ TestSrc{..} err) (clangExe, includeDirs, flags) opts clangRoot = do@@ -303,7 +332,7 @@ -- waste our time [] -> Nothing -- drop the tab for the pattern- first:_ -> Just (tail first)+ first:_ -> Just (drop 1 first) grepPat AsStage = -- check the first line of the clang error for "error:" case (lines err) of@@ -329,20 +358,17 @@ clangExe, "-I", csmithPath, flags, "-c" , "-emit-llvm", baseName ++ "-reduced.c", "-o", bcFile ] ++ includeOpts- buildLl = unwords $- [ "llvm-disasm" ] ++- llvmVersionFlags ++- [ bcFile, ">", llFile ]+ buildLl = optDisasm opts+ <> (unwords $ llvmVersionFlags ++ [ bcFile, ">", llFile ]) copyBc = unwords [ "cp", bcFile, absClangRoot </> bcFile ] script DisasmStage = unlines $ scriptHeader ++ [ buildBc , copyBc- , unwords $- [ "llvm-disasm" ] ++- llvmVersionFlags ++- [ bcFile, "2>&1 |" , "grep", show (fromMaybe "" (grepPat st)) ]+ , optDisasm opts+ <> (unwords $ llvmVersionFlags +++ [ bcFile, "2>&1 |" , "grep", show (fromMaybe "" (grepPat st)) ]) ] script AsStage = unlines $ scriptHeader ++ [ buildBc@@ -432,12 +458,38 @@ srcFile = baseFile <.> "c" bcFile = baseFile <.> "bc" llFile = baseFile <.> "ll"- llvmVersionFlags =- case stripPrefix "clang-" clangExe of- Nothing -> []- Just ver -> [ "--llvm-version=" ++ ver ] includeOpts = concatMap (\dir -> ["-I", dir]) includeDirs- putStrLn $ "Testing bitcode file " ++ bcFile+ llvmVersionFlags <-+ case stripPrefix "clang-" clangExe of+ Just ver -> return [ "--llvm-version=" ++ ver ]+ Nothing ->+ do (ec,o,_err) <- readProcessWithExitCode "clang" [ "--version" ] ""+ if ec == ExitSuccess+ then case lines o of+ -- Expecting something like:+ --+ -- clang version 11.1.0 (....)+ -- Target: x86_64-unknown-linux-gnu+ -- Thread model: posix+ -- InstalledDir: ...+ --+ -- where the (....) on the first line may or may not be+ -- present and frequently specifies tag information or github+ -- commit info.+ (vline:_) -> -- First line+ case drop 2 $ words vline of+ (ver:_) -> -- Third word+ do let v = takeWhile (/= '.') ver+ -- putStrLn $ "Determined LLVM version " <> v <> " from clang --version output:"+ -- putStrLn o+ return [ "--llvm-version=" <> v ]+ [] -> do putStrLn $ "Warning: clang --version output line has no words"+ return []+ _ -> do putStrLn $ "Warning: clang --version output blank"+ return []+ else do putStrLn $ "Warning: no clang found to determine LLVM version"+ return []+ putStr $ "Testing bitcode file " ++ bcFile ++ " with " ++ show llvmVersionFlags ++ " ... " ---- Run csmith ---- csmithPath <- getCsmithPath opts callProcess "csmith" [@@ -459,7 +511,11 @@ ---- Disassemble ---- let disasmArgs = llvmVersionFlags ++ [ tmpDir </> bcFile ] (ec, out, err) <-- readProcessWithExitCode "llvm-disasm" disasmArgs ""+ let args = words $ optDisasm opts+ cmd = case args of+ [] -> "llvm-disasm"+ (c:_) -> c+ in readProcessWithExitCode cmd (drop 1 args <> disasmArgs) "" case ec of ExitFailure c -> do putStrLn "[DISASM ERROR]"@@ -537,10 +593,7 @@ mkJUnitXml allResults = do hostname <- readProcess "hostname" [] "" now <- getZonedTime- let nowFmt = formatTime- defaultTimeLocale- (iso8601DateFormat (Just "%H:%M:%S"))- now+ let nowFmt = iso8601Show now testsuites = map (testsuite hostname nowFmt) (Map.toList allResults) return $ unode "testsuites" testsuites where
llvm-pretty-bc-parser.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 Name: llvm-pretty-bc-parser-Version: 0.5.1.0+Version: 0.6.0.0 License: BSD-3-Clause License-file: LICENSE Author: Trevor Elliott <trevor@galois.com>@@ -28,6 +28,11 @@ Description: Enable regression testing build Default: False +Flag old-optparse+ Description: Enable pprint compatibility when using older optparse-applicative+ Default: False+ -- automatically enabled when the attempt to use the newer optparse fails+ Source-repository head type: git location: https://github.com/galoisinc/llvm-pretty-bc-parser@@ -74,7 +79,7 @@ bytestring >= 0.10, containers >= 0.4, fgl >= 5.5,- llvm-pretty >= 0.13.0.0 && < 0.14,+ llvm-pretty >= 0.14.0.0 && < 0.15, mtl >= 2.2.2, pretty >= 1.0.1, uniplate >= 1.6,@@ -127,6 +132,7 @@ Test-suite disasm-test type: exitcode-stdio-1.0 Main-is: Main.hs+ other-modules: Instances Default-language: Haskell2010 hs-source-dirs: disasm-test Ghc-options: -Wall@@ -138,7 +144,6 @@ exceptions >= 0.10 && < 0.11, filepath, lens,- optparse-applicative >= 0.18.1.0, pretty-show>= 1.6, prettyprinter >= 1.7 && < 1.8, string-interpolate >= 0.3 && < 0.4,@@ -148,11 +153,18 @@ tasty-hunit, tasty-sugar >= 2.2 && < 2.3, transformers >= 0.5 && < 0.7,+ tree-diff >= 0.2 && < 0.4, terminal-size >= 0.3 && < 0.4, text, versions < 7, llvm-pretty, llvm-pretty-bc-parser+ if flag(old-optparse)+ build-depends: optparse-applicative >= 0.17.0.0 && < 0.18.0.0,+ prettyprinter-convert-ansi-wl-pprint+ else+ build-depends: optparse-applicative >= 0.18.0.0+ Executable regression-test Main-is: Main.hs
src/Data/LLVM/BitCode/Bitstream.hs view
@@ -14,17 +14,18 @@ , getBitstream, parseBitstream , getBitCodeBitstream, parseBitCodeBitstream, parseBitCodeBitstreamLazy , parseMetadataStringLengths+ , flagsFromBits ) where import Data.LLVM.BitCode.BitString as BS import Data.LLVM.BitCode.GetBits import Control.Monad ( unless, replicateM, guard )-import Data.Bits ( Bits )+import Data.Bits ( Bits, testBit ) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map-import Data.Word ( Word8, Word16, Word32 )+import Data.Word ( Word8, Word16, Word32, Word64 ) -- Primitive Reads -------------------------------------------------------------@@ -67,6 +68,13 @@ 62 -> return (fromIntegral (fromEnum '.')) 63 -> return (fromIntegral (fromEnum '_')) _ -> fail "invalid char6"+++-- | Test the Word64 for bits set, and return the set of input flags whose+-- indices correspond to the set bits.+flagsFromBits :: [flag] -> Word64 -> [flag]+flagsFromBits flgs bf =+ foldl (\a (n,f) -> if testBit bf n then f:a else a) [] $ zip [0..] flgs -- Bitstream Parsing -----------------------------------------------------------
src/Data/LLVM/BitCode/IR/Constants.hs view
@@ -18,7 +18,7 @@ import Control.Monad (mplus,mzero,foldM,(<=<), when) import Control.Monad.ST (runST,ST) import Data.Array.ST (newArray,readArray,MArray,STUArray)-import Data.Bits (shiftL,shiftR,testBit, Bits)+import Data.Bits ( complement, shiftL, shiftR, testBit, (.&.), Bits ) import Data.LLVM.BitCode.BitString ( pattern Bits' ) import qualified Data.LLVM.BitCode.BitString as BitS import qualified Data.Map as Map@@ -152,31 +152,56 @@ where uaop op tv = ValConstExpr (ConstUnaryArith op tv) -castOpGeneric :: forall c. (ConvOp -> Maybe c) -> Match Field c+castOpGeneric ::+ forall c.+ (ConvOp -> Typed PValue -> Type -> c) ->+ Match Field (Maybe Int -> Typed PValue -> Type -> c) castOpGeneric op = choose <=< numeric where- choose :: Match Int c- choose 0 = op Trunc- choose 1 = op ZExt- choose 2 = op SExt- choose 3 = op FpToUi- choose 4 = op FpToSi- choose 5 = op UiToFp- choose 6 = op SiToFp- choose 7 = op FpTrunc- choose 8 = op FpExt- choose 9 = op PtrToInt- choose 10 = op IntToPtr- choose 11 = op BitCast+ constant c = return $ \_mb tv t -> op c tv t++ nuw x = testBit x 0+ nsw x = testBit x 1++ -- operations that accept the nuw and nsw flags+ wrapFlags c = return $ \mb tv t ->+ case mb of+ Nothing -> op (c False False) tv t+ Just w -> op (c (nuw w) (nsw w)) tv t++ nneg x = testBit x 0++ -- operations that accept the nneg flag+ nnegFlag c = return $ \mb tv t ->+ case mb of+ Nothing -> op (c False) tv t+ Just w -> op (c (nneg w)) tv t++ choose :: Match Int (Maybe Int -> Typed PValue -> Type -> c)+ choose 0 = wrapFlags Trunc+ choose 1 = nnegFlag ZExt+ choose 2 = constant SExt+ choose 3 = constant FpToUi+ choose 4 = constant FpToSi+ choose 5 = nnegFlag UiToFp+ choose 6 = constant SiToFp+ choose 7 = constant FpTrunc+ choose 8 = constant FpExt+ choose 9 = constant PtrToInt+ choose 10 = constant IntToPtr+ choose 11 = constant BitCast choose _ = mzero -castOp :: Match Field (Typed PValue -> Type -> PInstr)-castOp = castOpGeneric (return . Conv)+castOp :: Match Field (Maybe Int -> Typed PValue -> Type -> PInstr)+castOp = castOpGeneric Conv +-- NB: Unlike the type of 'castOp', this does not offer a @Maybe Int@ argument+-- in its callback. This is because at present, LLVM constant expressions do not+-- accept flags like their expression counterparts do. castOpCE :: Match Field (Typed PValue -> Type -> PValue)-castOpCE = castOpGeneric op+castOpCE i = (\p -> p Nothing) <$> castOpGeneric op i where- op c = return (\ tv t -> ValConstExpr (ConstConv c tv t))+ op c tv t = ValConstExpr (ConstConv c tv t) -- Constants Block ------------------------------------------------------------- @@ -231,7 +256,11 @@ ty <- getTy n <- field 0 signedWord64 let val = fromMaybe (ValInteger (toInteger n)) $ do- Integer 0 <- elimPrimType ty+ -- Include a special case for `i1`, as we would prefer to+ -- render values of this type as `false` or `true` instead of+ -- as integer literals. Note that `false` is always encoded as+ -- `0`, but `true` may be encoded as `1` or `-1`.+ Integer 1 <- elimPrimType ty return (ValBool (n /= 0)) return (getTy, Typed ty val:cs) @@ -322,7 +351,7 @@ return (getTy,Typed ty (cast' (forwardRef cxt opval t) ty):cs) -- [n x operands]- 12 -> label "CST_CODE_CE_GEP" $ do+ 12 -> label "CST_CODE_CE_GEP_OLD" $ do ty <- getTy v <- parseCeGep CeGepCode12 t r return (getTy,Typed ty v:cs)@@ -452,6 +481,20 @@ tv <- parseInlineAsm InlineAsmCode30 getTy r return (getTy, tv:cs) + 31 -> label "CST_CODE_CE_GEP_WITH_INRANGE" $ do+ ty <- getTy+ v <- parseCeGep CeGepCode31 t r+ return (getTy,Typed ty v:cs)++ -- [opty, flags, n x operands ] see https://github.com/llvm/llvm-project/commit/8cdecd4+ 32 -> label "CST_CODE_CE_GEP" $ do+ ty <- getTy+ v <- parseCeGep CeGepCode32 t r+ return (getTy,Typed ty v:cs)++ 33 -> label "CST_CODE_PTRAUTH (33)" $ do+ notImplemented+ code -> Assert.unknownEntity "constant record code" code parseConstantEntry _ st (abbrevDef -> Just _) =@@ -465,7 +508,7 @@ -- minor differences in how they are parsed. data CeGepCode = CeGepCode12- -- ^ @CST_CODE_CE_GEP = 12@. The original.+ -- ^ @CST_CODE_CE_GEP_OLD = 12@. The original. | CeGepCode20 -- ^ @CST_CODE_CE_INBOUNDS_GEP = 20@. This adds an @inbounds@ field that -- indicates that the result value should be poison if it performs an@@ -475,6 +518,15 @@ -- that indicates that loading or storing to the result pointer will have -- undefined behavior if the load or store would access memory outside of the -- bounds of the indices marked as @inrange@.+ | CeGepCode31+ -- ^ @CST_CODE_CE_GEP_WITH_INRANGE = 31@. This changes @inbounds@ to a set of+ -- flags (like CeGepCode32) and then encodes the range explicitly as a bitwidth+ -- followed by the lower and upper range values.+ | CeGepCode32+ -- ^ @CST_CODE_CE_GEP = 32@. This changes @inbounds@ to a set of flags 9like+ -- CeGepCode31 but without a range) where each flag has a set of rules that+ -- will result in poison if they are violated. Initial set of flags: inbounds,+ -- nusw, nuw. deriving Eq -- | Parse a 'ConstGEP' value. There are several variations on this theme that@@ -484,20 +536,33 @@ let field = parseField r (mbBaseTy, ix0) <-- if code == CeGepCode24 || odd (length (recordFields r))+ if not (code `elem` [ CeGepCode12+ , CeGepCode20+ ])+ || odd (length (recordFields r)) then do baseTy <- getType =<< field 0 numeric pure (Just baseTy, 1) else pure (Nothing, 0) - (isInbounds, mInrangeIdx, ix1) <-+ (optFlags, mInrangeIdx, ix1) <- case code of- CeGepCode12 -> pure (False, Nothing, ix0)- CeGepCode20 -> pure (True, Nothing, ix0)+ CeGepCode12 -> pure ([], Nothing, ix0)+ CeGepCode20 -> pure ([GEP_Inbounds, GEP_NUSW], Nothing, ix0) CeGepCode24 -> do (flags :: Word64) <- parseField r ix0 numeric let inbounds = testBit flags 0 inrangeIdx = flags `shiftR` 1- pure (inbounds, Just inrangeIdx, ix0 + 1)+ flgArr = if inbounds+ then [GEP_Inbounds, GEP_NUSW]+ else []+ pure (flgArr, Just (RangeIndex inrangeIdx), ix0 + 1)+ CeGepCode31 -> do+ flagArr <- flagsFromBits orderedGEPAttrs <$> parseField r ix0 numeric+ (range, newidx) <- getConstantRange r (ix0 + 1)+ pure (flagArr, Just range, newidx)+ CeGepCode32 -> do+ flagArr <- flagsFromBits orderedGEPAttrs <$> parseField r ix0 numeric+ pure (flagArr, Nothing, ix0 + 1) let loop n = do ty <- getType =<< field n numeric@@ -516,12 +581,33 @@ Just baseTy -> pure baseTy Nothing -> Assert.elimPtrTo "constant GEP not headed by pointer" (typedType ptr) - return $! ValConstExpr (ConstGEP isInbounds mInrangeIdx baseTy ptr args')+ return $! ValConstExpr (ConstGEP optFlags mInrangeIdx baseTy ptr args') -parseWideInteger :: Record -> Int -> Parse Integer-parseWideInteger r idx = do- limbs <- parseSlice r idx (length (recordFields r) - idx) signedWord64+-- see llvm/lib/Bitcode/Writer/BitcodeWriter.cpp: emitConstantRange+getConstantRange :: Record -> Int -> Parse (RangeSpec, Int)+getConstantRange r rix = do+ rangeWidth <- fromIntegral <$> (parseField r rix numeric :: Parse Word64) -- emitBitWidth true+ if rangeWidth > 64+ then do (sizes :: Word64) <- parseField r (rix+1) numeric+ let mask32 = fromIntegral (complement 0 :: Word32)+ lSize = fromIntegral $ sizes .&. mask32+ uSize = fromIntegral $ sizes `shiftR` 32+ l <- parseWideAPInt r (rix + 2) lSize+ u <- parseWideAPInt r (rix + 2 + lSize) uSize+ return (Range rangeWidth l u, rix + 2 + lSize + uSize)+ else do l <- fromIntegral <$> parseField r (rix+1) signedWord64+ u <- fromIntegral <$> parseField r (rix+2) signedWord64+ return (Range rangeWidth l u, rix+3)++-- | Parses an arbitrary precision integer value whose bit width is > 64. Upper+-- bits are typically 0, so this only parses the low n 64-bit words of the value.+parseWideAPInt :: Record -> Int -> Int -> Parse Integer+parseWideAPInt r ix n = do+ limbs <- parseSlice r ix n signedWord64 return (foldr (\l acc -> acc `shiftL` 64 + (toInteger l)) 0 limbs)++parseWideInteger :: Record -> Int -> Parse Integer+parseWideInteger r idx = parseWideAPInt r idx (length (recordFields r) - idx) resolveNull :: Type -> Parse PValue resolveNull ty = case typeNull ty of
src/Data/LLVM/BitCode/IR/Function.hs view
@@ -369,12 +369,13 @@ ValueTable -> PartialDefine -> Entry -> Parse PartialDefine -parseFunctionBlockEntry _ _ d (constantsBlockId -> Just es) = do- -- CONSTANTS_BLOCK+parseFunctionBlockEntry _ _ d (constantsBlockId -> Just es) =+ label "CONSTANTS_BLOCK" $ do parseConstantsBlock es return d -parseFunctionBlockEntry _ t d (fromEntry -> Just r) = case recordCode r of+parseFunctionBlockEntry _ t d (fromEntry -> Just r) =+ case recordCode r of -- [n] 1 -> label "FUNC_CODE_DECLARE_BLOCKS"@@ -396,7 +397,7 @@ -- designates the value of the exact flag. -- -- - If the instruction is floating-point, the extra field designates the- -- value of the fast-math flags. We currently ignore these.+ -- value of the fast-math flags. TODO(#61): We currently ignore these. -- -- The constructor returned from binop will use that value when -- constructing the binop.@@ -407,10 +408,25 @@ 3 -> label "FUNC_CODE_INST_CAST" $ do let field = parseField r (tv,ix) <- getValueTypePair t r 0- Assert.recordSizeIn r [ix + 2]+ Assert.recordSizeIn r [ix + 2, ix + 3] resty <- getType =<< field ix numeric cast' <- field (ix+1) castOp- result resty (cast' tv resty) d+ -- If there's an extra field on the end of the record, it's for one of the+ -- following:+ --+ -- - If the instruction is zext or uitpfp, the extra field designates the+ -- value of the nneg flag.+ --+ -- - If the instruction is trunc, the extra field designates the value of+ -- the nuw and nsw flags.+ --+ -- - If the instruction is fptrunc or fpext, the extra field designates the+ -- value of the fast-math flags. TODO(#61): We currently ignore these.+ --+ -- The constructor returned from castOp will use that value when+ -- constructing the cast-related operation.+ let mbWord = numeric =<< fieldAt (ix+2) r+ result resty (cast' mbWord tv resty) d 4 -> label "FUNC_CODE_INST_GEP_OLD" (parseGEP t (Just False) r d) @@ -561,7 +577,7 @@ args <- parsePhiArgs useRelIds t r when (even (length (recordFields r))) $ do- pure () -- TODO: fast math flags+ pure () -- TODO(#61): fast math flags result ty (Phi ty args) d @@ -671,7 +687,7 @@ (tv,ix) <- getValueTypePair t r 0 fv <- getValue t (typedType tv) =<< field ix numeric (c,_) <- getValueTypePair t r (ix+1)- -- XXX: we're ignoring the fast-math flags+ -- TODO(#61): we're ignoring the fast-math flags result (typedType tv) (Select c tv (typedValue fv)) d 30 -> label "FUNC_CODE_INST_INBOUNDS_GEP_OLD" (parseGEP t (Just True) r d)@@ -696,7 +712,7 @@ -- pal <- field 0 numeric -- N.B. skipping param attributes ccinfo <- field 1 numeric- let ix0 = if testBit ccinfo 17 then 3 else 2 -- N.B. skipping fast-math flags+ let ix0 = if testBit ccinfo 17 then 3 else 2 -- TODO(#61): skipping fast-math flags (mbFnTy, ix1) <- if testBit (ccinfo :: Word32) callExplicitTypeBit then do fnTy <- getType =<< field ix0 numeric return (Just fnTy, ix0+1)@@ -721,31 +737,15 @@ -- a pointer type. See Note [Typing function applications]. result ret (Call False fnty fn args) d - -- [Line,Col,ScopeVal, IAVal]+ -- [Line,Col,ScopeVal, IAVal, IsImplicit, atomGroup, atomRank]+ -- isImplicit: added LLVM 16+ -- atomGroup and atomRank: added LLVM 21 35 -> label "FUNC_CODE_DEBUG_LOC" $ do- Assert.recordSizeGreater r 3-- let field = parseField r- line <- field 0 numeric- col <- field 1 numeric- scopeId <- field 2 numeric- iaId <- field 3 numeric-- scope <- if scopeId > 0- then getMetadata (scopeId - 1)- else fail "No scope provided"-- ia <- if iaId > 0- then Just `fmap` getMetadata (iaId - 1)- else return Nothing-- let loc = DebugLoc- { dlLine = line- , dlCol = col- , dlScope = typedValue scope- , dlIA = typedValue `fmap` ia- , dlImplicit = False- }+ let lookupMetadata v = if v > 0+ then Just . typedValue <$> getMetadata (v-1)+ else return Nothing+ let resolveScope = maybe (fail "No scope provided") return <=< lookupMetadata+ loc <- parseDebugLoc 0 resolveScope lookupMetadata r setLastLoc loc updateLastStmt (extendMetadata ("dbg", ValMdLoc loc)) d @@ -952,7 +952,7 @@ let field = parseField r (v,ix) <- getValueTypePair t r 0 mkInstr <- field ix unop- -- XXX: we're ignoring the fast-math flags+ -- TODO(#61): we're ignoring the fast-math flags result (typedType v) (mkInstr v) d -- LLVM 9: [attr, cc, norm, transfs, fnty, fnid, args...]@@ -1001,7 +1001,93 @@ 59 -> label "FUNC_CODE_INST_ATOMICRMW" $ parseAtomicRMW False t r d + 60 -> label "FUNC_CODE_BLOCKADDR_USERS" $+ -- BLOCKADDR_USERS: [value..]+ notImplemented + 61 -> label "FUNC_CODE_DEBUG_RECORD_VALUE" $ do+ -- [DILocation, DILocalVariable, DIExpression, ValueAsMetadata]+ assertRecordSizeIn r [4]+ let field = parseField r+ dil <- field 0 numeric >>= getMetadata+ var <- field 1 numeric >>= getMetadata+ expr <- field 2 numeric >>= getMetadata+ rawloc <- field 3 numeric >>= getMetadata+ let drv = DbgRecValue+ { drvLocation = typedValue dil+ , drvLocalVariable = typedValue var+ , drvExpression = typedValue expr+ , drvValAsMetadata = typedValue rawloc+ }+ updateLastStmt (addDebugRecord (DebugRecordValue drv)) d++ 62 -> label "FUNC_CODE_DEBUG_RECORD_DECLARE" $ do+ -- [DILocation, DILocalVariable, DIExpression, ValueAsMetadata]+ assertRecordSizeIn r [4]+ let field = parseField r+ dil <- field 0 numeric >>= getMetadata+ var <- field 1 numeric >>= getMetadata+ expr <- field 2 numeric >>= getMetadata+ rawloc <- field 3 numeric >>= getMetadata+ let drd = DbgRecDeclare+ { drdLocation = typedValue dil+ , drdLocalVariable = typedValue var+ , drdExpression = typedValue expr+ , drdValAsMetadata = typedValue rawloc+ }+ updateLastStmt (addDebugRecord (DebugRecordDeclare drd)) d++ 63 -> label "FUNC_CODE_DEBUG_RECORD_ASSIGN" $ do+ -- [DILocation, DILocalVariable, DIExpression, ValueAsMetadata,+ -- DIAssignID, DIExpression (addr), ValueAsMetadata (addr)]+ assertRecordSizeIn r [7]+ let field = parseField r+ dil <- field 0 numeric >>= getMetadata+ var <- field 1 numeric >>= getMetadata+ expr <- field 2 numeric >>= getMetadata+ rawloc <- field 3 numeric >>= getMetadata+ assgnid <- field 4 numeric >>= getMetadata+ expraddr <- field 5 numeric >>= getMetadata+ valaddr <- field 6 numeric >>= getMetadata+ let dra = DbgRecAssign+ { draLocation = typedValue dil+ , draLocalVariable = typedValue var+ , draExpression = typedValue expr+ , draValAsMetadata = typedValue rawloc+ , draAssignID = typedValue assgnid+ , draExpressionAddr = typedValue expraddr+ , draValAsMetadataAddr = typedValue valaddr+ }+ updateLastStmt (addDebugRecord (DebugRecordAssign dra)) d++ 64 -> label "FUNC_CODE_DEBUG_RECORD_VALUE_SIMPLE" $ do+ -- [DILocation, DILocalVariable, DIExpression, Value]+ assertRecordSizeIn r [4]+ let field = parseField r+ dil <- field 0 numeric >>= getMetadata+ var <- field 1 numeric >>= getMetadata+ expr <- field 2 numeric >>= getMetadata+ (val, _) <- getValueTypePair t r 3+ let drd = DbgRecValueSimple+ { drvsLocation = typedValue dil+ , drvsLocalVariable = typedValue var+ , drvsExpression = typedValue expr+ , drvsValue = val+ }+ updateLastStmt (addDebugRecord (DebugRecordValueSimple drd)) d++ 65 -> label "FUNC_CODE_DEBUG_RECORD_LABEL" $ do+ -- [DILocation, DILabel]+ assertRecordSizeIn r [2]+ let field = parseField r+ dil <- field 0 numeric >>= getMetadata+ lbl <- field 1 numeric >>= getMetadata+ let drl = DbgRecLabel+ { drlLocation = typedValue dil+ , drlLabel = typedValue lbl+ }+ updateLastStmt (addDebugRecord (DebugRecordLabel drl)) d+ -- [opty,opval,opval,pred] code | code == 9@@ -1014,21 +1100,42 @@ rhs <- getValue t (typedType lhs) =<< field ix numeric let ty = typedType lhs++ samesign :: Maybe Int -> Bool+ samesign mb =+ case mb of+ Nothing -> False+ Just x -> testBit x 0++ parseOp :: Match Field (Maybe Int -> Typed PValue -> PValue -> PInstr) parseOp | isPrimTypeOf isFloatingPoint ty || isVectorOf (isPrimTypeOf isFloatingPoint) ty =- return . FCmp <=< fcmpOp+ \f -> do op <- fcmpOp f+ return $ \_mb x y -> FCmp op x y | otherwise =- return . ICmp <=< icmpOp+ \i -> do op <- icmpOp i+ return $ \mb x y -> ICmp (samesign mb) op x y op <- field (ix + 1) parseOp- -- XXX: we're ignoring the fast-math flags+ -- If there's an extra field on the end of the record, it's for one of the+ -- following:+ --+ -- - If the instruction is icmp, the extra field designates the value of the+ -- samesign flag.+ --+ -- - If the instruction is fcmp, the extra field designates the value of the+ -- fast-math flags. TODO(#61): We currently ignore these.+ --+ -- The constructor returned from parseOp will use that value when+ -- constructing the comparison operation.+ let mbWord = numeric =<< fieldAt (ix + 2) r let boolTy = Integer 1 let rty = case ty of Vector n _ -> Vector n (PrimType boolTy) _ -> PrimType boolTy- result rty (op lhs (typedValue rhs)) d+ result rty (op mbWord lhs (typedValue rhs)) d -- unknown | otherwise -> fail ("instruction code " ++ show code ++ " is unknown")@@ -1084,8 +1191,11 @@ addMd stmts (i,md') = Seq.adjust update (i-off) stmts where- update (Result n s md) = Result n s (md ++ md')- update (Effect s md) = Effect s (md ++ md')+ -- addInstrAttachments is only called for metadata read at function block+ -- entry, which (to date) is always an inline/intrinsic style metadata+ -- element.+ update (Result n s drs md) = Result n s drs (md ++ md')+ update (Effect s drs md) = Effect s drs (md ++ md') go _ _ Seq.EmptyL = Seq.empty @@ -1100,13 +1210,24 @@ Just ib -> do (tv,ix') <- getValueTypePair t r 0 ty <- Assert.elimPtrTo "GEP not headed by pointer" (typedType tv)- return (ib, ty, tv, r, ix')+ return (if ib then [GEP_Inbounds] else [], ty, tv, r, ix') - -- FUNC_CODE_INST_GEP+ -- FUNC_CODE_INST_GEP.+ --+ -- Originally had an "inbounds" boolean, followed by arguments, but in+ -- LLVM 19 this was changed to be a Word64 of bits specifying the gep+ -- inlining status, followed by the actual arguments. The record count+ -- doesn't change as a discriminator, so this tries parsing the older+ -- boolean and on failure assume the newer format. Nothing -> do let r' = flattenRecord r let field = parseField r'- ib <- field 0 boolean+ ib <- (field 0 boolean >>= \case+ True -> return [GEP_Inbounds]+ False -> return []+ )+ `mplus`+ (flagsFromBits orderedGEPAttrs <$> field 0 numeric) ty <- getType =<< field 1 numeric (tv,ix') <- getValueTypePair t r' 2 return (ib, ty, tv, r', ix')@@ -1172,14 +1293,14 @@ -- | Generate a statement that doesn't produce a result. effect :: Instr' Int -> PartialDefine -> Parse PartialDefine-effect i d = addStmt (Effect i []) d+effect i d = addStmt (Effect i mempty []) d -- | Try to name results, fall back on leaving them as effects. result :: Type -> Instr' Int -> PartialDefine -> Parse PartialDefine result (PrimType Void) i d = effect i d result ty i d = do res <- nameNextValue ty- addStmt (Result res i []) d+ addStmt (Result res i mempty []) d -- | Loop, parsing arguments out of a record in pairs, as the arguments to a phi -- instruction.
src/Data/LLVM/BitCode/IR/Metadata.hs view
@@ -4,11 +4,14 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Data.LLVM.BitCode.IR.Metadata ( parseMetadataBlock+ , parseDebugLoc , parseMetadataKindEntry , PartialUnnamedMd(..) , finalizePartialUnnamedMd@@ -18,6 +21,9 @@ , PFnMdAttachments , PKindMd , PGlobalAttachments+ , assertRecordSizeAtLeast+ , assertRecordSizeBetween+ , assertRecordSizeIn ) where import Data.LLVM.BitCode.Bitstream@@ -31,12 +37,12 @@ import qualified Codec.Binary.UTF8.String as UTF8 (decode) import Control.Applicative ((<|>)) import Control.Exception (throw)-import Control.Monad (foldM, guard, mplus, when)-import Data.Bits (shiftR, testBit, shiftL, (.&.), (.|.), bit, complement)-import Data.Data (Data)-import Data.Typeable (Typeable)+import Control.Monad (foldM, guard, mplus, unless, when)+import Data.Bits ( Bits, shiftR, testBit, shiftL, (.&.), (.|.), bit+ , complement ) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as Char8 (unpack)+import Data.Data (Data) import Data.Either (partitionEithers) import Data.Generics.Uniplate.Data import qualified Data.IntMap as IntMap@@ -44,14 +50,14 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe)-import qualified Data.Sequence as Seq import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Typeable (Typeable) import Data.Word (Word8,Word32,Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack, callStack)-import Data.Bifunctor (bimap)-+import Data.Bifunctor (bimap) -- Parsing State ---------------------------------------------------------------@@ -402,40 +408,25 @@ parseMetadataEntry :: ValueTable -> MetadataTable -> PartialMetadata -> Entry -> Parse PartialMetadata parseMetadataEntry vt mt pm (fromEntry -> Just r) =- 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)- when (len < lb || ub < len) $- addParseWarning $- InvalidMetadataRecordSize len (MetadataRecordSizeBetween lb ub) cxt-- assertRecordSizeIn ns = do- cxt <- getContext- let len = length (recordFields r)- when (not (len `elem` ns)) $- addParseWarning $- InvalidMetadataRecordSize len (MetadataRecordSizeIn ns) cxt-- assertRecordSizeAtLeast lb = do- cxt <- getContext- let len = length (recordFields r)- when (len < lb) $- addParseWarning $- InvalidMetadataRecordSize len (MetadataRecordSizeAtLeast lb) cxt-- -- Helper for a common pattern which appears below in the parsing+ let -- Helpers for common patterns which appear below in parsing metadata ron n = do ctx <- getContext mdForwardRefOrNull ctx mt <$> parseField r n numeric+ ronl n = if length (recordFields r) <= n then pure Nothing else ron n + -- If the @isMetadata@ argument is 'True', then parse a metadata value+ -- (which may be null). Otherwise, parse a 64-bit integer and return it as+ -- a 'ValMdValue'. This is used for parsing size and offset fields in+ -- type-related debug nodes, which can be non-constant expressions in+ -- LLVM 21 or later.+ mdOrConstant :: Bool -> Int -> Parse (Maybe PValMd)+ mdOrConstant isMetadata n+ | isMetadata+ = ron n+ | otherwise+ = fmap+ (Just . ValMdValue . Typed (PrimType (Integer 64)) . ValInteger)+ (parseField r n numeric)+ -- Note: the parsing cases below use a Monadic coding style, as opposed to an -- Applicative style (as was originally used) for performance reasons: -- Applicative record construction has quadratic size and corresponding@@ -454,7 +445,7 @@ -- [type num, value num] 2 -> label "METADATA_VALUE" $ do- assertRecordSizeIn [2]+ assertRecordSizeIn r [2] let field = parseField r ty <- getType =<< field 0 numeric when (ty == PrimType Metadata || ty == PrimType Void)@@ -487,24 +478,13 @@ -- [distinct, line, col, scope, inlined-at?] 7 -> label "METADATA_LOCATION" $ do- -- TODO: broken in 3.7+; needs to be a DILocation rather than an- -- MDLocation, but there appears to be no difference in the- -- bitcode. /sigh/- assertRecordSizeIn [5, 6]- let field = parseField r- cxt <- getContext- isDistinct <- field 0 nonzero- dlLine <- field 1 numeric- dlCol <- field 2 numeric- dlScope <- mdForwardRef cxt mt <$> field 3 numeric- dlIA <- mdForwardRefOrNull cxt mt <$> field 4 numeric- dlImplicit <- if length (recordFields r) <= 5- then pure False- else parseField r 5 nonzero- let loc = DebugLoc {..}+ cxt <- getContext+ isDistinct <- parseField r 0 nonzero+ loc <- parseDebugLoc 1+ (pure . mdForwardRef cxt mt)+ (pure . mdForwardRefOrNull cxt mt) r return $! updateMetadataTable (addLoc isDistinct loc) pm - -- [n x (type num, value num)] 8 -> label "METADATA_OLD_NODE" (parseMetadataOldNode False vt mt r pm) @@ -542,7 +522,7 @@ fail "not yet implemented" 13 -> label "METADATA_SUBRANGE" $ do- assertRecordSizeIn [3, 5]+ assertRecordSizeIn r [3, 5] field0 <- parseField r 0 unsigned let isDistinct = field0 .&. 0 == 1 -- The format field determines what set of fields are contained in this@@ -575,7 +555,7 @@ -- [isBigInt|isUnsigned|distinct, value, name] 14 -> label "METADATA_ENUMERATOR" $ do- assertRecordSizeAtLeast 3+ assertRecordSizeAtLeast r 3 ctx <- getContext flags <- parseField r 0 numeric let isDistinct = testBit (flags :: Int) 0@@ -592,24 +572,30 @@ return $! updateMetadataTable (addDebugInfo isDistinct diEnum) pm 15 -> label "METADATA_BASIC_TYPE" $ do- assertRecordSizeIn [6, 7]+ assertRecordSizeBetween r 6 8 ctx <- getContext- isDistinct <- parseField r 0 nonzero+ flags <- parseField r 0 numeric+ let isDistinct = testBit (flags :: Int) 0+ sizeIsMetadata = testBit (flags :: Int) 1 dibtTag <- parseField r 1 numeric dibtName <- mdString ctx pm <$> parseField r 2 numeric- dibtSize <- parseField r 3 numeric+ dibtSize <- mdOrConstant sizeIsMetadata 3 dibtAlign <- parseField r 4 numeric dibtEncoding <- parseField r 5 numeric dibtFlags <- if length (recordFields r) <= 6 then pure Nothing else Just <$> parseField r 6 numeric+ dibtNumExtraInhabitants <-+ if length (recordFields r) <= 7+ then pure 0+ else parseField r 7 numeric let dibt = DIBasicType {..} return $! updateMetadataTable (addDebugInfo isDistinct (DebugInfoBasicType dibt)) pm -- [distinct, filename, directory] 16 -> label "METADATA_FILE" $ do- assertRecordSizeIn [3, 5]+ assertRecordSizeIn r [3, 5] ctx <- getContext isDistinct <- parseField r 0 nonzero difFilename <- mdStringOrEmpty ctx pm <$> parseField r 1 numeric@@ -622,18 +608,20 @@ -- While upstream LLVM currently imposes a maximum of 14 records per -- entry, we raise this to 15 for the sake of parsing Apple LLVM. -- See Note [Apple LLVM].- assertRecordSizeBetween 12 15+ assertRecordSizeBetween r 12 15 ctx <- getContext- isDistinct <- parseField r 0 nonzero+ flags <- parseField r 0 numeric+ let isDistinct = testBit (flags :: Int) 0+ sizeIsMetadata = testBit (flags :: Int) 1 didtTag <- parseField r 1 numeric didtName <- mdStringOrNull ctx pm <$> parseField r 2 numeric didtFile <- ron 3 didtLine <- parseField r 4 numeric didtScope <- ron 5 didtBaseType <- ron 6- didtSize <- parseField r 7 numeric+ didtSize <- mdOrConstant sizeIsMetadata 7 didtAlign <- parseField r 8 numeric- didtOffset <- parseField r 9 numeric+ didtOffset <- mdOrConstant sizeIsMetadata 9 didtFlags <- parseField r 10 numeric didtExtraData <- ron 11 didtDwarfAddressSpace <-@@ -657,48 +645,50 @@ (addDebugInfo isDistinct (DebugInfoDerivedType didt)) pm 18 -> label "METADATA_COMPOSITE_TYPE" $ do- assertRecordSizeBetween 16 22+ assertRecordSizeBetween r 16 26 ctx <- getContext- isDistinct <- parseField r 0 nonzero+ flags <- parseField r 0 numeric+ let isDistinct = testBit (flags :: Int) 0+ -- isNotUsedInTypeRef = testBit (flags :: Int) 1+ sizeIsMetadata = testBit (flags :: Int) 2 dictTag <- parseField r 1 numeric dictName <- mdStringOrNull ctx pm <$> parseField r 2 numeric dictFile <- ron 3 dictLine <- parseField r 4 numeric dictScope <- ron 5 dictBaseType <- ron 6- dictSize <- parseField r 7 numeric+ dictSize <- mdOrConstant sizeIsMetadata 7 dictAlign <- parseField r 8 numeric- dictOffset <- parseField r 9 numeric+ dictOffset <- mdOrConstant sizeIsMetadata 9 dictFlags <- parseField r 10 numeric dictElements <- ron 11 dictRuntimeLang <- parseField r 12 numeric dictVTableHolder <- ron 13 dictTemplateParams <- ron 14 dictIdentifier <- mdStringOrNull ctx pm <$> parseField r 15 numeric- dictDiscriminator <- if length (recordFields r) <= 16- then pure Nothing- else ron 16- dictDataLocation <- if length (recordFields r) <= 17- then pure Nothing- else ron 17- dictAssociated <- if length (recordFields r) <= 18- then pure Nothing- else ron 18- dictAllocated <- if length (recordFields r) <= 19- then pure Nothing- else ron 19- dictRank <- if length (recordFields r) <= 20- then pure Nothing- else ron 20- dictAnnotations <- if length (recordFields r) <= 21- then pure Nothing- else ron 21+ dictDiscriminator <- ronl 16+ dictDataLocation <- ronl 17+ dictAssociated <- ronl 18+ dictAllocated <- ronl 19+ dictRank <- ronl 20+ dictAnnotations <- ronl 21+ dictNumExtraInhabitants <- if length (recordFields r) <= 22+ then pure 0+ else parseField r 22 numeric+ dictSpecification <- ronl 23+ dictEnumKind <- if length (recordFields r) <= 24+ then pure Nothing+ else do f <- parseField r 24 numeric+ if f == dwarf_DW_APPLE_ENUM_KIND_invalid+ then pure Nothing+ else pure $ Just f+ dictBitStride <- ronl 25 let dict = DICompositeType {..} return $! updateMetadataTable (addDebugInfo isDistinct (DebugInfoCompositeType dict)) pm 19 -> label "METADATA_SUBROUTINE_TYPE" $ do- assertRecordSizeBetween 3 4+ assertRecordSizeBetween r 3 4 isDistinct <- parseField r 0 nonzero distFlags <- parseField r 1 numeric distTypeArray <- ron 2@@ -707,7 +697,7 @@ (addDebugInfo isDistinct (DebugInfoSubroutineType dist)) pm 20 -> label "METADATA_COMPILE_UNIT" $ do- assertRecordSizeBetween 14 22+ assertRecordSizeBetween r 14 22 let recordSize = length (recordFields r) ctx <- getContext isDistinct <- parseField r 0 nonzero@@ -757,8 +747,7 @@ -- this one is a bit funky: -- https://github.com/llvm/llvm-project/blob/release/10.x/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L1486 - assertRecordSizeBetween 18 21-+ assertRecordSizeBetween r 18 21 -- A "version" is encoded in the high-order bits of the isDistinct field. version <- parseField r 0 numeric @@ -840,7 +829,7 @@ -- Some additional sanity checking when (not hasSPFlags && hasUnit)- (assertRecordSizeBetween 19 21)+ (assertRecordSizeBetween r 19 21) when (hasSPFlags && not hasUnit) (fail "DISubprogram record has subprogram flags, but does not have unit. Invalid record.")@@ -881,7 +870,7 @@ (addDebugInfo isDistinct (DebugInfoSubprogram disp)) pm 22 -> label "METADATA_LEXICAL_BLOCK" $ do- assertRecordSizeIn [5]+ assertRecordSizeIn r [5] isDistinct <- parseField r 0 nonzero dilbScope <- ron 1 dilbFile <- ron 2@@ -892,7 +881,7 @@ (addDebugInfo isDistinct (DebugInfoLexicalBlock dilb)) pm 23 -> label "METADATA_LEXICAL_BLOCK_FILE" $ do- assertRecordSizeIn [4]+ assertRecordSizeIn r [4] cxt <- getContext isDistinct <- parseField r 0 nonzero dilbfScope <- mdForwardRef cxt mt <$> parseField r 1 numeric@@ -903,7 +892,7 @@ (addDebugInfo isDistinct (DebugInfoLexicalBlockFile dilbf)) pm 24 -> label "METADATA_NAMESPACE" $ do- assertRecordSizeIn [3, 5]+ assertRecordSizeIn r [3, 5] let isNew = length (recordFields r) == 3 let nameIdx = if isNew then 2 else 3 @@ -920,7 +909,7 @@ (addDebugInfo isDistinct (DebugInfoNameSpace dins)) pm 25 -> label "METADATA_TEMPLATE_TYPE" $ do- assertRecordSizeIn [3, 4]+ assertRecordSizeIn r [3, 4] let hasIsDefault = length (recordFields r) == 4 cxt <- getContext isDistinct <- parseField r 0 nonzero@@ -934,7 +923,7 @@ (addDebugInfo isDistinct (DebugInfoTemplateTypeParameter dittp)) pm 26 -> label "METADATA_TEMPLATE_VALUE" $ do- assertRecordSizeIn [5, 6]+ assertRecordSizeIn r [5, 6] let hasIsDefault = length (recordFields r) == 6 cxt <- getContext isDistinct <- parseField r 0 nonzero@@ -950,7 +939,7 @@ (addDebugInfo isDistinct (DebugInfoTemplateValueParameter ditvp)) pm 27 -> label "METADATA_GLOBAL_VAR" $ do- assertRecordSizeBetween 11 13+ assertRecordSizeBetween r 11 13 ctx <- getContext field0 <- parseField r 0 numeric let isDistinct = testBit field0 0@@ -979,7 +968,7 @@ 28 -> label "METADATA_LOCAL_VAR" $ do -- this one is a bit funky: -- https://github.com/llvm-mirror/llvm/blob/release_38/lib/Bitcode/Reader/BitcodeReader.cpp#L2308- assertRecordSizeBetween 8 10+ assertRecordSizeBetween r 8 10 ctx <- getContext field0 <- parseField r 0 numeric let isDistinct = testBit (field0 :: Word32) 0@@ -1033,7 +1022,7 @@ fail "not yet implemented" 31 -> label "METADATA_IMPORTED_ENTITY" $ do- assertRecordSizeIn [6, 7]+ assertRecordSizeIn r [6, 7] cxt <- getContext isDistinct <- parseField r 0 nonzero diieTag <- parseField r 1 numeric@@ -1077,7 +1066,7 @@ fail "not yet implemented" 35 -> label "METADATA_STRINGS" $ do- assertRecordSizeIn [3]+ assertRecordSizeIn r [3] count <- parseField r 0 numeric offset <- parseField r 1 numeric bs <- parseField r 2 fieldBlob@@ -1111,7 +1100,7 @@ return $! addGlobalAttachments sym refs pm 37 -> label "METADATA_GLOBAL_VAR_EXPR" $ do- assertRecordSizeIn [3]+ assertRecordSizeIn r [3] isDistinct <- parseField r 0 nonzero digveVariable <- ron 1 digveExpression <- ron 2@@ -1120,7 +1109,7 @@ (addDebugInfo isDistinct (DebugInfoGlobalVariableExpression digve)) pm 38 -> label "METADATA_INDEX_OFFSET" $ do- assertRecordSizeIn [2]+ assertRecordSizeIn r [2] a <- parseField r 0 numeric b <- parseField r 1 numeric let _offset = a + (b `shiftL` 32) :: Word64@@ -1136,13 +1125,34 @@ return pm 40 -> label "METADATA_LABEL" $ do- assertRecordSizeIn [5]+ assertRecordSizeIn r [5, 7] cxt <- getContext- isDistinct <- parseField r 0 nonzero+ (flags :: Int) <- parseField r 0 numeric+ let isDistinct = testBit flags 0+ dilIsArtificial = testBit flags 1 dilScope <- ron 1 dilName <- mdString cxt pm <$> parseField r 2 numeric dilFile <- ron 3 dilLine <- parseField r 4 numeric+ dilColumn <-+ if length (recordFields r) > 5+ then parseField r 5 numeric+ else pure 0+ -- Heavily based on the upstream metadata loader code in LLVM:+ -- https://github.com/llvm/llvm-project/blob/58e6d02aa28ba48ee37f1b59ad006dfeb45d1dd3/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L2267-L2274+ dilCoroSuspendIdx <-+ if length (recordFields r) > 6+ then do+ (rawSuspendIdx :: Word64) <- parseField r 6 numeric+ if rawSuspendIdx == maxBound @Word64+ then pure Nothing+ else do+ when (rawSuspendIdx > fromIntegral @Word32 @Word64 maxBound) $+ fail $ "CoroSuspendIdx value is too large: " ++ show rawSuspendIdx+ -- This use of fromIntegral (which truncates to a smaller Word+ -- type) is always safe due to the check above.+ pure $ Just $ fromIntegral @Word64 @Word32 rawSuspendIdx+ else pure Nothing let dil = DILabel {..} return $! updateMetadataTable (addDebugInfo isDistinct (DebugInfoLabel dil)) pm@@ -1166,6 +1176,15 @@ return $! updateMetadataTable (addInlineDebugInfo (DebugInfoArgList dial)) pm + 47 -> label "METADATA_ASSIGN_ID" $ do+ assertRecordSizeIn r [1]+ isDistinct <- parseField r 0 nonzero+ -- Inspirted by a similar check in+ -- https://github.com/llvm/llvm-project/blob/7a0b9daac9edde4293d2e9fdf30d8b35c04d16a6/llvm/lib/Bitcode/Reader/MetadataLoader.cpp#L2071-L2072+ unless isDistinct $+ fail "Invalid DIAssignID record. Must be distinct"+ return $! updateMetadataTable+ (addDebugInfo isDistinct DebugInfoAssignID) pm code -> fail ("unknown record code: " ++ show code) @@ -1238,11 +1257,73 @@ _ -> fail "Malformed metadata node" +parseDebugLoc :: Num scope => Bits scope => Num ia => Bits ia+ => Int+ -> (scope -> Parse (ValMd' r))+ -> (ia -> Parse (Maybe (ValMd' r)))+ -> Record+ -> Parse (DebugLoc' r)+parseDebugLoc idx resolveScope resolveIA r = do+ assertRecordSizeIn r [ idx + i | i <- [4, 5, 7] ]+ let recordSize = length $ recordFields r+ let field = parseField r . (idx +)+ let fieldDef d i = if recordSize < (idx + 1 + i)+ then const (pure d)+ else field i+ dlLine <- field 0 numeric+ dlCol <- field 1 numeric+ dlScope <- resolveScope =<< field 2 numeric+ dlIA <- resolveIA =<< field 3 numeric+ dlImplicit <- fieldDef False 4 nonzero+ dlAtomGroup <- fieldDef 0 5 numeric+ dlAtomRank <- fieldDef 0 6 numeric+ return DebugLoc {..}++ parseMetadataKindEntry :: Record -> Parse () parseMetadataKindEntry r = do kind <- parseField r 0 numeric name <- parseFields r 1 char addKind kind (UTF8.decode name)++----------------------------------------------------------------------++-- 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 :: Record -> Int -> Int -> Parse ()+assertRecordSizeBetween r lb ub = do+ cxt <- getContext+ let len = length (recordFields r)+ when (len < lb || ub < len) $+ addParseWarning $+ InvalidMetadataRecordSize len (MetadataRecordSizeBetween lb ub) cxt++assertRecordSizeIn :: Record -> [Int] -> Parse ()+assertRecordSizeIn r ns = do+ cxt <- getContext+ let len = length (recordFields r)+ when (not (len `elem` ns)) $+ addParseWarning $+ InvalidMetadataRecordSize len (MetadataRecordSizeIn ns) cxt++assertRecordSizeAtLeast :: Record -> Int -> Parse ()+assertRecordSizeAtLeast r lb = do+ cxt <- getContext+ let len = length (recordFields r)+ when (len < lb) $+ addParseWarning $+ InvalidMetadataRecordSize len (MetadataRecordSizeAtLeast lb) cxt+++---------------------------------------------------------------------- {- Note [Apple LLVM]
src/Data/LLVM/BitCode/IR/Values.hs view
@@ -13,7 +13,9 @@ import Data.LLVM.BitCode.Record import Text.LLVM.AST +import qualified Control.Exception as X import Control.Monad ((<=<),foldM)+import GHC.Stack (callStack) -- Value Table -----------------------------------------------------------------@@ -44,7 +46,7 @@ --getValueNoFwdRef :: Type -> Int -> Parse (Typed PValue) --getValueNoFwdRef ty n = label "getValueNoFwdRef" (getFnValueById ty =<< adjustId n) -getFnValueById :: (HasMdTable m, HasParseEnv m, HasValueTable m, MonadFail m)+getFnValueById :: (HasMdTable m, HasMdRefTable m, HasParseEnv m, HasValueTable m, MonadFail m) => Type -> Int -> m (Typed PValue) getFnValueById = getFnValueById' Nothing @@ -52,14 +54,19 @@ getValue vt ty n = label "getValue" (getFnValueById' (Just vt) ty =<< adjustId n) -- | Lookup a value by its absolute id, or perhaps some metadata.-getFnValueById' :: (HasMdTable m, HasParseEnv m, HasValueTable m, MonadFail m)+getFnValueById' :: (HasMdTable m, HasMdRefTable 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 md <- getMdTable- return (forwardRef cxt n md)+ mdr <- getMdRefTable+ case resolveMd n md mdr of+ Just tv -> return tv+ Nothing ->+ let explanation = "Illegal forward reference into metadata"+ in X.throw $ BadValueRef callStack cxt explanation n _ -> do mb <- lookupValueAbs n
src/Data/LLVM/BitCode/Parse.hs view
@@ -439,22 +439,28 @@ getMetadata :: Int -> Parse (Typed PValMd) getMetadata ix = do ps <- Parse get- case resolveMd ix ps of+ case resolveMd ix (psMdTable ps) (psMdRefs ps) of Just tv -> case typedValue tv of ValMd val -> return tv { typedValue = val } _ -> fail "unexpected non-metadata value in metadata table" Nothing -> fail ("metadata index " ++ show ix ++ " is not defined") -resolveMd :: Int -> ParseState -> Maybe (Typed PValue)-resolveMd ix ps = nodeRef `mplus` mdValue+resolveMd :: Int -> MdTable -> MdRefTable -> Maybe (Typed PValue)+resolveMd ix mdTable mdRefs = nodeRef `mplus` mdValue where reference = Typed (PrimType Metadata) . ValMd . ValMdRef- nodeRef = reference `fmap` IntMap.lookup ix (psMdRefs ps)- mdValue = lookupValueTableAbs ix (psMdTable ps)+ nodeRef = reference `fmap` IntMap.lookup ix mdRefs+ mdValue = lookupValueTableAbs ix mdTable type MdRefTable = IntMap.IntMap Int +class Monad m => HasMdRefTable m where+ getMdRefTable :: m MdRefTable++instance HasMdRefTable Parse where+ getMdRefTable = gets psMdRefs+ setMdRefs :: MdRefTable -> Parse () setMdRefs refs = Parse $ do ps <- get@@ -880,6 +886,7 @@ data FinalizeEnv = FinalizeEnv { parsedEnv :: Env , parsedMdTable :: ValueTable+ , parsedMdRefs :: MdRefTable , parsedValueTable :: ValueTable , parsedFuncSymtabs :: FuncSymTabs }@@ -929,6 +936,9 @@ instance HasMdTable Finalize where getMdTable = asks parsedMdTable +instance HasMdRefTable Finalize where+ getMdRefTable = asks parsedMdRefs+ instance HasValueTable Finalize where getValueTable = asks parsedValueTable @@ -951,9 +961,11 @@ liftFinalize defs (Finalize m) = do env <- ask mdt <- getMdTable+ mdr <- getMdRefTable valt <- getValueTable let fenv = FinalizeEnv { parsedEnv = env , parsedMdTable = mdt+ , parsedMdRefs = mdr , parsedValueTable = valt , parsedFuncSymtabs = defs }
src/Data/LLVM/CFG.hs view
@@ -139,7 +139,7 @@ -- Graph construction (exit, gr) = stitchDummyExit lab (G.mkGraph nodes' edges') where lab n = BasicBlock (Just (BBId n, Named $ Ident dummyExitName))- [Effect Unreachable []]+ [Effect Unreachable mempty []] nodes' = map (nodeId &&& id) bs' edges' = concatMap bbOutEdges bs'
unit-test/Tests/ExpressionInstances.hs view
@@ -8,6 +8,9 @@ import Tests.PrimInstances () +instance Arbitrary Alignment where arbitrary = genericArbitrary uniform+instance Arbitrary PointerSize where arbitrary = genericArbitrary uniform+instance Arbitrary Storage where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (Type' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (Typed lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (ValMd' lab) where arbitrary = genericArbitrary uniform@@ -20,12 +23,14 @@ instance Arbitrary FCmpOp where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DebugLoc' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (ConstExpr' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary GEPAttr where arbitrary = genericArbitrary uniform+instance Arbitrary RangeSpec where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DebugInfo' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DIImportedEntity' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DITemplateTypeParameter' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DITemplateValueParameter' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DINameSpace' lab) where arbitrary = genericArbitrary uniform-instance Arbitrary DIBasicType where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DIBasicType' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DICompileUnit' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DICompositeType' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DIDerivedType' lab) where arbitrary = genericArbitrary uniform@@ -41,3 +46,9 @@ instance Arbitrary lab => Arbitrary (DISubroutineType' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DILabel' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DIArgList' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DebugRecord' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DbgRecValue' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DbgRecValueSimple' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DbgRecDeclare' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DbgRecAssign' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DbgRecLabel' lab) where arbitrary = genericArbitrary uniform