llvm-pretty-bc-parser 0.6.0.0 → 0.6.1.0
raw patch · 21 files changed
+521/−282 lines, 21 filesdep +microlensdep −lensdep −tree-diffdep ~llvm-prettydep ~prettyPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: microlens
Dependencies removed: lens, tree-diff
Dependency ranges changed: llvm-pretty, pretty
API changes (from Hackage documentation)
+ Data.LLVM.BitCode: UnknownMetadataRecordCode :: !Int -> ParseWarning
+ Data.LLVM.BitCode: UnsupportedMetadataRecordCode :: !Int -> !String -> ParseWarning
- Data.LLVM.Internal: PartialUnnamedMd :: Int -> PValMd -> Bool -> PartialUnnamedMd
+ Data.LLVM.Internal: PartialUnnamedMd :: UnnamedMdIdx -> PValMd -> Bool -> PartialUnnamedMd
- Data.LLVM.Internal: [pumIndex] :: PartialUnnamedMd -> Int
+ Data.LLVM.Internal: [pumIndex] :: PartialUnnamedMd -> UnnamedMdIdx
- Data.LLVM.Internal: parseMetadataBlock :: Int -> ValueTable -> [Entry] -> Parse ParsedMetadata
+ Data.LLVM.Internal: parseMetadataBlock :: UnnamedMdIdx -> ValueTable -> [Entry] -> Parse ParsedMetadata
Files
- CHANGELOG.md +14/−0
- README.md +3/−1
- disasm-test/Instances.hs +0/−95
- disasm-test/Main.hs +106/−51
- disasm-test/tests/constantbfloat.ll +6/−0
- disasm-test/tests/constantbfloat.pre-llvm11.ll +1/−0
- disasm-test/tests/constantfloat.ll +57/−0
- disasm-test/tests/difixedpointtype.ll +23/−0
- disasm-test/tests/difixedpointtype.pre-llvm21.ll +0/−0
- disasm-test/tests/disubrangetype.ll +25/−0
- disasm-test/tests/disubrangetype.pre-llvm21.ll +0/−0
- llvm-pretty-bc-parser.cabal +5/−5
- src/Data/LLVM/BitCode/IR/Constants.hs +33/−9
- src/Data/LLVM/BitCode/IR/Function.hs +8/−8
- src/Data/LLVM/BitCode/IR/Metadata.hs +200/−97
- src/Data/LLVM/BitCode/IR/Module.hs +4/−4
- src/Data/LLVM/BitCode/IR/Types.hs +1/−2
- src/Data/LLVM/BitCode/IR/Values.hs +1/−1
- src/Data/LLVM/BitCode/Parse.hs +22/−9
- unit-test/Tests/ExpressionInstances.hs +4/−0
- unit-test/Tests/PrimInstances.hs +8/−0
CHANGELOG.md view
@@ -1,5 +1,19 @@ # Revision history for llvm-pretty-bc-parser +## 0.6.1.0 -- 2026-08-27++* Support LLVM 22:+ * Support parsing `sourceLanguageVersion` fields in `DICompileUnit` debug+ metadata.+ * Support parsing `dataSize` fields in `DIBasicType` debug metadata.+* Support LLVM 21:+ * Parsing for `DISubrangeType` (metadata ID 48).+ * Parsing for `DIFixedPointType` (metadata ID 49).+* Add support for reading 16-bit "Brain" floats (`bfloat`)+* Add missing handling for 16-bit IEEE half-precision floats,+ 64-bit IEEE quad-precision floats, and PowerPC pair-of-doubles+ floats.+ ## 0.6.0.0 -- 2026-01-23 * Updates for supporting LLVM-19:
README.md view
@@ -39,6 +39,7 @@ | | v19 | ✓ | ✓ | See [issues][llvm19] | | | v20 | ✓ | ✓ | See [issues][llvm20] | | | v21 | ✓ | ✓ | See [issues][llvm21] |+| | v22 | ✓ | ✓ | See [issues][llvm22] | If you encounter problems with the output of *any* compiler, please file [an issue](https://github.com/GaloisInc/llvm-pretty-bc-parser/issues).@@ -57,7 +58,7 @@ - GHC 9.8.4 - GHC 9.10.1 -[fuzz-workflow]: https://github.com/GaloisInc/llvm-pretty-bc-parser/blob/master/.github/workflows/llvm-quick-fuzz.yml+[fuzz-workflow]: https://github.com/GaloisInc/llvm-pretty-bc-parser/blob/4934fb36e377fd5b1339f33ddcfd76bf9c68be0d/flake.nix#L104-L105 [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@@ -82,3 +83,4 @@ [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+[llvm22]: https://github.com/GaloisInc/llvm-pretty-bc-parser/issues?q=is%3Aopen+is%3Aissue+label%3Allvm%2F22.0
− disasm-test/Instances.hs
@@ -1,95 +0,0 @@-{-# 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
@@ -12,9 +12,9 @@ ParseWarning,ppParseWarnings) import qualified Text.LLVM.AST as AST import Text.LLVM.PP ( ppLLVM, ppLLVM35, ppLLVM36, ppLLVM37, ppLLVM38, llvmPP )+import qualified Text.PrettyPrint.HughesPJ as HPJ import qualified Control.Exception as EX-import Control.Lens ( (^?), _Right ) import Control.Monad ( foldM, unless, when ) import qualified Control.Monad.Catch as X import Control.Monad.IO.Class ( MonadIO, liftIO )@@ -24,7 +24,7 @@ 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 , groupBy, sortBy )+import Data.List ( find, isPrefixOf, isSuffixOf, nub, sort , groupBy, sortBy ) import Data.Map ( (!), (!?) ) import qualified Data.Map as Map import Data.Maybe ( fromMaybe )@@ -32,15 +32,16 @@ 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 Lens.Micro ( (^?), _Right ) import qualified GHC.IO.Exception as GE import qualified Options.Applicative as OA import qualified Prettyprinter as PP import qualified Prettyprinter.Util as PPU import qualified System.Console.Terminal.Size as Term-import System.Directory ( doesFileExist, getTemporaryDirectory+import System.Directory ( doesFileExist, findExecutable+ , getTemporaryDirectory , listDirectory , removeFile ) import System.Environment ( lookupEnv )@@ -49,18 +50,19 @@ import System.IO (openBinaryTempFile,hClose,openTempFile,hPrint, hPutStrLn,stderr) import qualified System.IO as IO (stderr)+import System.IO.Temp (withTempFile) import qualified System.Process as Proc+import System.Process (readProcessWithExitCode) import Test.Tasty import Test.Tasty.ExpectedFailure ( ignoreTestBecause , expectFailBecause )-import Test.Tasty.HUnit ( assertFailure, testCase, assertBool )+import Test.Tasty.HUnit ( assertEqual, assertFailure, testCase ) 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@@ -194,6 +196,17 @@ optionCLParser = TO.mkOptionCLParser $ OA.metavar "FILEPATH" +newtype LLVMDiff = LLVMDiff FilePath++instance TO.IsOption LLVMDiff where+ defaultValue = LLVMDiff "llvm-diff"+ parseValue = Just . LLVMDiff+ optionName = pure "with-llvm-diff"+ optionHelp = pure "path to llvm-diff"+ showDefaultValue (LLVMDiff d) = Just d+ optionCLParser = TO.mkOptionCLParser $+ OA.metavar "FILEPATH"+ newtype Roundtrip = Roundtrip Bool instance TO.IsOption Roundtrip where@@ -232,6 +245,7 @@ includingOptions [ TO.Option (Proxy @LLVMAs) , TO.Option (Proxy @LLVMDis) , TO.Option (Proxy @Clang)+ , TO.Option (Proxy @LLVMDiff) , TO.Option (Proxy @Roundtrip) , TO.Option (Proxy @Keep) , TO.Option (Proxy @Details)@@ -275,9 +289,12 @@ vcVersioning :: VersionCheck -> Either T.Text Versioning vcVersioning (VC _ v) = v -mkVC :: String -> String -> VersionCheck-mkVC nm raw = let r = T.pack raw in VC nm $ first (const r) $ versioning r+versionMissing :: Either T.Text a+versionMissing = Left "[missing]" +mkVC :: String -> T.Text -> VersionCheck+mkVC nm r = VC nm $ first (const r) $ versioning r+ getLLVMAsVersion :: LLVMAs -> IO VersionCheck getLLVMAsVersion (LLVMAs llvmAsPath) = getLLVMToolVersion "llvm-as" llvmAsPath @@ -287,32 +304,35 @@ getClangVersion :: Clang -> IO VersionCheck getClangVersion (Clang clangPath) = getLLVMToolVersion "clang" clangPath +getLLVMDiffVersion :: LLVMDiff -> IO VersionCheck+getLLVMDiffVersion (LLVMDiff llvmDiffPath) = getLLVMToolVersion "llvm-diff" llvmDiffPath+ -- Determine which version of an LLVM tool will be used for these tests (if -- possible). Uses partial 'head' but this is just tests, and failure is -- captured. getLLVMToolVersion :: String -> FilePath -> IO VersionCheck getLLVMToolVersion toolName toolPath = do- let isVerLine l = isInfixOf "LLVM version" l || isInfixOf "clang version" l- dropLetter = dropWhile (all isLetter)+ let isVerLine l = T.isInfixOf "LLVM version" l || T.isInfixOf "clang version" l+ dropLetter = dropWhile (all isLetter. T.unpack) getVer (Right inp) = -- example inp: "LLVM version 10.0.1" or "clang version 11.1.0"- case filter isVerLine $ lines inp of- [] -> "NO VERSION IDENTIFIED FOR " <> toolName- (l:_) -> case dropLetter $ words l of- [] -> toolName <> " VERSION NOT PARSED: " <> l- (v:_) -> fst $ break (== '-') v -- remove vendor suffix (e.g. 12.0.1-19ubuntu3)+ case filter isVerLine $ T.lines $ T.pack inp of+ [] -> "NO VERSION IDENTIFIED FOR " <> T.pack toolName+ (l:_) -> case dropLetter $ T.words l of+ [] -> T.pack toolName <> " VERSION NOT PARSED: " <> l+ (v:_) -> fst $ T.break (== '-') v -- remove vendor suffix (e.g. 12.0.1-19ubuntu3) getVer (Left full) = full mkVC toolName . getVer <$> readProcessVersion toolPath -- Runs the tool with a --version argument to have it self-report its version. -- The tool may not even be installed. Returns either an error string or the -- output string from the tool.-readProcessVersion :: String -> IO (Either String String)+readProcessVersion :: String -> IO (Either T.Text String) readProcessVersion forTool = X.catches (Right <$> Proc.readProcess forTool [ "--version" ] "") [ X.Handler $ \(e :: EX.IOException) -> if GE.ioe_type e == GE.NoSuchThing- then return $ Left "[missing]" -- tool executable not found+ then return $ versionMissing -- tool executable not found else do putStrLn $ "Warning: IO error attempting to determine " <> forTool <> " version:" putStrLn $ show e return $ Left "unknown"@@ -337,21 +357,26 @@ -- result, we have to resort to using more of tasty's internals here. disasmOpts <- parseCmdLine - let llvmAs' = TO.lookupOption disasmOpts- llvmDis' = TO.lookupOption disasmOpts- clang' = TO.lookupOption disasmOpts+ let llvmAs' = TO.lookupOption disasmOpts+ llvmDis' = TO.lookupOption disasmOpts+ llvmDiff' = TO.lookupOption disasmOpts+ clang' = TO.lookupOption disasmOpts llvmAsVC <- getLLVMAsVersion llvmAs' llvmDisVC <- getLLVMDisVersion llvmDis' clangVC <- getClangVersion clang'- unless (and [ vcVersioning llvmAsVC == vcVersioning llvmDisVC+ llvmDiffVC <- getLLVMDiffVersion llvmDiff'+ unless (and [ vcVersioning llvmAsVC /= versionMissing+ , vcVersioning llvmAsVC == vcVersioning llvmDisVC , vcVersioning llvmAsVC == vcVersioning clangVC+ , vcVersioning llvmAsVC == vcVersioning llvmDiffVC ]) $ error $ unlines- [ "Unexpected version mismatch between clang, llvm-as and llvm-dis"- , "* llvm-as version: " ++ showVC llvmAsVC- , "* llvm-dis version: " ++ showVC llvmDisVC- , "* clang version: " ++ showVC clangVC+ [ "Unexpected version mismatch between clang, llvm-as, llvm-dis, or llvm-diff"+ , "* llvm-as version: " ++ showVC llvmAsVC+ , "* llvm-dis version: " ++ showVC llvmDisVC+ , "* llvm-diff version: " ++ showVC llvmDiffVC+ , "* clang version: " ++ showVC clangVC ] knownBugs <- getKnownBugs rootPth@@ -400,6 +425,7 @@ , TS.separators = "." , TS.validParams = [ ("llvm-range", Just [ "recent-llvm" , "pre-llvm9"+ , "pre-llvm11" , "pre-llvm12" , "pre-llvm13" , "pre-llvm14"@@ -410,6 +436,7 @@ , "post-llvm18" , "pre-llvm19" , "pre-llvm20"+ , "pre-llvm21" ]) ] -- Somewhat unusually for tasty-sugar, we make the expectedSuffix the same@@ -537,16 +564,53 @@ --- | 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.+-- | Pretty-print a module using the version-appropriate LLVM printer.+ppModuleForVersion :: VersionCheck -> AST.Module -> HPJ.Doc+ppModuleForVersion vc m =+ case vcVersioning vc ^? (_Right . major) of+ Nothing -> ppLLVM35 $ llvmPP m+ Just v ->+ case v of+ 3 -> case vcVersioning vc ^? (_Right . minor) of+ Just 5 -> ppLLVM35 $ llvmPP m+ Just 6 -> ppLLVM36 $ llvmPP m+ Just 7 -> ppLLVM37 $ llvmPP m+ Just 8 -> ppLLVM38 $ llvmPP m+ o -> if maybe True (< 5) o+ then ppLLVM35 $ llvmPP m+ else ppLLVM38 $ llvmPP m+ _ -> ppLLVM (fromEnum v) $ llvmPP m++-- | Compare two ASTs to see if they are the same. Fundamentally this is just+-- done via (==) on the normalized ASTs. On failure, serializes both modules to+-- .ll files and runs llvm-diff for a structured diff; falls back to plain+-- diff -u if llvm-diff is not available. 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+cmpASTs ast1 ast2 =+ when (ast1 /= ast2) $ do+ llvmVersion <- gets llvmVer+ LLVMDiff diffExe <- gets llvmDiff+ Details dets <- gets showDetails+ liftIO $ do+ tmp <- getTemporaryDirectory+ let withLL name m f =+ withTempFile tmp name $ \path h -> do+ hPutStrLn h (show (ppModuleForVersion llvmVersion m))+ hClose h+ f path+ withLL "mod1.ll" ast1 $ \f1 ->+ withLL "mod2.ll" ast2 $ \f2 -> do+ mb <- findExecutable diffExe+ irDiff <- case mb of+ Just exe -> do+ when dets $ liftIO $ putStrLn ("## Running: " ++ exe ++ " " ++ unwords [f1, f2])+ (_, out, err) <- readProcessWithExitCode exe [f1, f2] ""+ return $ "llvm-diff output:\n" <> out <> err+ Nothing -> do+ when dets $ liftIO $ putStrLn ("## Running: " ++ "diff -u " ++ unwords [f1, f2])+ (_, out, _) <- readProcessWithExitCode "diff" ["-u", f1, f2] ""+ return $ "diff -u output (llvm-diff not found):\n" <> out+ assertEqual irDiff ast1 ast2 -- Assembles the specified .ll file to bitcode, then disassembles it with@@ -708,6 +772,7 @@ , llvmAs :: LLVMAs , llvmDis :: LLVMDis , clang :: Clang+ , llvmDiff :: LLVMDiff , llvmVer :: VersionCheck } @@ -721,12 +786,14 @@ askOption $ \keep -> askOption $ \details -> askOption $ \clang' ->+ askOption $ \llvmDiff' -> testCase pfx $ evalStateT ops (TestState { keepTemp = keep , rndTrip = roundtrip , showDetails = details , llvmAs = llvmAs' , llvmDis = llvmDis' , clang = clang'+ , llvmDiff = llvmDiff' , llvmVer = llvmVersion }) @@ -816,23 +883,11 @@ let m' = AST.fixupOpaquePtrs m postParseTests m' llvmVersion <- gets llvmVer- llvmAssembly <-- case vcVersioning llvmVersion ^? (_Right . major) of- Nothing -> do liftIO $ hPutStrLn IO.stderr- ( "warning: unknown LLVM version ("- <> showVC llvmVersion <> "), assuming 3.5")- return $ ppLLVM35 $ llvmPP m'- Just v ->- case v of- 3 -> case vcVersioning llvmVersion ^? (_Right . minor) of- Just 5 -> return $ ppLLVM35 $ llvmPP m'- Just 6 -> return $ ppLLVM36 $ llvmPP m'- Just 7 -> return $ ppLLVM37 $ llvmPP m'- Just 8 -> return $ ppLLVM38 $ llvmPP m'- o -> if maybe True (< 5) o- then return $ ppLLVM35 $ llvmPP m'- else return $ ppLLVM38 $ llvmPP m'- _ -> return $ ppLLVM (fromEnum v) $ llvmPP m'+ when (vcVersioning llvmVersion == versionMissing) $+ liftIO $ hPutStrLn IO.stderr+ ( "warning: unknown LLVM version ("+ <> showVC llvmVersion <> "), assuming 3.5")+ let llvmAssembly = ppModuleForVersion llvmVersion m' parsed <- liftIO $ printToTempFile "ll" $ show llvmAssembly Roundtrip roundtrip <- gets rndTrip -- stripComments parsed
+ disasm-test/tests/constantbfloat.ll view
@@ -0,0 +1,6 @@+@bf0 = dso_local global bfloat 0xR0000, align 2+@bf1 = dso_local global bfloat 0xR3F80, align 2+@bf2 = dso_local global bfloat 0xR4000, align 2+@bf025 = dso_local global bfloat 0xR3E80, align 2+@bfinf = dso_local global bfloat 0xR7F80, align 2+@bfnan = dso_local global bfloat 0xRFFD5, align 2
+ disasm-test/tests/constantbfloat.pre-llvm11.ll view
@@ -0,0 +1,1 @@+SKIP_TEST bfloats were introduced in llvm-11
+ disasm-test/tests/constantfloat.ll view
@@ -0,0 +1,57 @@+; half-floats+@hf0 = dso_local global half 0xH0000, align 2+@hf1 = dso_local global half 0xH3C00, align 2+@hf2 = dso_local global half 0xH4000, align 2+@hf025 = dso_local global half 0xH3A00, align 2+@hfinf = dso_local global half 0xH7C00, align 2+@hfnan = dso_local global half 0xHFC55, align 2++; single-floats+;+; Do not attempt to test NaNs; it breaks the test infrastructure.+; Because we load these into the Haskell float type, a NaN is not+; equal to itself, and then the test both (a) fails and then (b)+; prints a diff of what you got wrong... with no visible differences,+; which is highly confusing.+;+; Note: apparently the proper behavior for printing single-precision+; as hex is to promote to double and print that. This is also why the+; hex values below are doubles.+@f0 = dso_local global float 0.0, align 4+@f1 = dso_local global float 1.0, align 4+@f2 = dso_local global float 2.0, align 4+@f025 = dso_local global float 0.25, align 4+@finf = dso_local global float 0x7FF0000000000000, align 4+;@fnan = dso_local global float 0xFFF5555540000000, align 4++; double-floats+;+; Don't test NaNs for the same reason as singles.+@d0 = dso_local global double 0.0, align 8+@d1 = dso_local global double 1.0, align 8+@d2 = dso_local global double 2.0, align 8+@d025 = dso_local global double 0.25, align 8+@dinf = dso_local global double 0x7FF0000000000000, align 8+;@dnan = dso_local global double 0xFFF5555555555555, align 8++; x86 80-bit floats+;+; These are always printed as hex so there's not much point chasing+; after specific values; just get zero and nonzero.+@fp80_a = dso_local global x86_fp80 0xK00000000000000000000, align 16+@fp80_b = dso_local global x86_fp80 0xKF0F0F0F0F0F0F0F0F0F0, align 16++; quad floats+;+; These are always printed as hex so there's not much point chasing+; after specific values; just get zero and nonzero.+@fp128_a = dso_local global fp128 0xL00000000000000000000000000000000, align 16+@fp128_b = dso_local global fp128 0xLF0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0, align 16++; PowerPC pair-of-doubles floats+;+; These are always printed as hex so there's not much point chasing+; after specific values; just get zero and nonzero. Avoid making+; either component a NaN.+@fp128ppc_a = dso_local global ppc_fp128 0xM00000000000000000000000000000000, align 16+@fp128ppc_b = dso_local global ppc_fp128 0xMF0F0F0F0F0F0F0F0F0F0F0F0F0F0F0F0, align 16
+ disasm-test/tests/difixedpointtype.ll view
@@ -0,0 +1,23 @@+;; This test checks generation of DIFixedPointType.+;; From llvm-project llvm/test/Bitcode/fixedpoint_type.ll (https://github.com/llvm/llvm-project/blob/llvm/test/Bitcode/fixedpoint_type.ll)++; ModuleID = 'fixedpoint_type.ll'+source_filename = "/dir/fixedpoint_type.adb"++!llvm.module.flags = !{!0, !1}+!llvm.dbg.cu = !{!2}++!0 = !{i32 2, !"Debug Info Version", i32 3}+!1 = !{i32 2, !"Dwarf Version", i32 4}+!2 = distinct !DICompileUnit(language: DW_LANG_Ada95, file: !3, producer: "GNAT/LLVM", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !4, retainedTypes: !5, globals: !4, imports: !4)+!3 = !DIFile(filename: "fixedpoint_type.adb", directory: "/dir")+!4 = !{}+!5 = !{!11, !12, !13}+!6 = distinct !DISubprogram(name: "fp", scope: !3, file: !3, line: 1, type: !7, scopeLine: 1, spFlags: DISPFlagDefinition, unit: !4, retainedNodes: !9)+!7 = !DISubroutineType(types: !8)+!8 = !{null}+!9 = !{!10}+!10 = !DILocalVariable(name: "x", scope: !6, file: !3, line: 3, type: !11, align: 32)+!11 = !DIFixedPointType(name: "fp__decimal", size: 32, align: 32, encoding: DW_ATE_signed_fixed, kind: Decimal, factor: -4)+!12 = !DIFixedPointType(name: "fp__rational", size: 32, align: 32, encoding: DW_ATE_unsigned_fixed, kind: Rational, numerator: 1234, denominator: 5678)+!13 = !DIFixedPointType(name: "fp__binary", size: 64, align: 0, encoding: DW_ATE_unsigned_fixed, kind: Binary, factor: -16)
+ disasm-test/tests/difixedpointtype.pre-llvm21.ll view
+ disasm-test/tests/disubrangetype.ll view
@@ -0,0 +1,25 @@+;; This test checks generation of DISubrangeType.+;; Copy of llvm-project llvm/test/Bitcode/subrange_type.ll (https://github.com/llvm/llvm-project/blob/main/llvm/test/Bitcode/subrange_type.ll)++; ModuleID = 'subrange_type.ll'+source_filename = "/dir/subrange_type.adb"++!llvm.module.flags = !{!0, !1}+!llvm.dbg.cu = !{!2}++!0 = !{i32 2, !"Debug Info Version", i32 3}+!1 = !{i32 2, !"Dwarf Version", i32 4}+!2 = distinct !DICompileUnit(language: DW_LANG_Ada95, file: !3, producer: "GNAT/LLVM", isOptimized: false, runtimeVersion: 0, emissionKind: FullDebug, enums: !4, retainedTypes: !5, globals: !4, imports: !4)+!3 = !DIFile(filename: "subrange_type.adb", directory: "/dir")+!4 = !{}+!5 = !{!11}+!6 = distinct !DISubprogram(name: "sr", scope: !3, file: !3, line: 1, type: !7, scopeLine: 1, spFlags: DISPFlagDefinition, unit: !4, retainedNodes: !9)+!7 = !DISubroutineType(types: !8)+!8 = !{null}+!9 = !{!10}+!10 = !DILocalVariable(name: "x", scope: !6, file: !3, line: 3, type: !11, align: 32)+!11 = !DISubrangeType(name: "sr__int_range", file: !3, line: 2, size: 32, align: 32, baseType: !12, lowerBound: i64 -7, upperBound: i64 23, stride: i64 5, bias: i64 -1)+!12 = !DIBasicType(name: "sr__Tint_rangeB", size: 32, encoding: DW_ATE_signed)+!13 = !DILocation(line: 3, column: 4, scope: !6)+!14 = !DILocation(line: 6, column: 5, scope: !6)+
+ disasm-test/tests/disubrangetype.pre-llvm21.ll view
llvm-pretty-bc-parser.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 Name: llvm-pretty-bc-parser-Version: 0.6.0.0+Version: 0.6.1.0 License: BSD-3-Clause License-file: LICENSE Author: Trevor Elliott <trevor@galois.com>@@ -79,7 +79,7 @@ bytestring >= 0.10, containers >= 0.4, fgl >= 5.5,- llvm-pretty >= 0.14.0.0 && < 0.15,+ llvm-pretty >= 0.15.0.0 && < 0.16, mtl >= 2.2.2, pretty >= 1.0.1, uniplate >= 1.6,@@ -132,7 +132,6 @@ 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@@ -143,7 +142,8 @@ bytestring, exceptions >= 0.10 && < 0.11, filepath,- lens,+ microlens,+ pretty, pretty-show>= 1.6, prettyprinter >= 1.7 && < 1.8, string-interpolate >= 0.3 && < 0.4,@@ -152,8 +152,8 @@ tasty-expected-failure >= 0.12 && < 0.13, tasty-hunit, tasty-sugar >= 2.2 && < 2.3,+ temporary, transformers >= 0.5 && < 0.7,- tree-diff >= 0.2 && < 0.4, terminal-size >= 0.3 && < 0.4, text, versions < 7,
src/Data/LLVM/BitCode/IR/Constants.hs view
@@ -279,11 +279,29 @@ build k = do a <- parseField r 0 (fmap k . numeric) return (getTy, (Typed ty $! a):cs)+ let build2 :: (Num a, Bits a, Num b, Bits b) => (a -> b -> PValue) -> Parse (Parse Type, [Typed PValue])+ build2 k = do+ a <- parseField r 0 numeric+ b <- parseField r 1 numeric+ return (getTy, (Typed ty $! k a b):cs) case ft of+ Half -> build (ValHalf . FPHalf)+ BFloat -> build (ValBFloat . FPBFloat) Float -> build (ValFloat . castFloat) Double -> build (ValDouble . castDouble)+ -- x86 80-bit float X86_fp80 -> fp80build ty r cs getTy- _ -> error $ "parseConstantEntry: Unsupported type " ++ show ft+ -- IEEE 128-bit quad; ships as a pair of 64-bit values.+ Fp128 -> build2 (\a b -> ValFP128 $ FP128_LongDouble a b)+ -- PPC's weird quad, a pair of doubles.+ PPC_fp128 ->+ let construct a b =+ let a' = castDouble a+ b' = castDouble b+ in+ ValFP128_PPC $ FP128_PPC_DoubleDouble a' b'+ in+ build2 construct -- [n x value number] 7 -> label "CST_CODE_AGGREGATE" $ do@@ -685,15 +703,21 @@ res <- castSTUArray arr readArray res 0 --- fp80 is double extended format. This conforms to IEEE 754, but is--- store as two values: the significand and the exponent. Discussion--- here is relative to information from the LLVM source based at--- https://github.com/llvm-mirror/llvm/blob/release_60 (hereafter--- identified as LGH).+-- fp80 is the x86 extended double format. It (mostly) conforms to+-- IEEE 754, but is stored as two values: the significand and the+-- exponent. Discussion here is relative to information from the LLVM+-- source based at https://github.com/llvm-mirror/llvm/blob/release_60+-- (hereafter identified as LGH). ----- The exponent range is 16383..-16384 (14 bits), and the precision--- (significand bits) is 64, including the integer bit (see--- LGH/lib/Support/APFloat.cpp:75).+-- The exponent range is 16383..-16384 (15 bits), and there are 64+-- bits of mantissa. This includes, unlike IEEE floats, the integer+-- (ones) bit. Thus, the _significand_ size is 63.+--+-- (See LGH/lib/Support/APFloat.cpp:75). Also your favorite x86 docs.+--+-- Note that there's also an m68k 80-bit float; it has essentially the+-- same layout but subtly different semantics. Probably LLVM will+-- never bother to support it. -- -- When reading the Record here, there are two fields, one of 65 bits -- and the other of up to 20 bits (which clearly adds to more than
src/Data/LLVM/BitCode/IR/Function.hs view
@@ -337,9 +337,9 @@ -- | Parse the function block. parseFunctionBlock ::- Int {- ^ unnamed globals so far -} ->+ UnnamedMdIdx {- ^ maximum unnamed Metadata index so far -} -> [Entry] -> Parse PartialDefine-parseFunctionBlock unnamedGlobals ents =+parseFunctionBlock maxUnMdIdx ents = label "FUNCTION_BLOCK" $ enterFunctionDef $ do -- parse the value symtab block first, so that names are present during the@@ -357,7 +357,7 @@ -- generate the initial partial definition pd <- emptyPartialDefine proto- rec pd' <- foldM (parseFunctionBlockEntry unnamedGlobals vt) pd ents+ rec pd' <- foldM (parseFunctionBlockEntry maxUnMdIdx vt) pd ents vt <- getValueTable -- merge the symbol table with the anonymous symbol table@@ -365,7 +365,7 @@ -- | Parse the members of the function block parseFunctionBlockEntry ::- Int {- ^ unnamed globals so far -} ->+ UnnamedMdIdx {- ^ maximum unnamed metadata index used so far -} -> ValueTable -> PartialDefine -> Entry -> Parse PartialDefine @@ -1144,15 +1144,15 @@ -- this is parsed before any of the function block return d -parseFunctionBlockEntry globals t d (metadataBlockId -> Just es) = do- (_, (globalUnnamedMds, localUnnamedMds), _, _, _) <- parseMetadataBlock globals t es+parseFunctionBlockEntry maxUnMdIdx t d (metadataBlockId -> Just es) = do+ (_, (globalUnnamedMds, localUnnamedMds), _, _, _) <- parseMetadataBlock maxUnMdIdx t es if (null localUnnamedMds) then return d { partialGlobalMd = globalUnnamedMds <> partialGlobalMd d } else return d -- silently drop unexpected local unnamed metadata -parseFunctionBlockEntry globals t d (metadataAttachmentBlockId -> Just es) = do+parseFunctionBlockEntry maxUnMdIdx t d (metadataAttachmentBlockId -> Just es) = do (_,(globalUnnamedMds, localUnnamedMds),instrAtt,fnAtt,_)- <- parseMetadataBlock globals t es+ <- parseMetadataBlock maxUnMdIdx t es unless (null localUnnamedMds) (fail "parseFunctionBlockEntry PANIC: unexpected local unnamed metadata") unless (null globalUnnamedMds)
src/Data/LLVM/BitCode/IR/Metadata.hs view
@@ -40,6 +40,7 @@ import Control.Monad (foldM, guard, mplus, unless, when) import Data.Bits ( Bits, shiftR, testBit, shiftL, (.&.), (.|.), bit , complement )+import Data.Bool ( bool ) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as Char8 (unpack) import Data.Data (Data)@@ -53,7 +54,7 @@ import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Typeable (Typeable)-import Data.Word (Word8,Word32,Word64)+import Data.Word (Word8,Word16,Word32,Word64) import GHC.Generics (Generic) import GHC.Stack (HasCallStack, callStack)@@ -64,26 +65,32 @@ data MetadataTable = MetadataTable { mtEntries :: MdTable- , mtNextNode :: !Int- , mtNodes :: IntMap.IntMap (Bool, Bool, Int)+ , mtNextNode :: !UnnamedMdIdx+ , mtNodes :: IntMap.IntMap (Bool, Bool, UnnamedMdIdx) -- ^ The entries in the map are: is the entry function local, -- is the entry distinct, and the implicit id for the node. } deriving (Show) emptyMetadataTable ::- Int {- ^ globals seen so far -} ->+ UnnamedMdIdx {- ^ maximum unnamed metadata index seen so far -} -> MdTable -> MetadataTable-emptyMetadataTable globals es = MetadataTable+emptyMetadataTable maxUnMdIdx es = MetadataTable { mtEntries = es- , mtNextNode = globals+ , mtNextNode = maxUnMdIdx , mtNodes = IntMap.empty } metadata :: PValMd -> Typed PValue metadata = Typed (PrimType Metadata) . ValMd -addMetadata :: PValMd -> MetadataTable -> (Int,MetadataTable)-addMetadata val mt = (ix, mt { mtEntries = es' })+parseMdIdx :: Record -> Int -> Parse UnnamedMdIdx+parseMdIdx r n = UnnamedMdIdx <$> parseField r n numeric++parseMultiMdIdx :: Record -> Int -> Parse [UnnamedMdIdx]+parseMultiMdIdx r n = fmap UnnamedMdIdx <$> parseFields r n numeric++addMetadata :: PValMd -> MetadataTable -> (UnnamedMdIdx, MetadataTable)+addMetadata val mt = (UnnamedMdIdx ix, mt { mtEntries = es' }) where (ix,es') = addValue' (metadata val) (mtEntries mt) @@ -95,10 +102,11 @@ , typedValue = ValMd (ValMdValue tv) } -nameNode :: Bool -> Bool -> Int -> MetadataTable -> MetadataTable+nameNode :: Bool -> Bool -> UnnamedMdIdx -> MetadataTable -> MetadataTable nameNode fnLocal isDistinct ix mt = mt- { mtNodes = IntMap.insert ix (fnLocal,isDistinct,mtNextNode mt) (mtNodes mt)- , mtNextNode = mtNextNode mt + 1+ { mtNodes = IntMap.insert (unnamedMdIdx ix) (fnLocal,isDistinct,mtNextNode mt)+ (mtNodes mt)+ , mtNextNode = nextUnnamedMdIdx $ mtNextNode mt } addString :: String -> PartialMetadata -> PartialMetadata@@ -148,34 +156,33 @@ where (ix,mt') = addMetadata (ValMdNode [ Just (ValMdValue tv) | tv <- vals ]) mt -mdForwardRef :: [String] -> MetadataTable -> Int -> PValMd+mdForwardRef :: [String] -> MetadataTable -> UnnamedMdIdx -> PValMd mdForwardRef cxt mt ix = fromMaybe fallback nodeRef where- nodeRef = reference `fmap` IntMap.lookup ix (mtNodes mt)- fallback = case forwardRef cxt ix (mtEntries mt) of+ nodeRef = reference `fmap` IntMap.lookup (unnamedMdIdx ix) (mtNodes mt)+ fallback = case forwardRef cxt (unnamedMdIdx ix) (mtEntries mt) of Typed { typedValue = ValMd md } -> md tv -> ValMdValue tv reference (False, _, r) = ValMdRef r reference (_ , _, r) = let explanation = "Illegal forward reference into function-local metadata."- in throw (BadValueRef callStack cxt explanation r)+ in throw (BadValueRef callStack cxt explanation $ unnamedMdIdx r) -mdForwardRefOrNull :: [String] -> MetadataTable -> Int -> Maybe PValMd-mdForwardRefOrNull cxt mt ix | ix > 0 = Just (mdForwardRef cxt mt (ix - 1))- | otherwise = Nothing+mdForwardRefOrNull :: [String] -> MetadataTable -> UnnamedMdIdx -> Maybe PValMd+mdForwardRefOrNull cxt mt ix = mdForwardRef cxt mt <$> nonNullUnnamedMdIdx ix mdNodeRef :: HasCallStack- => [String] -> MetadataTable -> Int -> Int-mdNodeRef cxt mt ix = maybe except prj (IntMap.lookup ix (mtNodes mt))+ => [String] -> MetadataTable -> UnnamedMdIdx -> UnnamedMdIdx+mdNodeRef cxt mt ix = maybe except prj (IntMap.lookup (unnamedMdIdx ix) (mtNodes mt)) where explanation = "Bad forward reference into mtNodes"- except = throw (BadValueRef callStack cxt explanation ix)+ except = throw (BadValueRef callStack cxt explanation $ unnamedMdIdx ix) prj (_, _, x) = x mdString :: HasCallStack- => [String] -> PartialMetadata -> Int -> String+ => [String] -> PartialMetadata -> UnnamedMdIdx -> String mdString cxt partialMeta ix = let explanation = "Null value when metadata string was expected"- in fromMaybe (throw (BadValueRef callStack cxt explanation ix))+ in fromMaybe (throw (BadValueRef callStack cxt explanation $ unnamedMdIdx ix)) (mdStringOrNull cxt partialMeta ix) -- | This preferentially fetches the string from the strict string table@@ -183,21 +190,21 @@ mdStringOrNull :: HasCallStack => [String] -> PartialMetadata- -> Int+ -> UnnamedMdIdx -> Maybe String mdStringOrNull cxt partialMeta ix =- Map.lookup (ix - 1) (pmStrings partialMeta) <|>- case mdForwardRefOrNull cxt (pmEntries partialMeta) ix of- Nothing -> Nothing- Just (ValMdString str) -> Just str- Just _ ->- let explanation = "Non-string metadata when string was expected"- in throw (BadTypeRef callStack cxt explanation ix)+ do aix <- nonNullUnnamedMdIdx ix+ Map.lookup aix (pmStrings partialMeta)+ <|> case mdForwardRef cxt (pmEntries partialMeta) aix of+ ValMdString str -> Just str+ _ -> let explanation = "Non-string metadata when string was expected"+ in throw (BadTypeRef callStack cxt explanation $ unnamedMdIdx ix) + mdStringOrEmpty :: HasCallStack => [String] -> PartialMetadata- -> Int+ -> UnnamedMdIdx -> String mdStringOrEmpty cxt partialMeta = fromMaybe "" . mdStringOrNull cxt partialMeta @@ -210,12 +217,12 @@ data PartialMetadata = PartialMetadata { pmEntries :: MetadataTable- , pmNamedEntries :: Map.Map String [Int]+ , pmNamedEntries :: Map.Map String [UnnamedMdIdx] , pmNextName :: Maybe String , pmInstrAttachments :: InstrMdAttachments , pmFnAttachments :: PFnMdAttachments , pmGlobalAttachments:: PGlobalAttachments- , pmStrings :: Map Int String+ , pmStrings :: Map UnnamedMdIdx String -- ^ Forward references to metadata strings are never actually -- forward references, string blocks (@METADATA_STRINGS@) always come first. -- So references to them don't need to be inside the @MonadFix@ like@@ -227,10 +234,10 @@ } deriving (Show) emptyPartialMetadata ::- Int {- ^ globals seen so far -} ->+ UnnamedMdIdx {- ^ maximum unnamed metadata index seen so far -} -> MdTable -> PartialMetadata-emptyPartialMetadata globals es = PartialMetadata- { pmEntries = emptyMetadataTable globals es+emptyPartialMetadata maxUnMdIdx es = PartialMetadata+ { pmEntries = emptyMetadataTable maxUnMdIdx es , pmNamedEntries = Map.empty , pmNextName = Nothing , pmInstrAttachments = Map.empty@@ -264,7 +271,7 @@ addInstrAttachment instr md pm = pm { pmInstrAttachments = Map.insert instr md (pmInstrAttachments pm) } -nameMetadata :: [Int] -> PartialMetadata -> Parse PartialMetadata+nameMetadata :: [UnnamedMdIdx] -> PartialMetadata -> Parse PartialMetadata nameMetadata val pm = case pmNextName pm of Just name -> return $! pm { pmNextName = Nothing@@ -295,18 +302,18 @@ -- | We avoid erroneously recursing into ValMdValues and exit early on -- a few other constructors de-duplication wouldn't affect.- maybeTransform :: Map PValMd Int -> PValMd -> PValMd+ maybeTransform :: Map PValMd UnnamedMdIdx -> PValMd -> PValMd maybeTransform pumdMap v@(ValMdNode _) = transform (trans pumdMap) v maybeTransform pumdMap v@(ValMdLoc _) = transform (trans pumdMap) v maybeTransform pumdMap v@(ValMdDebugInfo _) = transform (trans pumdMap) v maybeTransform _ v = v - trans :: Map PValMd Int -> PValMd -> PValMd+ trans :: Map PValMd UnnamedMdIdx -> PValMd -> PValMd trans pumdMap v = case Map.lookup v pumdMap of Just idex -> ValMdRef idex Nothing -> v - mkPartialUnnamedMdMap :: Seq PartialUnnamedMd -> Map PValMd Int+ mkPartialUnnamedMdMap :: Seq PartialUnnamedMd -> Map PValMd UnnamedMdIdx mkPartialUnnamedMdMap = foldl' (\mp part -> Map.insert (pumValues part) (pumIndex part) mp) Map.empty @@ -319,7 +326,7 @@ . pmNamedEntries data PartialUnnamedMd = PartialUnnamedMd- { pumIndex :: Int+ { pumIndex :: UnnamedMdIdx , pumValues :: PValMd , pumDistinct :: Bool } deriving (Data, Eq, Ord, Generic, Show, Typeable)@@ -338,18 +345,19 @@ -- | Partition unnamed entries into global and function local unnamed entries. unnamedEntries :: PartialMetadata -> (Seq PartialUnnamedMd, Seq PartialUnnamedMd)-unnamedEntries pm = bimap Seq.fromList Seq.fromList (partitionEithers (mapMaybe resolveNode (IntMap.toList (mtNodes mt))))+unnamedEntries pm = bimap Seq.fromList Seq.fromList+ (partitionEithers (mapMaybe resolveNode (IntMap.toList (mtNodes mt)))) where mt = pmEntries pm -- TODO: is this silently eating errors with metadata that's not in the -- value table (when the lookupValueTableAbs fails)?- resolveNode :: (Int, (Bool, Bool, Int))+ resolveNode :: (Int, (Bool, Bool, UnnamedMdIdx)) -> Maybe (Either PartialUnnamedMd PartialUnnamedMd) resolveNode (ref,(fnLocal,d,ix)) = ((if fnLocal then Right else Left) <$> lookupNode ref d ix) - lookupNode :: Int -> Bool -> Int -> Maybe PartialUnnamedMd+ lookupNode :: Int -> Bool -> UnnamedMdIdx -> Maybe PartialUnnamedMd lookupNode ref d ix = do tv <- lookupValueTableAbs ref (mtEntries mt) case tv of@@ -387,11 +395,11 @@ -- Metadata Parsing ------------------------------------------------------------ parseMetadataBlock ::- Int {- ^ globals seen so far -} ->+ UnnamedMdIdx {- ^ maximum unnamed metadata index seen so far -} -> ValueTable -> [Entry] -> Parse ParsedMetadata-parseMetadataBlock globals vt es = label "METADATA_BLOCK" $ do+parseMetadataBlock maxUnMdIdx vt es = label "METADATA_BLOCK" $ do ms <- getMdTable- let pm0 = emptyPartialMetadata globals ms+ let pm0 = emptyPartialMetadata maxUnMdIdx ms rec pm <- foldM (parseMetadataEntry vt (pmEntries pm)) pm0 es let entries = pmEntries pm setMdTable (mtEntries entries)@@ -410,9 +418,29 @@ parseMetadataEntry vt mt pm (fromEntry -> Just r) = let -- Helpers for common patterns which appear below in parsing metadata ron n = do ctx <- getContext- mdForwardRefOrNull ctx mt <$> parseField r n numeric+ mdForwardRefOrNull ctx mt <$> parseMdIdx r n ronl n = if length (recordFields r) <= n then pure Nothing else ron n + -- Converts from the parsed raw numeric value (a two's-complement+ -- representation) into a native positive or negative value.+ asSignedVal = fmap $ \case+ v@(ValMdValue tv)+ | PrimType (Integer s) <- typedType tv+ , ValInteger i <- typedValue tv+ -> let checkNeg x =+ if testBit x (fromEnum $ s - 1)+ then+ let xNeg = toInteger (complement x + 1) * (-1)+ in ValMdValue $ tv { typedValue = ValInteger xNeg }+ else v+ in case s of+ 8 -> checkNeg (fromInteger i :: Word8)+ 16 -> checkNeg (fromInteger i :: Word16)+ 32 -> checkNeg (fromInteger i :: Word32)+ 64 -> checkNeg (fromInteger i :: Word64)+ _ -> v+ o -> o+ -- 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@@ -427,6 +455,17 @@ (Just . ValMdValue . Typed (PrimType (Integer 64)) . ValInteger) (parseField r n numeric) + -- Used when some sort of placeholder entry must be added to the metadata+ -- table, because it may be cross-referenced by other metadata; here we use+ -- an empty expression as that placeholder.+ placeholderRecord :: DebugInfo' Int+ placeholderRecord = DebugInfoExpression $ DIExpression mempty++ mdNotImplemented :: String -> Parse PartialMetadata+ mdNotImplemented name = do+ addParseWarning $ UnsupportedMetadataRecordCode (recordCode r) name+ return $! updateMetadataTable (addDebugInfo False placeholderRecord) pm+ -- 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@@ -481,8 +520,8 @@ cxt <- getContext isDistinct <- parseField r 0 nonzero loc <- parseDebugLoc 1- (pure . mdForwardRef cxt mt)- (pure . mdForwardRefOrNull cxt mt) r+ (pure . mdForwardRef cxt mt . UnnamedMdIdx)+ (pure . mdForwardRefOrNull cxt mt . UnnamedMdIdx) r return $! updateMetadataTable (addLoc isDistinct loc) pm -- [n x (type num, value num)]@@ -493,7 +532,7 @@ -- [n x mdnodes] 10 -> label "METADATA_NAMED_NODE" $ do- mdIds <- parseFields r 0 numeric+ mdIds <- parseMultiMdIdx r 0 cxt <- getContext let ids = map (mdNodeRef cxt mt) mdIds nameMetadata ids pm@@ -561,7 +600,7 @@ let isDistinct = testBit (flags :: Int) 0 isUnsigned = testBit (flags :: Int) 1 isBigInt = testBit (flags :: Int) 2- name <- mdString ctx pm <$> parseField r 2 numeric+ name <- mdString ctx pm <$> parseMdIdx r 2 value <- if isBigInt -- LLVM 12 or later@@ -572,13 +611,13 @@ return $! updateMetadataTable (addDebugInfo isDistinct diEnum) pm 15 -> label "METADATA_BASIC_TYPE" $ do- assertRecordSizeBetween r 6 8+ assertRecordSizeBetween r 6 9 ctx <- getContext 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+ dibtName <- mdString ctx pm <$> parseMdIdx r 2 dibtSize <- mdOrConstant sizeIsMetadata 3 dibtAlign <- parseField r 4 numeric dibtEncoding <- parseField r 5 numeric@@ -589,6 +628,10 @@ if length (recordFields r) <= 7 then pure 0 else parseField r 7 numeric+ dibtDataSize <-+ if length (recordFields r) <= 8+ then pure 0+ else parseField r 8 numeric let dibt = DIBasicType {..} return $! updateMetadataTable (addDebugInfo isDistinct (DebugInfoBasicType dibt)) pm@@ -598,8 +641,8 @@ assertRecordSizeIn r [3, 5] ctx <- getContext isDistinct <- parseField r 0 nonzero- difFilename <- mdStringOrEmpty ctx pm <$> parseField r 1 numeric- difDirectory <- mdStringOrEmpty ctx pm <$> parseField r 2 numeric+ difFilename <- mdStringOrEmpty ctx pm <$> parseMdIdx r 1+ difDirectory <- mdStringOrEmpty ctx pm <$> parseMdIdx r 2 let diFile = DIFile {..} return $! updateMetadataTable (addDebugInfo isDistinct (DebugInfoFile diFile)) pm@@ -614,7 +657,7 @@ let isDistinct = testBit (flags :: Int) 0 sizeIsMetadata = testBit (flags :: Int) 1 didtTag <- parseField r 1 numeric- didtName <- mdStringOrNull ctx pm <$> parseField r 2 numeric+ didtName <- mdStringOrNull ctx pm <$> parseMdIdx r 2 didtFile <- ron 3 didtLine <- parseField r 4 numeric didtScope <- ron 5@@ -652,7 +695,7 @@ -- isNotUsedInTypeRef = testBit (flags :: Int) 1 sizeIsMetadata = testBit (flags :: Int) 2 dictTag <- parseField r 1 numeric- dictName <- mdStringOrNull ctx pm <$> parseField r 2 numeric+ dictName <- mdStringOrNull ctx pm <$> parseMdIdx r 2 dictFile <- ron 3 dictLine <- parseField r 4 numeric dictScope <- ron 5@@ -665,12 +708,12 @@ dictRuntimeLang <- parseField r 12 numeric dictVTableHolder <- ron 13 dictTemplateParams <- ron 14- dictIdentifier <- mdStringOrNull ctx pm <$> parseField r 15 numeric+ dictIdentifier <- mdStringOrNull ctx pm <$> parseMdIdx r 15 dictDiscriminator <- ronl 16 dictDataLocation <- ronl 17 dictAssociated <- ronl 18 dictAllocated <- ronl 19- dictRank <- ronl 20+ dictRank <- asSignedVal <$> ronl 20 dictAnnotations <- ronl 21 dictNumExtraInhabitants <- if length (recordFields r) <= 22 then pure 0@@ -697,17 +740,17 @@ (addDebugInfo isDistinct (DebugInfoSubroutineType dist)) pm 20 -> label "METADATA_COMPILE_UNIT" $ do- assertRecordSizeBetween r 14 22+ assertRecordSizeBetween r 14 23 let recordSize = length (recordFields r) ctx <- getContext isDistinct <- parseField r 0 nonzero dicuLanguage <- parseField r 1 numeric dicuFile <- ron 2- dicuProducer <- mdStringOrNull ctx pm <$> parseField r 3 numeric+ dicuProducer <- mdStringOrNull ctx pm <$> parseMdIdx r 3 dicuIsOptimized <- parseField r 4 nonzero- dicuFlags <- mdStringOrNull ctx pm <$> parseField r 5 numeric+ dicuFlags <- mdStringOrNull ctx pm <$> parseMdIdx r 5 dicuRuntimeVersion <- parseField r 6 numeric- dicuSplitDebugFilename <- mdStringOrNull ctx pm <$> parseField r 7 numeric+ dicuSplitDebugFilename <- mdStringOrNull ctx pm <$> parseMdIdx r 7 dicuEmissionKind <- parseField r 8 numeric dicuEnums <- ron 9 dicuRetainedTypes <- ron 10@@ -734,10 +777,14 @@ else parseField r 19 nonzero dicuSysRoot <- if recordSize <= 20 then pure Nothing- else mdStringOrNull ctx pm <$> parseField r 20 numeric+ else mdStringOrNull ctx pm <$> parseMdIdx r 20 dicuSDK <- if recordSize <= 21 then pure Nothing- else mdStringOrNull ctx pm <$> parseField r 21 numeric+ else mdStringOrNull ctx pm <$> parseMdIdx r 21+ dicuSourceLanguageVersion <-+ if recordSize <= 22+ then pure 0+ else parseField r 22 numeric let dicu = DICompileUnit {..} return $! updateMetadataTable (addDebugInfo isDistinct (DebugInfoCompileUnit dicu)) pm@@ -839,12 +886,12 @@ -- Forward references that depend on the 'version' let optFwdRef b n = if b- then mdForwardRefOrNull ctx mt <$> parseField r n numeric+ then mdForwardRefOrNull ctx mt . UnnamedMdIdx <$> parseField r n numeric else pure Nothing dispScope <- ron 1- dispName <- mdStringOrNull ctx pm <$> parseField r 2 numeric- dispLinkageName <- mdStringOrNull ctx pm <$> parseField r 3 numeric+ dispName <- mdStringOrNull ctx pm <$> parseMdIdx r 2+ dispLinkageName <- mdStringOrNull ctx pm <$> parseMdIdx r 3 dispFile <- ron 4 dispLine <- parseField r 5 numeric dispType <- ron 6@@ -884,7 +931,7 @@ assertRecordSizeIn r [4] cxt <- getContext isDistinct <- parseField r 0 nonzero- dilbfScope <- mdForwardRef cxt mt <$> parseField r 1 numeric+ dilbfScope <- mdForwardRef cxt mt <$> parseMdIdx r 1 dilbfFile <- ron 2 dilbfDiscriminator <- parseField r 3 numeric let dilbf = DILexicalBlockFile {..}@@ -894,15 +941,15 @@ 24 -> label "METADATA_NAMESPACE" $ do assertRecordSizeIn r [3, 5] let isNew = length (recordFields r) == 3- let nameIdx = if isNew then 2 else 3+ let nameIdx = bool 3 2 isNew cxt <- getContext isDistinct <- parseField r 0 nonzero- dinsName <- mdStringOrNull cxt pm <$> parseField r nameIdx numeric- dinsScope <- mdForwardRef cxt mt <$> parseField r 1 numeric+ dinsName <- mdStringOrNull cxt pm <$> parseMdIdx r nameIdx+ dinsScope <- mdForwardRef cxt mt <$> parseMdIdx r 1 dinsFile <- if isNew then return (ValMdString "")- else mdForwardRef cxt mt <$> parseField r 2 numeric+ else mdForwardRef cxt mt <$> parseMdIdx r 2 dinsLine <- if isNew then return 0 else parseField r 4 numeric let dins = DINameSpace {..} return $! updateMetadataTable@@ -913,7 +960,7 @@ let hasIsDefault = length (recordFields r) == 4 cxt <- getContext isDistinct <- parseField r 0 nonzero- dittpName <- mdStringOrNull cxt pm <$> parseField r 1 numeric+ dittpName <- mdStringOrNull cxt pm <$> parseMdIdx r 1 dittpType <- ron 2 dittpIsDefault <- if hasIsDefault then Just <$> parseField r 3 boolean@@ -928,12 +975,12 @@ cxt <- getContext isDistinct <- parseField r 0 nonzero ditvpTag <- parseField r 1 numeric- ditvpName <- mdStringOrNull cxt pm <$> parseField r 2 numeric+ ditvpName <- mdStringOrNull cxt pm <$> parseMdIdx r 2 ditvpType <- ron 3 ditvpIsDefault <- if hasIsDefault then Just <$> parseField r 4 boolean else pure Nothing- ditvpValue <- mdForwardRef cxt mt <$> parseField r (if hasIsDefault then 5 else 4) numeric+ ditvpValue <- mdForwardRef cxt mt <$> parseMdIdx r (bool 4 5 hasIsDefault) let ditvp = DITemplateValueParameter {..} return $! updateMetadataTable (addDebugInfo isDistinct (DebugInfoTemplateValueParameter ditvp)) pm@@ -946,8 +993,8 @@ _version = shiftR field0 1 :: Int digvScope <- ron 1- digvName <- mdStringOrNull ctx pm <$> parseField r 2 numeric- digvLinkageName <- mdStringOrNull ctx pm <$> parseField r 3 numeric+ digvName <- mdStringOrNull ctx pm <$> parseMdIdx r 2+ digvLinkageName <- mdStringOrNull ctx pm <$> parseMdIdx r 3 digvFile <- ron 4 digvLine <- parseField r 5 numeric digvType <- ron 6@@ -981,14 +1028,14 @@ dilvScope <- mdForwardRefOrNull ("dilvScope":ctx) mt- <$> parseField r (adj 1) numeric+ <$> parseMdIdx r (adj 1) dilvName <- mdStringOrNull ("dilvName" :ctx) pm- <$> parseField r (adj 2) numeric+ <$> parseMdIdx r (adj 2) dilvFile <- mdForwardRefOrNull ("dilvFile" :ctx) mt- <$> parseField r (adj 3) numeric+ <$> parseMdIdx r (adj 3) dilvLine <- parseField r (adj 4) numeric dilvType <- mdForwardRefOrNull ("dilvType" :ctx) mt- <$> parseField r (adj 5) numeric+ <$> parseMdIdx r (adj 5) dilvArg <- parseField r (adj 6) numeric dilvFlags <- parseField r (adj 7) numeric dilvAlignment <-@@ -1032,7 +1079,7 @@ then ron 6 else pure Nothing diieLine <- parseField r 4 numeric- diieName <- mdStringOrNull cxt pm <$> parseField r 5 numeric+ diieName <- mdStringOrNull cxt pm <$> parseMdIdx r 5 let diie = DIImportedEntity {..} return $! updateMetadataTable (addDebugInfo isDistinct (DebugInfoImportedEntity diie)) pm@@ -1131,7 +1178,7 @@ let isDistinct = testBit flags 0 dilIsArtificial = testBit flags 1 dilScope <- ron 1- dilName <- mdString cxt pm <$> parseField r 2 numeric+ dilName <- mdString cxt pm <$> parseMdIdx r 2 dilFile <- ron 3 dilLine <- parseField r 4 numeric dilColumn <-@@ -1157,22 +1204,19 @@ return $! updateMetadataTable (addDebugInfo isDistinct (DebugInfoLabel dil)) pm - 41 -> label "METADATA_STRING_TYPE" $ do- notImplemented+ 41 -> mdNotImplemented "METADATA_STRING_TYPE" -- Codes 42 and 43 are reserved for Fortran array–specific debug info, see -- https://github.com/llvm/llvm-project/blob/4681f6111e655057f5015564a9bf3705f87495bf/llvm/include/llvm/Bitcode/LLVMBitCodes.h#L348-L349 - 44 -> label "METADATA_COMMON_BLOCK" $ do- notImplemented+ 44 -> mdNotImplemented "METADATA_COMMON_BLOCK" - 45 -> label "METADATA_GENERIC_SUBRANGE" $ do- notImplemented+ 45 -> mdNotImplemented "METADATA_GENERIC_SUBRANGE" 46 -> label "METADATA_ARG_LIST" $ do cxt <- getContext dial <- DIArgList- <$> (map (mdForwardRef cxt mt) <$> parseFields r 0 numeric)+ <$> (map (mdForwardRef cxt mt) <$> parseMultiMdIdx r 0) return $! updateMetadataTable (addInlineDebugInfo (DebugInfoArgList dial)) pm @@ -1186,8 +1230,66 @@ return $! updateMetadataTable (addDebugInfo isDistinct DebugInfoAssignID) pm - code -> fail ("unknown record code: " ++ show code)+ 48 -> label "METADATA_SUBRANGE_TYPE" $ do+ assertRecordSizeIn r [13]+ ctx <- getContext+ field0 <- parseField r 0 unsigned+ let isDistinct = field0 .&. 0 == 1+ disrtName <- mdStringOrNull ctx pm <$> parseMdIdx r 1+ disrtFile <- ron 2+ disrtLine <- parseField r 3 numeric+ disrtScope <- ron 4+ disrtSize <- ron 5+ disrtAlign <- parseField r 6 numeric+ disrtFlags <- parseField r 7 numeric+ disrtBaseType <- ron 8+ disrtLowerBound <- asSignedVal <$> ron 9+ disrtUpperBound <- asSignedVal <$> ron 10+ disrtStride <- asSignedVal <$> ron 11+ disrtBias <- asSignedVal <$> ron 12+ let disrt = DISubrangeType {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoSubrangeType disrt)) pm + 49 -> label "METADATA_FIXED_POINT_TYPE" $ do+ assertRecordSizeAtLeast r 11+ ctx <- getContext+ field0 <- parseField r 0 unsigned+ let isDistinct = field0 .&. 0 == 1+ difptTag <- parseField r 1 numeric+ difptName <- mdStringOrNull ctx pm <$> parseMdIdx r 2+ difptSize <- ron 3+ difptAlign <- parseField r 4 numeric+ difptEncoding <- parseField r 5 numeric+ difptFlags <- parseField r 6 numeric+ kind <- parseField r 7 numeric+ difptKind <-+ case (kind :: Integer) of+ 0 -> FixedPointBinary <$> parseField r 8 numeric+ 1 -> FixedPointDecimal <$> parseField r 8 numeric+ 2 -> do let parseWInt n = do+ (encoded :: Word64) <- parseField r n numeric+ let nwords = fromEnum $ encoded `shiftR` 32+ -- let bitwidth = encoded .&. (1 `shiftL` 32) - 1)+ -- Technically, the value should be no wider than+ -- bitwidth bits, so we could apply a mask here,+ -- but we don't expect non-zero values in the+ -- unused portions of the parsed words so we can+ -- save the overhead of the masking operation.+ v <- parseWideAPInt r (n+1) nwords+ return (n+1+nwords, v)+ (idx, numerator) <- parseWInt 9+ (_, denominator) <- parseWInt idx+ return $ FixedPointRational numerator denominator+ _ -> fail $ "unrecognized FixedPointType kind: " <> show kind+ let difpt = DIFixedPointType {..}+ return $! updateMetadataTable+ (addDebugInfo isDistinct (DebugInfoFixedPointType difpt)) pm++ _ -> do+ addParseWarning $ UnknownMetadataRecordCode (recordCode r)+ return $! updateMetadataTable (addDebugInfo False placeholderRecord) pm+ parseMetadataEntry _ _ pm (abbrevDef -> Just _) = return pm @@ -1215,7 +1317,7 @@ go cxt acc n | n < len = do kind <- getKind =<< parseField r n numeric- i <- parseField r (n + 1) numeric+ i <- parseMdIdx r (n + 1) go cxt (Map.insert kind (mdForwardRef cxt mt i) acc) (n + 2) go _ acc _ =@@ -1226,7 +1328,7 @@ parseMetadataNode :: Bool -> MetadataTable -> Record -> PartialMetadata -> Parse PartialMetadata parseMetadataNode isDistinct mt r pm = do- ixs <- parseFields r 0 numeric+ ixs <- parseMultiMdIdx r 0 cxt <- getContext let lkp = mdForwardRefOrNull cxt mt return $! updateMetadataTable (addNode isDistinct (map lkp ixs)) pm@@ -1246,7 +1348,8 @@ ty <- getType' tyId val <- case ty of PrimType Metadata -> return $ Typed (PrimType Metadata)- (ValMd (mdForwardRef cxt mt valId))+ (ValMd (mdForwardRef cxt mt+ $ UnnamedMdIdx valId)) -- XXX need to check for a void type here _ -> return (forwardRef cxt valId vt)
src/Data/LLVM/BitCode/IR/Module.hs view
@@ -142,8 +142,8 @@ parseFunProto r pm parseModuleBlockEntry pm (functionBlockId -> Just es) = label "FUNCTION_BLOCK_ID" $ do- let unnamedGlobalsCount = length (partialUnnamedMd pm)- def <- parseFunctionBlock unnamedGlobalsCount es+ let maxUnMdIdx = UnnamedMdIdx $ length (partialUnnamedMd pm)+ def <- parseFunctionBlock maxUnMdIdx es let def' = def { partialGlobalMd = mempty } return pm { partialDefines = partialDefines pm Seq.|> def' , partialUnnamedMd = partialGlobalMd def <> partialUnnamedMd pm@@ -161,8 +161,8 @@ parseModuleBlockEntry pm (metadataBlockId -> Just es) = label "METADATA_BLOCK_ID" $ do vt <- getValueTable- let globalsSoFar = length (partialUnnamedMd pm)- (ns,(gs,_),_,_,atts) <- parseMetadataBlock globalsSoFar vt es+ let maxUnMdIdx = UnnamedMdIdx $ length (partialUnnamedMd pm)+ (ns,(gs,_),_,_,atts) <- parseMetadataBlock maxUnMdIdx vt es return $ addGlobalAttachments atts pm { partialNamedMd = partialNamedMd pm <> ns , partialUnnamedMd = partialUnnamedMd pm <> gs
src/Data/LLVM/BitCode/IR/Types.hs view
@@ -193,8 +193,7 @@ 22 -> label "TYPE_CODE_TOKEN" $ do notImplemented - 23 -> label "TYPE_CODE_BFLOAT" $ do- notImplemented+ 23 -> label "TYPE_CODE_BFLOAT" (addType (PrimType (FloatType BFloat))) 24 -> label "TYPE_CODE_X86_AMX" $ do notImplemented
src/Data/LLVM/BitCode/IR/Values.hs view
@@ -62,7 +62,7 @@ cxt <- getContext md <- getMdTable mdr <- getMdRefTable- case resolveMd n md mdr of+ case resolveMd (UnnamedMdIdx n) md mdr of Just tv -> return tv Nothing -> let explanation = "Illegal forward reference into metadata"
src/Data/LLVM/BitCode/Parse.hs view
@@ -305,7 +305,6 @@ data ValueTable = ValueTable { valueNextId :: !Int , valueEntries :: IntMap.IntMap (Typed PValue)- , strtabEntries :: IntMap.IntMap (Int, Int) , valueRelIds :: Bool } deriving (Show) @@ -313,7 +312,6 @@ emptyValueTable rel = ValueTable { valueNextId = 0 , valueEntries = IntMap.empty- , strtabEntries = IntMap.empty , valueRelIds = rel } @@ -439,21 +437,21 @@ getMetadata :: Int -> Parse (Typed PValMd) getMetadata ix = do ps <- Parse get- case resolveMd ix (psMdTable ps) (psMdRefs ps) of+ case resolveMd (UnnamedMdIdx 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 -> MdTable -> MdRefTable -> Maybe (Typed PValue)-resolveMd ix mdTable mdRefs = nodeRef `mplus` mdValue+resolveMd :: UnnamedMdIdx -> MdTable -> MdRefTable -> Maybe (Typed PValue)+resolveMd (UnnamedMdIdx ix) mdTable mdRefs = nodeRef `mplus` mdValue where reference = Typed (PrimType Metadata) . ValMd . ValMdRef nodeRef = reference `fmap` IntMap.lookup ix mdRefs mdValue = lookupValueTableAbs ix mdTable -type MdRefTable = IntMap.IntMap Int+type MdRefTable = IntMap.IntMap UnnamedMdIdx class Monad m => HasMdRefTable m where getMdRefTable :: m MdRefTable@@ -808,6 +806,13 @@ -- the @[String]@ is the stack trace at the point where the warning was -- emitted. InvalidMetadataRecordSize !Int !MetadataRecordSizeRange ![String]+ -- | The parser encountered a metadata record code that it is aware of, but+ -- does notknow how to parse, where the 'Int' is the record code value and+ -- the 'String' is the associated name of the record type.+ | UnsupportedMetadataRecordCode !Int !String+ -- | The parser encountered a metadata record code that it is not aware of,+ -- where the 'Int' is the record code value.+ | UnknownMetadataRecordCode !Int deriving Show -- | The expected size of a metadata record.@@ -849,6 +854,12 @@ "Expected one of:" PP.<+> PP.pPrint ns MetadataRecordSizeAtLeast lb -> "Expected size of" PP.<+> PP.pPrint lb PP.<+> "or greater"+ppParseWarning (UnsupportedMetadataRecordCode code name) =+ "Unsupported metadata record:"+ PP.<+> PP.text name+ PP.<+> PP.parens (PP.pPrint code)+ppParseWarning (UnknownMetadataRecordCode code) =+ "Unrecognized metadata record code:" PP.<+> PP.pPrint code -- | Pretty-print a group of 'ParseWarning's in a format suitable for -- user-facing messages.@@ -863,10 +874,12 @@ (\warning -> PP.nest 4 $ PP.vcat [ppParseWarning warning, ""]) (F.toList warnings) ++- [supportMsg | any isInvalidMetadataRecordSize warnings]+ [supportMsg | any maybeBadVersion warnings] where- isInvalidMetadataRecordSize :: ParseWarning -> Bool- isInvalidMetadataRecordSize (InvalidMetadataRecordSize {}) = True+ maybeBadVersion :: ParseWarning -> Bool+ maybeBadVersion (InvalidMetadataRecordSize {}) = True+ maybeBadVersion (UnknownMetadataRecordCode {}) = True+ maybeBadVersion _ = False supportMsg :: PP.Doc supportMsg =
unit-test/Tests/ExpressionInstances.hs view
@@ -31,9 +31,12 @@ instance Arbitrary lab => Arbitrary (DITemplateValueParameter' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DINameSpace' lab) where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DIBasicType' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DISubrangeType' 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+instance Arbitrary lab => Arbitrary (DIFixedPointType' lab) where arbitrary = genericArbitrary uniform+instance Arbitrary lab => Arbitrary (DIFixedPointKind' lab) where arbitrary = genericArbitrary uniform instance Arbitrary DIExpression where arbitrary = genericArbitrary uniform instance Arbitrary DIFile where arbitrary = genericArbitrary uniform instance Arbitrary lab => Arbitrary (DIGlobalVariable' lab) where arbitrary = genericArbitrary uniform@@ -52,3 +55,4 @@ 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+instance Arbitrary UnnamedMdIdx where arbitrary = genericArbitrary uniform
unit-test/Tests/PrimInstances.hs view
@@ -5,9 +5,17 @@ import Text.LLVM.AST +-- FUTURE: for floating point values, given what we're doing here, it+-- might be worth biasing the generation. Also if there's a way to do+-- so, generating the known special cases (+/-0, +/-Inf, and a few+-- NaNs and subnormals) up front before randomizing. instance Arbitrary PrimType where arbitrary = genericArbitrary uniform instance Arbitrary FloatType where arbitrary = genericArbitrary uniform+instance Arbitrary FPHalfValue where arbitrary = genericArbitrary uniform+instance Arbitrary FPBFloatValue where arbitrary = genericArbitrary uniform instance Arbitrary FP80Value where arbitrary = genericArbitrary uniform+instance Arbitrary FP128Value where arbitrary = genericArbitrary uniform+instance Arbitrary FP128_PPCValue where arbitrary = genericArbitrary uniform instance Arbitrary Ident where arbitrary = genericArbitrary uniform instance Arbitrary Symbol where arbitrary = genericArbitrary uniform