diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/disasm-test/Instances.hs b/disasm-test/Instances.hs deleted file mode 100644 --- a/disasm-test/Instances.hs +++ /dev/null @@ -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 diff --git a/disasm-test/Main.hs b/disasm-test/Main.hs --- a/disasm-test/Main.hs +++ b/disasm-test/Main.hs @@ -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 diff --git a/disasm-test/tests/constantbfloat.ll b/disasm-test/tests/constantbfloat.ll new file mode 100644 --- /dev/null +++ b/disasm-test/tests/constantbfloat.ll @@ -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 diff --git a/disasm-test/tests/constantbfloat.pre-llvm11.ll b/disasm-test/tests/constantbfloat.pre-llvm11.ll new file mode 100644 --- /dev/null +++ b/disasm-test/tests/constantbfloat.pre-llvm11.ll @@ -0,0 +1,1 @@ +SKIP_TEST bfloats were introduced in llvm-11 diff --git a/disasm-test/tests/constantfloat.ll b/disasm-test/tests/constantfloat.ll new file mode 100644 --- /dev/null +++ b/disasm-test/tests/constantfloat.ll @@ -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 diff --git a/disasm-test/tests/difixedpointtype.ll b/disasm-test/tests/difixedpointtype.ll new file mode 100644 --- /dev/null +++ b/disasm-test/tests/difixedpointtype.ll @@ -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) diff --git a/disasm-test/tests/difixedpointtype.pre-llvm21.ll b/disasm-test/tests/difixedpointtype.pre-llvm21.ll new file mode 100644 --- /dev/null +++ b/disasm-test/tests/difixedpointtype.pre-llvm21.ll diff --git a/disasm-test/tests/disubrangetype.ll b/disasm-test/tests/disubrangetype.ll new file mode 100644 --- /dev/null +++ b/disasm-test/tests/disubrangetype.ll @@ -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) + diff --git a/disasm-test/tests/disubrangetype.pre-llvm21.ll b/disasm-test/tests/disubrangetype.pre-llvm21.ll new file mode 100644 --- /dev/null +++ b/disasm-test/tests/disubrangetype.pre-llvm21.ll diff --git a/llvm-pretty-bc-parser.cabal b/llvm-pretty-bc-parser.cabal --- a/llvm-pretty-bc-parser.cabal +++ b/llvm-pretty-bc-parser.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 Name: llvm-pretty-bc-parser -Version: 0.6.0.0 +Version: 0.6.1.0 License: BSD-3-Clause License-file: LICENSE Author: Trevor Elliott @@ -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, diff --git a/src/Data/LLVM/BitCode/IR/Constants.hs b/src/Data/LLVM/BitCode/IR/Constants.hs --- a/src/Data/LLVM/BitCode/IR/Constants.hs +++ b/src/Data/LLVM/BitCode/IR/Constants.hs @@ -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 diff --git a/src/Data/LLVM/BitCode/IR/Function.hs b/src/Data/LLVM/BitCode/IR/Function.hs --- a/src/Data/LLVM/BitCode/IR/Function.hs +++ b/src/Data/LLVM/BitCode/IR/Function.hs @@ -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) diff --git a/src/Data/LLVM/BitCode/IR/Metadata.hs b/src/Data/LLVM/BitCode/IR/Metadata.hs --- a/src/Data/LLVM/BitCode/IR/Metadata.hs +++ b/src/Data/LLVM/BitCode/IR/Metadata.hs @@ -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) diff --git a/src/Data/LLVM/BitCode/IR/Module.hs b/src/Data/LLVM/BitCode/IR/Module.hs --- a/src/Data/LLVM/BitCode/IR/Module.hs +++ b/src/Data/LLVM/BitCode/IR/Module.hs @@ -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 diff --git a/src/Data/LLVM/BitCode/IR/Types.hs b/src/Data/LLVM/BitCode/IR/Types.hs --- a/src/Data/LLVM/BitCode/IR/Types.hs +++ b/src/Data/LLVM/BitCode/IR/Types.hs @@ -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 diff --git a/src/Data/LLVM/BitCode/IR/Values.hs b/src/Data/LLVM/BitCode/IR/Values.hs --- a/src/Data/LLVM/BitCode/IR/Values.hs +++ b/src/Data/LLVM/BitCode/IR/Values.hs @@ -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" diff --git a/src/Data/LLVM/BitCode/Parse.hs b/src/Data/LLVM/BitCode/Parse.hs --- a/src/Data/LLVM/BitCode/Parse.hs +++ b/src/Data/LLVM/BitCode/Parse.hs @@ -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 = diff --git a/unit-test/Tests/ExpressionInstances.hs b/unit-test/Tests/ExpressionInstances.hs --- a/unit-test/Tests/ExpressionInstances.hs +++ b/unit-test/Tests/ExpressionInstances.hs @@ -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 diff --git a/unit-test/Tests/PrimInstances.hs b/unit-test/Tests/PrimInstances.hs --- a/unit-test/Tests/PrimInstances.hs +++ b/unit-test/Tests/PrimInstances.hs @@ -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